From d974365ef5928048edb87af218f6105ae454c3b6 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Thu, 25 Jun 2015 10:48:03 +0200 Subject: dev/tool/anomaly-traces-parser.el An .emacs-ready elisp snippet to parse location of Anomaly backtraces and jump to them conveniently from the Emacs *compilation* output. --- dev/README | 3 +++ dev/tools/anomaly-traces-parser.el | 28 ++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+) create mode 100644 dev/tools/anomaly-traces-parser.el diff --git a/dev/README b/dev/README index 5edf64c8f2..814f609576 100644 --- a/dev/README +++ b/dev/README @@ -45,3 +45,6 @@ Makefile.subdir: makefile dedicated to intensive work in a given subdirectory Makefile.devel: utilities to automatically launch coq in various states Makefile.common: used by other Makefiles objects.el: various development utilities at emacs level +anomaly-traces-parser.el: a .emacs-ready elisp snippet to parse + location of Anomaly backtraces and jump to them conveniently from + the Emacs *compilation* output. diff --git a/dev/tools/anomaly-traces-parser.el b/dev/tools/anomaly-traces-parser.el new file mode 100644 index 0000000000..68f54266f9 --- /dev/null +++ b/dev/tools/anomaly-traces-parser.el @@ -0,0 +1,28 @@ +;; This Elisp snippet adds a regexp parser for the format of Anomaly +;; backtraces (coqc -bt ...), to the error parser of the Compilation +;; mode (C-c C-c: "Compile command: ..."). Once the +;; coq-change-error-alist-for-backtraces function has run, file +;; locations in traces are recognized and can be jumped from easily +;; from the *compilation* buffer. + +;; You can just copy everything below to your .emacs and this will be +;; enabled from any compilation command launched from an OCaml file. + +(defun coq-change-error-alist-for-backtraces () + "Hook to change the compilation-error-regexp-alist variable, to + search the coq backtraces for error locations" + (interactive) + (add-to-list + 'compilation-error-regexp-alist-alist + '(coq-backtrace + "^ *\\(?:raise\\|frame\\) @ file \\(\"?\\)\\([^,\" \n\t<>]+\\)\\1,\ + lines? \\([0-9]+\\)-?\\([0-9]+\\)?\\(?:$\\|,\ + \\(?: characters? \\([0-9]+\\)-?\\([0-9]+\\)?:?\\)?\\)" + 2 (3 . 4) (5 . 6))) + (add-to-list 'compilation-error-regexp-alist 'coq-backtrace)) + +;; this Anomaly parser should be available when one is hacking +;; on the *OCaml* code of Coq (adding bugs), so we enable it +;; through the OCaml mode hooks. +(add-hook 'caml-mode-hook 'coq-change-error-alist-for-backtraces) +(add-hook 'tuareg-mode-hook 'coq-change-error-alist-for-backtraces) -- cgit v1.2.3 From 85c9add9486bbb2d42c0765f4db88ecfcbf2ac39 Mon Sep 17 00:00:00 2001 From: mlasson Date: Mon, 27 Jul 2015 12:49:52 +0200 Subject: Traversal of inductive defs in Print Assumptions This patch implements the traversal of inductive definitions in the traverse function of toplevel/assumptions.ml which recursively collects references in terms. In my opinion, this fixes a bug (but it could be argued that inductive definitions were not traversed on purpose). I think that is not possible to use this bug to hide a meaningful use of an axiom. You can try the patch with the following coq script: Axiom n1 : nat. Axiom n2 : nat. Axiom n3 : nat. Inductive I1 (p := n1) : Type := c1. Inductive I2 : let p := n2 in Type := c2. Inductive I3 : Type := c3 : let p := n3 in I3. Inductive J : I1 -> I2 -> I3 -> Type := | cj : J c1 c2 c3. Inductive K : I1 -> I2 -> I3 -> Type := . Definition T := I1 -> I2 -> I3. Definition C := c1. Print Assumptions I1. Print Assumptions I2. Print Assumptions I3. Print Assumptions J. Print Assumptions K. Print Assumptions T. Print Assumptions C. Print Assumptions c1. Print Assumptions c2. Print Assumptions c3. Print Assumptions cj. The patch is a bit more complicated that I would have liked due to the feature introduced in commit 2defd4c. Since this commit, Print Assumptions also displays the type proved when one destruct an axiom inhabiting an empty type. This provides more information about where the old implementation of the admit tactic is used. I am not a big fan of this feature, especially since the change in the admit tactic. PS: In order to write some tests, I had to change the criteria for picking which axiom destruction are printed. The original criteria was : | Case (_,oty,c,[||]) -> (* non dependent match on an inductive with no constructor *) begin match Constr.(kind oty, kind c) with | Lambda(Anonymous,_,oty), Const (kn, _) when Vars.noccurn 1 oty && not (Declareops.constant_has_body (lookup_constant kn)) -> and I replaced Anonymous by _. Indeed, an Anonymous name here could only be built using the "case" tactic and the pretyper seems to always provide a name when compiling "match axiom as _ with end". And I wanted to test what happened when this destruction occurs in inductive definitions (which is of course weird in practice), for instance: Inductive I4 (X : Type) (p := match absurd return X with end) : Type -> Type := c4 : forall (q := match absurd return X with end) (Y : Type) (r := match absurd return Y with end), I4 X Y. The ability of "triggering" the display of this information only when using the "case" tactic (and not destruct or pattern matching written by hand) could have been a feature. If so, please feel free to change back the criteria to "Anonymous". --- toplevel/assumptions.ml | 99 ++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 86 insertions(+), 13 deletions(-) diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index a11653a43b..61ee9562f7 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -141,8 +141,6 @@ let label_of = function | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn) | VarRef id -> Label.of_id id -let push (r : Context.rel_declaration) (ctx : Context.rel_context) = r :: ctx - let rec traverse current ctx accu t = match kind_of_term t with | Var id -> let body () = match Global.lookup_named id with (_, body, _) -> body in @@ -150,24 +148,26 @@ let rec traverse current ctx accu t = match kind_of_term t with | Const (kn, _) -> let body () = Global.body_of_constant_body (lookup_constant kn) in traverse_object accu body (ConstRef kn) -| Ind (ind, _) -> - traverse_object accu (fun () -> None) (IndRef ind) -| Construct (cst, _) -> - traverse_object accu (fun () -> None) (ConstructRef cst) +| Ind ((mind, _) as ind, _) -> + traverse_inductive accu mind (IndRef ind) +| Construct (((mind, _), _) as cst, _) -> + traverse_inductive accu mind (ConstructRef cst) | Meta _ | Evar _ -> assert false | Case (_,oty,c,[||]) -> - (* non dependent match on an inductive with no constructors *) + (* non dependent match on an inductive with no constructors *) begin match Constr.(kind oty, kind c) with - | Lambda(Anonymous,_,oty), Const (kn, _) + | Lambda(_,_,oty), Const (kn, _) when Vars.noccurn 1 oty && not (Declareops.constant_has_body (lookup_constant kn)) -> let body () = Global.body_of_constant_body (lookup_constant kn) in traverse_object ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn) | _ -> - Termops.fold_constr_with_full_binders push (traverse current) ctx accu t + Termops.fold_constr_with_full_binders + Context.add_rel_decl (traverse current) ctx accu t end -| _ -> Termops.fold_constr_with_full_binders push (traverse current) ctx accu t +| _ -> Termops.fold_constr_with_full_binders + Context.add_rel_decl (traverse current) ctx accu t and traverse_object ?inhabits (curr, data, ax2ty) body obj = let data, ax2ty = @@ -179,20 +179,93 @@ and traverse_object ?inhabits (curr, data, ax2ty) body obj = let ax2ty = if Option.is_empty inhabits then ax2ty else let ty = Option.get inhabits in - try let l = Refmap.find obj ax2ty in Refmap.add obj (ty::l) ax2ty + try let l = Refmap.find obj ax2ty in Refmap.add obj (ty::l) ax2ty with Not_found -> Refmap.add obj [ty] ax2ty in data, ax2ty | Some body -> if already_in then data, ax2ty else let contents,data,ax2ty = - traverse (label_of obj) [] (Refset.empty,data,ax2ty) body in + traverse (label_of obj) Context.empty_rel_context + (Refset.empty,data,ax2ty) body in Refmap.add obj contents data, ax2ty in (Refset.add obj curr, data, ax2ty) +(** Collects the references occurring in the declaration of mutual inductive + definitions. All the constructors and names of a mutual inductive + definition share exactly the same dependencies. Also, there is no explicit + dependency between mutually defined inductives and constructors. *) +and traverse_inductive (curr, data, ax2ty) mind obj = + let firstind_ref = (IndRef (mind, 0)) in + let label = label_of obj in + let data, ax2ty = + (* Invariant : I_0 \in data iff I_i \in data iff c_ij \in data + where I_0, I_1, ... are in the same mutual definition and c_ij + are all their constructors. *) + if Refmap.mem firstind_ref data then data, ax2ty else + let mib = Global.lookup_mind mind in + (* Collects references of parameters *) + let param_ctx = mib.mind_params_ctxt in + let nparam = List.length param_ctx in + let accu = + traverse_context label Context.empty_rel_context + (Refset.empty, data, ax2ty) param_ctx + in + (* Build the context of all arities *) + let arities_ctx = + let global_env = Global.env () in + Array.fold_left (fun accu oib -> + let pspecif = Univ.in_punivs (mib, oib) in + let ind_type = Inductive.type_of_inductive global_env pspecif in + let ind_name = Name oib.mind_typename in + Context.add_rel_decl (ind_name, None, ind_type) accu) + Context.empty_rel_context mib.mind_packets + in + (* For each inductive, collects references in their arity and in the type + of constructors*) + let (contents, data, ax2ty) = Array.fold_left (fun accu oib -> + let arity_wo_param = + List.rev (List.skipn nparam (List.rev oib.mind_arity_ctxt)) + in + let accu = + traverse_context + label param_ctx accu arity_wo_param + in + Array.fold_left (fun accu cst_typ -> + let param_ctx, cst_typ_wo_param = Term.decompose_prod_n_assum nparam cst_typ in + let ctx = Context.(fold_rel_context add_rel_decl ~init:arities_ctx param_ctx) in + traverse label ctx accu cst_typ_wo_param) + accu oib.mind_user_lc) + accu mib.mind_packets + in + (* Maps all these dependencies to inductives and constructors*) + let data = Array.fold_left_i (fun n data oib -> + let ind = (mind, n) in + let data = Refmap.add (IndRef ind) contents data in + Array.fold_left_i (fun k data _ -> + Refmap.add (ConstructRef (ind, k+1)) contents data + ) data oib.mind_consnames) data mib.mind_packets + in + data, ax2ty + in + (Refset.add obj curr, data, ax2ty) + +(** Collects references in a rel_context. *) +and traverse_context current ctx accu ctxt = + snd (Context.fold_rel_context (fun decl (ctx, accu) -> + match decl with + | (_, Some c, t) -> + let accu = traverse current ctx (traverse current ctx accu t) c in + let ctx = Context.add_rel_decl decl ctx in + ctx, accu + | (_, None, t) -> + let accu = traverse current ctx accu t in + let ctx = Context.add_rel_decl decl ctx in + ctx, accu) ctxt ~init:(ctx, accu)) + let traverse current t = let () = modcache := MPmap.empty in - traverse current [] (Refset.empty, Refmap.empty, Refmap.empty) t + traverse current Context.empty_rel_context (Refset.empty, Refmap.empty, Refmap.empty) t (** Hopefully bullet-proof function to recover the type of a constant. It just ignores all the universe stuff. There are many issues that can arise when -- cgit v1.2.3 From 62ca663881ac7f731e2cf8a574c2e615f8d4a900 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 5 Aug 2015 16:16:13 +0200 Subject: README in MarkDown --- README | 66 --------------------------------------------------------------- README.md | 41 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 66 deletions(-) delete mode 100644 README create mode 100644 README.md diff --git a/README b/README deleted file mode 100644 index 293ee4c8f2..0000000000 --- a/README +++ /dev/null @@ -1,66 +0,0 @@ - - THE COQ V8 SYSTEM - ================= - -INSTALLATION. -============= - - See the file INSTALL for installation procedure. - - -DOCUMENTATION. -============== - - The documentation is part of the archive in directory doc. The - documentation of the last released version is available on the Coq - web site at http://coq.inria.fr/doc. - - -CHANGES. -======== - - There is a file named CHANGES that explains the differences and the - incompatibilities since last versions. If you upgrade Coq, please read - it carefully. - - -AVAILABILITY. -============= - - Coq is available from http://coq.inria.fr. - - -THE COQ CLUB. -============= - - The Coq Club moderated mailing list is meant to be a standard way - to discuss questions about the Coq system and related topics. The - subscription link can be found at http://coq.inria.fr/community. - - The topics to be discussed in the club should include: - - * technical problems; - - * questions about proof developments; - - * suggestions and questions about the implementation; - - * announcements of proofs; - - * theoretical questions about typed lambda-calculi which are - closely related to Coq. - - For any questions/suggestions about the Coq Club, please write to - coq-club-request@inria.fr. - - -BUGS REPORT. -============ - - Send your bug reports by filling a form at - - http://coq.inria.fr/bugs - - To be effective, bug reports should mention the Caml version used - to compile and run Coq, the Coq version (coqtop -v), the configuration - used, and include a complete source example leading to the bug. diff --git a/README.md b/README.md new file mode 100644 index 0000000000..3c9ebcb3f0 --- /dev/null +++ b/README.md @@ -0,0 +1,41 @@ +# THE COQ V8 SYSTEM + +## INSTALLATION +See the file `INSTALL` for installation procedure. + +## DOCUMENTATION +The documentation is part of the archive in directory doc. The +documentation of the last released version is available on the Coq +web site at [coq.inria.fr/doc](http://coq.inria.fr/doc). + +## CHANGES +There is a file named `CHANGES` that explains the differences and the +incompatibilities since last versions. If you upgrade Coq, please read +it carefully. + +## AVAILABILITY +Coq is available from [coq.inria.fr](http://coq.inria.fr). + +## THE COQ CLUB +The Coq Club moderated mailing list is meant to be a standard way +to discuss questions about the Coq system and related topics. The +subscription link can be found at [coq.inria.fr/community](http://coq.inria.fr/community). + +The topics to be discussed in the club should include: + +* technical problems; +* questions about proof developments; +* suggestions and questions about the implementation; +* announcements of proofs; +* theoretical questions about typed lambda-calculi which are + closely related to Coq. + +For any questions/suggestions about the Coq Club, please write to +`coq-club-request@inria.fr`. + +## BUGS REPORT +Send your bug reports by filling a form at [coq.inria.fr/bugs](http://coq.inria.fr/bugs). + +To be effective, bug reports should mention the OCaml version used +to compile and run Coq, the Coq version (`coqtop -v`), the configuration +used, and include a complete source example leading to the bug. -- cgit v1.2.3 From c3d1ca3e0957d6380143bdce29bfccbe1b05f537 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 5 Aug 2015 16:19:07 +0200 Subject: Simpler titles --- README.md | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index 3c9ebcb3f0..2329b536bf 100644 --- a/README.md +++ b/README.md @@ -1,22 +1,22 @@ -# THE COQ V8 SYSTEM +# Coq -## INSTALLATION +## Installation See the file `INSTALL` for installation procedure. -## DOCUMENTATION +## Documentation The documentation is part of the archive in directory doc. The documentation of the last released version is available on the Coq web site at [coq.inria.fr/doc](http://coq.inria.fr/doc). -## CHANGES +## Changes There is a file named `CHANGES` that explains the differences and the incompatibilities since last versions. If you upgrade Coq, please read it carefully. -## AVAILABILITY +## Availability Coq is available from [coq.inria.fr](http://coq.inria.fr). -## THE COQ CLUB +## The Coq Club The Coq Club moderated mailing list is meant to be a standard way to discuss questions about the Coq system and related topics. The subscription link can be found at [coq.inria.fr/community](http://coq.inria.fr/community). @@ -33,7 +33,7 @@ The topics to be discussed in the club should include: For any questions/suggestions about the Coq Club, please write to `coq-club-request@inria.fr`. -## BUGS REPORT +## Bugs report Send your bug reports by filling a form at [coq.inria.fr/bugs](http://coq.inria.fr/bugs). To be effective, bug reports should mention the OCaml version used -- cgit v1.2.3 From 0446b632883e7baa6979bd0251258ea3769c337b Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 5 Aug 2015 16:20:41 +0200 Subject: Description added --- README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/README.md b/README.md index 2329b536bf..a41ee7cc07 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,7 @@ # Coq +Coq is a formal proof management system. It provides a formal language to write +mathematical definitions, executable algorithms and theorems together with an +environment for semi-interactive development of machine-checked proofs. ## Installation See the file `INSTALL` for installation procedure. -- cgit v1.2.3 From 297b0cb44bbe8ec7304ca635c566815167266d4a Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 24 Jun 2015 11:28:44 +0200 Subject: Revert commit 18796b6aea453bdeef1ad12ce80eeb220bf01e67, close 3080 This reverts 18796b6aea453bdeef1ad12ce80eeb220bf01e67 (Slight change in the semantics of arguments scopes: scopes can no longer be bound to Funclass or Sortclass (this does not seem to be useful)). It is useful to have function_scope for, e.g., function composition. This allows users to, e.g., automatically interpret ∘ as morphism composition when expecting a morphism of categories, as functor composition when expecting a functor, and as function composition when expecting a function. Additionally, it is nicer to have fewer special cases in the OCaml code, and give more things a uniform syntax. (The scope type_scope should not be special-cased; this change is coming up next.) Also explicitly define [function_scope] in theories/Init/Notations.v. This closes bug #3080, Build a [function_scope] like [type_scope], or allow [Bind Scope ... with Sortclass] and [Bind Scope ... with Funclass] We now mention Funclass and Sortclass in the documentation of [Bind Scope] again. --- CHANGES | 3 +++ doc/refman/RefMan-syn.tex | 8 ++++---- interp/notation.ml | 37 ++++++++++++------------------------- interp/notation.mli | 7 +++++-- intf/vernacexpr.mli | 2 +- parsing/g_vernac.ml4 | 2 +- pretyping/classops.mli | 3 +++ printing/ppvernac.ml | 2 +- stm/texmacspp.ml | 8 +------- test-suite/output/Cases.out | 4 +++- test-suite/output/InitSyntax.out | 3 ++- test-suite/output/PrintInfos.out | 4 ++-- theories/Init/Notations.v | 4 ++++ toplevel/vernacentries.ml | 2 +- 14 files changed, 43 insertions(+), 46 deletions(-) diff --git a/CHANGES b/CHANGES index 08484a4b9b..12ee5d27fc 100644 --- a/CHANGES +++ b/CHANGES @@ -24,6 +24,9 @@ Tactics let tactics working under conjunctions apply sublemmas of the form "forall A, ... -> A". +Notations +- "Bind Scope" can once again bind "Funclass" and "Sortclass". + API - Some functions from pretyping/typing.ml and their derivatives were potential diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index aabc8a8995..3af72db78e 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -860,11 +860,11 @@ statically. For instance, if {\tt f} is a polymorphic function of type {\scope}, then {\tt a} of type {\tt t} in {\tt f~t~a} is not recognized as an argument to be interpreted in scope {\scope}. -\comindex{Bind Scope} -Any global reference can be bound by default to an -interpretation scope. The command to do it is +\comindex{Bind Scope} +More generally, any {\class} (see Chapter~\ref{Coercions-full}) can be +bound to an interpretation scope. The command to do it is \begin{quote} -{\tt Bind Scope} {\scope} \texttt{with} {\qualid} +{\tt Bind Scope} {\scope} \texttt{with} {\class} \end{quote} \Example diff --git a/interp/notation.ml b/interp/notation.ml index d18b804bfd..075e04cba0 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -556,23 +556,16 @@ let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) (* Mapping classes to scopes *) -type scope_class = ScopeRef of global_reference | ScopeSort +open Classops -let scope_class_compare sc1 sc2 = match sc1, sc2 with -| ScopeRef gr1, ScopeRef gr2 -> RefOrdered.compare gr1 gr2 -| ScopeRef _, ScopeSort -> -1 -| ScopeSort, ScopeRef _ -> 1 -| ScopeSort, ScopeSort -> 0 +type scope_class = cl_typ -let scope_class_of_reference x = ScopeRef x +let scope_class_compare : scope_class -> scope_class -> int = + cl_typ_ord let compute_scope_class t = - let t', _ = decompose_appvect (Reductionops.whd_betaiotazeta Evd.empty t) in - match kind_of_term t' with - | Var _ | Const _ | Ind _ -> ScopeRef (global_of_constr t') - | Proj (p, c) -> ScopeRef (ConstRef (Projection.constant p)) - | Sort _ -> ScopeSort - | _ -> raise Not_found + let (cl,_,_) = find_class_type Evd.empty t in + cl module ScopeClassOrd = struct @@ -583,7 +576,7 @@ end module ScopeClassMap = Map.Make(ScopeClassOrd) let initial_scope_class_map : scope_name ScopeClassMap.t = - ScopeClassMap.add ScopeSort "type_scope" ScopeClassMap.empty + ScopeClassMap.add CL_SORT type_scope ScopeClassMap.empty let scope_class_map = ref initial_scope_class_map @@ -617,8 +610,8 @@ let compute_arguments_scope t = fst (compute_arguments_scope_full t) let compute_type_scope t = find_scope_class_opt (try Some (compute_scope_class t) with Not_found -> None) -let compute_scope_of_global ref = - find_scope_class_opt (Some (ScopeRef ref)) +let scope_class_of_class (x : cl_typ) : scope_class = + x (** Updating a scope list, thanks to a list of argument classes and the current Bind Scope base. When some current scope @@ -650,12 +643,8 @@ let load_arguments_scope _ (_,(_,r,scl,cls)) = let cache_arguments_scope o = load_arguments_scope 1 o -let subst_scope_class subst cs = match cs with - | ScopeSort -> Some cs - | ScopeRef t -> - let (t',c) = subst_global subst t in - if t == t' then Some cs - else try Some (compute_scope_class c) with Not_found -> None +let subst_scope_class subst cs = + try Some (subst_cl_typ subst cs) with Not_found -> None let subst_arguments_scope (subst,(req,r,scl,cls)) = let r' = fst (subst_global subst r) in @@ -788,9 +777,7 @@ let pr_delimiters_info = function let classes_of_scope sc = ScopeClassMap.fold (fun cl sc' l -> if String.equal sc sc' then cl::l else l) !scope_class_map [] -let pr_scope_class = function - | ScopeSort -> str "Sort" - | ScopeRef t -> pr_global_env Id.Set.empty t +let pr_scope_class = pr_class let pr_scope_classes sc = let l = classes_of_scope sc in diff --git a/interp/notation.mli b/interp/notation.mli index 38bd5fc7b8..85c4be4cc1 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -153,7 +153,9 @@ val find_arguments_scope : global_reference -> scope_name option list type scope_class -val scope_class_of_reference : global_reference -> scope_class +(** Comparison of scope_class *) +val scope_class_compare : scope_class -> scope_class -> int + val subst_scope_class : Mod_subst.substitution -> scope_class -> scope_class option @@ -162,7 +164,8 @@ val declare_ref_arguments_scope : global_reference -> unit val compute_arguments_scope : Term.types -> scope_name option list val compute_type_scope : Term.types -> scope_name option -val compute_scope_of_global : global_reference -> scope_name option + +val scope_class_of_class : Classops.cl_typ -> scope_class (** Building notation key *) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index b72577e1e0..94e3739d4a 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -292,7 +292,7 @@ type vernac_expr = obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) | VernacDelimiters of scope_name * string option - | VernacBindScope of scope_name * reference or_by_notation list + | VernacBindScope of scope_name * class_rawexpr list | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * constr_expr * scope_name option | VernacNotation of diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index fe9c582408..5a6dfa547c 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1048,7 +1048,7 @@ GEXTEND Gram VernacDelimiters (sc, None) | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; - refl = LIST1 smart_global -> VernacBindScope (sc,refl) + refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) | IDENT "Infix"; local = obsolete_locality; op = ne_lstring; ":="; p = constr; diff --git a/pretyping/classops.mli b/pretyping/classops.mli index e2bb2d1a00..1858004900 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -26,6 +26,9 @@ val cl_typ_eq : cl_typ -> cl_typ -> bool val subst_cl_typ : substitution -> cl_typ -> cl_typ +(** Comparison of [cl_typ] *) +val cl_typ_ord : cl_typ -> cl_typ -> int + (** This is the type of infos for declared classes *) type cl_info_typ = { cl_param : int } diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 4e889e55f0..c4689c918d 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -656,7 +656,7 @@ module Make | VernacBindScope (sc,cll) -> return ( keyword "Bind Scope" ++ spc () ++ str sc ++ - spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_smart_global cll + spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_class_rawexpr cll ) | VernacArgumentsScope (q,scl) -> let pr_opt_scope = function diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index aaa6c2c07d..af506015de 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -513,13 +513,6 @@ let rec tmpp v loc = xmlScope loc "delimit" name ~attr:["delimiter",tag] [] | VernacDelimiters (name,None) -> xmlScope loc "undelimit" name ~attr:[] [] - | VernacBindScope (name,l) -> - xmlScope loc "bind" name - (List.map (function - | ByNotation(loc,name,None) -> xmlNotation [] name loc [] - | ByNotation(loc,name,Some d) -> - xmlNotation ["delimiter",d] name loc [] - | AN ref -> xmlReference ref) l) | VernacInfix (_,((_,name),sml),ce,sn) -> let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in let sc_attr = @@ -535,6 +528,7 @@ let rec tmpp v loc = | Some scope -> ["scope", scope] | None -> [] in xmlNotation (sc_attr @ attrs) name loc [pp_expr ce] + | VernacBindScope _ as x -> xmlTODO loc x | VernacNotationAddFormat _ as x -> xmlTODO loc x | VernacUniverse _ | VernacConstraint _ diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 09f032d478..92e70cf1cb 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -6,6 +6,8 @@ fix F (t : t) : P t := end : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t + +Argument scopes are [function_scope function_scope _] = fun d : TT => match d with | @CTT _ _ b => b end @@ -24,7 +26,7 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y -Argument scopes are [nat_scope nat_scope _ _ _] +Argument scopes are [nat_scope nat_scope function_scope _ _] foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index bbfd3405af..c17c63e724 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -4,7 +4,8 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := For sig2: Argument A is implicit For exist2: Argument A is implicit For sig2: Argument scopes are [type_scope type_scope type_scope] -For exist2: Argument scopes are [type_scope _ _ _ _ _] +For exist2: Argument scopes are [type_scope function_scope function_scope _ _ + _] exists x : nat, x = x : Prop fun b : bool => if b then b else b diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index ba076f050a..98420409e8 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -2,7 +2,7 @@ existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} existT is template universe polymorphic Argument A is implicit -Argument scopes are [type_scope _ _ _] +Argument scopes are [type_scope function_scope _ _] Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> {x : A & P x} @@ -10,7 +10,7 @@ Inductive sigT (A : Type) (P : A -> Type) : Type := For sigT: Argument A is implicit For existT: Argument A is implicit For sigT: Argument scopes are [type_scope type_scope] -For existT: Argument scopes are [type_scope _ _ _] +For existT: Argument scopes are [type_scope function_scope _ _] existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index a7bdba90aa..50728136ba 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -76,9 +76,13 @@ Reserved Notation "{ x : A & P }" (at level 0, x at level 99). Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99). Delimit Scope type_scope with type. +Delimit Scope function_scope with function. Delimit Scope core_scope with core. +Bind Scope function_scope with Funclass. + Open Scope core_scope. +Open Scope function_scope. Open Scope type_scope. (** ML Tactic Notations *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index cfbdaccec4..51ddf0c068 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -45,7 +45,7 @@ let cl_of_qualid = function | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r) let scope_class_of_qualid qid = - Notation.scope_class_of_reference (Smartlocate.smart_global qid) + Notation.scope_class_of_class (cl_of_qualid qid) (*******************) (* "Show" commands *) -- cgit v1.2.3 From 6aa58955515dff338ea85d59073dfc0d0c7648ab Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 24 Jun 2015 15:41:11 +0200 Subject: Move type_scope into user space, fix some output logs --- interp/constrextern.ml | 2 +- interp/constrintern.ml | 17 ++++++++++------- interp/notation.ml | 9 +++++---- interp/notation.mli | 4 +++- test-suite/bugs/closed/3080.v | 18 ++++++++++++++++++ test-suite/bugs/closed/3612.v | 2 ++ test-suite/bugs/closed/3649.v | 4 +++- theories/Init/Notations.v | 1 + 8 files changed, 43 insertions(+), 14 deletions(-) create mode 100644 test-suite/bugs/closed/3080.v diff --git a/interp/constrextern.ml b/interp/constrextern.ml index f57772ecb0..1c60d5c2f7 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -788,7 +788,7 @@ let rec extern inctx scopes vars r = Miscops.map_cast_type (extern_typ scopes vars) c') and extern_typ (_,scopes) = - extern true (Some Notation.type_scope,scopes) + extern true (Notation.current_type_scope_name (),scopes) and sub_extern inctx (_,scopes) = extern inctx (None,scopes) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 8c56d0ccfe..d572508a15 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -298,7 +298,7 @@ let set_var_scope loc id istermvar env ntnvars = (* Not in a notation *) () -let set_type_scope env = {env with tmp_scope = Some Notation.type_scope} +let set_type_scope env = {env with tmp_scope = Notation.current_type_scope_name ()} let reset_tmp_scope env = {env with tmp_scope = None} @@ -449,12 +449,15 @@ let intern_generalization intern env lvar loc bk ak c = | Some AbsPi -> true | Some _ -> false | None -> - let is_type_scope = match env.tmp_scope with + match Notation.current_type_scope_name () with + | Some type_scope -> + let is_type_scope = match env.tmp_scope with + | None -> false + | Some sc -> String.equal sc type_scope + in + is_type_scope || + String.List.mem type_scope env.scopes | None -> false - | Some sc -> String.equal sc Notation.type_scope - in - is_type_scope || - String.List.mem Notation.type_scope env.scopes in if pi then (fun (id, loc') acc -> @@ -1755,7 +1758,7 @@ let extract_ids env = Id.Set.empty let scope_of_type_kind = function - | IsType -> Some Notation.type_scope + | IsType -> Notation.current_type_scope_name () | OfType typ -> compute_type_scope typ | WithoutTypeConstraint -> None diff --git a/interp/notation.ml b/interp/notation.ml index 075e04cba0..8395f7d9ad 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -65,11 +65,9 @@ let empty_scope = { } let default_scope = "" (* empty name, not available from outside *) -let type_scope = "type_scope" (* special scope used for interpreting types *) let init_scope_map () = - scope_map := String.Map.add default_scope empty_scope !scope_map; - scope_map := String.Map.add type_scope empty_scope !scope_map + scope_map := String.Map.add default_scope empty_scope !scope_map (**********************************************************************) (* Operations on scopes *) @@ -576,7 +574,7 @@ end module ScopeClassMap = Map.Make(ScopeClassOrd) let initial_scope_class_map : scope_name ScopeClassMap.t = - ScopeClassMap.add CL_SORT type_scope ScopeClassMap.empty + ScopeClassMap.empty let scope_class_map = ref initial_scope_class_map @@ -610,6 +608,9 @@ let compute_arguments_scope t = fst (compute_arguments_scope_full t) let compute_type_scope t = find_scope_class_opt (try Some (compute_scope_class t) with Not_found -> None) +let current_type_scope_name () = + find_scope_class_opt (Some CL_SORT) + let scope_class_of_class (x : cl_typ) : scope_class = x diff --git a/interp/notation.mli b/interp/notation.mli index 85c4be4cc1..2bfbb33c2d 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -29,7 +29,6 @@ type scopes (** = [scope_name list] *) type local_scopes = tmp_scope_name option * scope_name list -val type_scope : scope_name val declare_scope : scope_name -> unit val current_scopes : unit -> scopes @@ -165,6 +164,9 @@ val declare_ref_arguments_scope : global_reference -> unit val compute_arguments_scope : Term.types -> scope_name option list val compute_type_scope : Term.types -> scope_name option +(** Get the current scope bound to Sortclass, if it exists *) +val current_type_scope_name : unit -> scope_name option + val scope_class_of_class : Classops.cl_typ -> scope_class (** Building notation key *) diff --git a/test-suite/bugs/closed/3080.v b/test-suite/bugs/closed/3080.v new file mode 100644 index 0000000000..7d0dc090e1 --- /dev/null +++ b/test-suite/bugs/closed/3080.v @@ -0,0 +1,18 @@ +(* -*- coq-prog-args: ("-emacs" "-nois") -*- *) +Delimit Scope type_scope with type. +Delimit Scope function_scope with function. + +Bind Scope type_scope with Sortclass. +Bind Scope function_scope with Funclass. + +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Notation "A -> B" := (forall (_ : A), B) : type_scope. + +Definition compose {A B C} (g : B -> C) (f : A -> B) := + fun x : A => g (f x). + +Notation " g ∘ f " := (compose g f) + (at level 40, left associativity) : function_scope. + +Fail Check (fun x => x) ∘ (fun x => x). (* this [Check] should fail, as [function_scope] is not opened *) +Check compose ((fun x => x) ∘ (fun x => x)) (fun x => x). (* this check should succeed, as [function_scope] should be automatically bound in the arugments to [compose] *) diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v index 9125ab16dd..324c12525c 100644 --- a/test-suite/bugs/closed/3612.v +++ b/test-suite/bugs/closed/3612.v @@ -6,6 +6,8 @@ lines, then from 421 lines to 428 lines, then from 444 lines to 429 lines, then Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y :> T" (at level 70, y at next level, no associativity). Reserved Notation "x = y" (at level 70, no associativity). +Delimit Scope type_scope with type. +Bind Scope type_scope with Sortclass. Open Scope type_scope. Global Set Universe Polymorphism. Notation "A -> B" := (forall (_ : A), B) : type_scope. diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v index 06188e7b1b..fc60897d21 100644 --- a/test-suite/bugs/closed/3649.v +++ b/test-suite/bugs/closed/3649.v @@ -4,6 +4,8 @@ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y" (at level 70, no associativity). +Delimit Scope type_scope with type. +Bind Scope type_scope with Sortclass. Open Scope type_scope. Axiom admit : forall {T}, T. Notation "A -> B" := (forall (_ : A), B) : type_scope. @@ -54,4 +56,4 @@ Goal forall (C D : PreCategory) (G G' : Functor C D) (** This [change] succeeded, but did not progress, in 07e4438bd758c2ced8caf09a6961ccd77d84e42b, because [T0 x o T1 x] was not found in the goal *) let T0 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T0) end in let T1 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T1) end in - progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)). \ No newline at end of file + progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)). diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 50728136ba..ef6125e6fa 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -79,6 +79,7 @@ Delimit Scope type_scope with type. Delimit Scope function_scope with function. Delimit Scope core_scope with core. +Bind Scope type_scope with Sortclass. Bind Scope function_scope with Funclass. Open Scope core_scope. -- cgit v1.2.3 From 2834cf72add1459d7460e3c1757e7352a1ff7466 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Sep 2015 10:34:19 +0200 Subject: Extending the grammar for CoqIDE preferences so as to match trunk. --- ide/config_lexer.mll | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 87cc6d06e7..3671535680 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -17,7 +17,7 @@ let space = [' ' '\010' '\013' '\009' '\012'] let char = ['A'-'Z' 'a'-'z' '_' '0'-'9'] -let ident = char+ +let ident = (char | '.')+ let ignore = space | ('#' [^ '\n']*) rule prefs m = parse -- cgit v1.2.3 From 77101ea44d88983ec399c8662b81f9392d92110b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Sep 2015 10:40:49 +0200 Subject: Fixing the XML lexer definition of names to match the standard. --- lib/xml_lexer.mll | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll index f6943dd132..0b541ee047 100644 --- a/lib/xml_lexer.mll +++ b/lib/xml_lexer.mll @@ -88,7 +88,8 @@ let error lexbuf e = let newline = ['\n'] let break = ['\r'] let space = [' ' '\t'] -let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-'] +let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-' '.'] +let ident = ['A'-'Z' 'a'-'z' '_' ':'] identchar+ let entitychar = ['A'-'Z' 'a'-'z'] let pcchar = [^ '\r' '\n' '<' '>' '&'] @@ -226,7 +227,7 @@ and entity = parse { raise (Error EUnterminatedEntity) } and ident_name = parse - | identchar+ + | ident { lexeme lexbuf } | _ | eof { error lexbuf EIdentExpected } @@ -252,7 +253,7 @@ and attributes = parse } and attribute = parse - | identchar+ + | ident { lexeme lexbuf } | _ | eof { error lexbuf EAttributeNameExpected } -- cgit v1.2.3 From 3140d22d75ac3f30e97c799a05819b8838d167ca Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Sep 2015 10:54:41 +0200 Subject: Fixing previous patch. --- lib/xml_lexer.mll | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll index 0b541ee047..290f2c89ab 100644 --- a/lib/xml_lexer.mll +++ b/lib/xml_lexer.mll @@ -89,7 +89,7 @@ let newline = ['\n'] let break = ['\r'] let space = [' ' '\t'] let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-' '.'] -let ident = ['A'-'Z' 'a'-'z' '_' ':'] identchar+ +let ident = ['A'-'Z' 'a'-'z' '_' ':'] identchar* let entitychar = ['A'-'Z' 'a'-'z'] let pcchar = [^ '\r' '\n' '<' '>' '&'] -- cgit v1.2.3 From f03aaf12eb7d89fa4caa59873e114c8cd125b950 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 10 Sep 2015 11:47:21 +0200 Subject: Assertion checking that invariant enforced by 0f8d1b92 always holds. When reifying a 31-bit integer after a VM computation, we check that no bit outside the 31 LSB is set to 1. --- kernel/environ.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/kernel/environ.ml b/kernel/environ.ml index 109e3830c2..bf12d6c6dc 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -584,7 +584,10 @@ let dispatch = Array.init 31 (fun n -> mkConstruct (digit_ind, nth_digit_plus_one i (30-n))) in - mkApp(mkConstruct(ind, 1), array_of_int tag) + (* We check that no bit above 31 is set to one. This assertion used to + fail in the VM, and led to conversion tests failing at Qed. *) + assert (Int.equal (tag lsr 31) 0); + mkApp(mkConstruct(ind, 1), array_of_int tag) in (* subfunction which dispatches the compiling information of an -- cgit v1.2.3 From 238725dd24d43574690b0111761b705753d3bee2 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Mon, 27 Apr 2015 15:40:48 +0200 Subject: typo in refman. --- doc/refman/RefMan-uti.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index 0729391062..c282083b5c 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -102,7 +102,7 @@ generator using for instance the command: This command generates a file \texttt{Makefile} that can be used to compile all the sources of the current project. It follows the -syntax described by the output of \texttt{\% coq\_makefile --help}. +syntax described by the output of \texttt{\% coq\_makefile ----help}. Once the \texttt{Makefile} file has been generated a first time, it can be used by the \texttt{make} command to compile part or all of the project. Note that once it has been generated once, as soon as -- cgit v1.2.3 From 490160d25d3caac1d2ea5beebbbebc959b1b3832 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 7 Jun 2015 14:39:18 +0200 Subject: Fixing bug #2498: Coqide navigation preferences delayed effect. --- ide/preferences.ml | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/ide/preferences.ml b/ide/preferences.ml index c59642d3a7..1bd9f587c7 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -711,38 +711,61 @@ let configure ?(apply=(fun () -> ())) () = ~f:(fun s -> current.project_file_name <- s) current.project_file_name in + let update_modifiers prefix mds = + let change ~path ~key ~modi ~changed = + if CString.is_sub prefix path 0 then + ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path) + in + GtkData.AccelMap.foreach change + in let help_string = "restart to apply" in let the_valid_mod = str_to_mod_list current.modifiers_valid in let modifier_for_tactics = + let cb l = + current.modifier_for_tactics <- mod_list_to_str l; + update_modifiers "/Tactics/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for Tactics Menu" (str_to_mod_list current.modifier_for_tactics) in let modifier_for_templates = + let cb l = + current.modifier_for_templates <- mod_list_to_str l; + update_modifiers "/Templates/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for Templates Menu" (str_to_mod_list current.modifier_for_templates) in let modifier_for_navigation = + let cb l = + current.modifier_for_navigation <- mod_list_to_str l; + update_modifiers "/Navigation/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for Navigation Menu" (str_to_mod_list current.modifier_for_navigation) in let modifier_for_display = + let cb l = + current.modifier_for_display <- mod_list_to_str l; + update_modifiers "/View/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for View Menu" (str_to_mod_list current.modifier_for_display) -- cgit v1.2.3 From 0528c147a9eee25668252537905d0c09ec20e3cd Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 13 Sep 2015 11:18:11 +0200 Subject: Coq_makefile: read TIMED and TIMECMD from environment. Useful e.g. with submakefiles. --- tools/coq_makefile.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 4b92d57082..b21845aea6 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -508,7 +508,7 @@ let parameters () = print "define donewline\n\n\nendef\n"; print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\\r' | tr '\\n' '@'; })))\n"; print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n"; - print "TIMED=\nTIMECMD=\nSTDTIME?=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\n"; + print "TIMED?=\nTIMECMD?=\nSTDTIME=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\n"; print "TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD))\n\n"; print "vo_to_obj = $(addsuffix .o,\\\n"; print " $(filter-out Warning: Error:,\\\n"; -- cgit v1.2.3 From f2f805ed8275f70767284f4d3c8a13db6f8c8923 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Sep 2015 01:16:26 +0200 Subject: Remove dead code in lazy reduction machine. --- kernel/closure.ml | 21 ++------------------- kernel/closure.mli | 2 -- kernel/reduction.ml | 17 ++++++----------- 3 files changed, 8 insertions(+), 32 deletions(-) diff --git a/kernel/closure.ml b/kernel/closure.ml index ea9b2755f2..bc414d9715 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -346,7 +346,6 @@ and fterm = | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr @@ -376,7 +375,6 @@ let update v1 no t = type stack_member = | Zapp of fconstr array - | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * constant | Zfix of fconstr * stack @@ -569,10 +567,6 @@ let rec to_constr constr_fun lfts v = | FFlex (ConstKey op) -> mkConstU op | FInd op -> mkIndU op | FConstruct op -> mkConstructU op - | FCase (ci,p,c,ve) -> - mkCase (ci, constr_fun lfts p, - constr_fun lfts c, - CArray.Fun1.map constr_fun lfts ve) | FCaseT (ci,p,c,ve,env) -> mkCase (ci, constr_fun lfts (mk_clos env p), constr_fun lfts c, @@ -646,9 +640,6 @@ let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s - | Zcase(ci,p,br)::s -> - let t = FCase(ci, p, m, br) in - zip {norm=neutr m.norm; term=t} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s @@ -731,7 +722,7 @@ let rec get_args n tys f e stk = (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function - | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _ + | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _ | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> @@ -842,7 +833,6 @@ let rec knh info m stk = | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) - | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with @@ -904,10 +894,6 @@ let rec knr info m stk = | None -> (set_norm m; (m,stk))) | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (depth, args, Zcase(ci,_,br)::s) -> - assert (ci.ci_npar>=0); - let rargs = drop_parameters depth ci.ci_npar args in - kni info br.(c-1) (rargs@s) | (depth, args, ZcaseT(ci,_,br,e)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in @@ -924,7 +910,7 @@ let rec knr info m stk = | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (_, args, (((Zcase _|ZcaseT _|Zproj _)::_) as stk')) -> + (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) @@ -953,9 +939,6 @@ let rec zip_term zfun m stk = | [] -> m | Zapp args :: s -> zip_term zfun (mkApp(m, Array.map zfun args)) s - | Zcase(ci,p,br)::s -> - let t = mkCase(ci, zfun p, m, Array.map zfun br) in - zip_term zfun t s | ZcaseT(ci,p,br,e)::s -> let t = mkCase(ci, zfun (mk_clos e p), m, Array.map (fun b -> zfun (mk_clos e b)) br) in diff --git a/kernel/closure.mli b/kernel/closure.mli index a3b0e0f301..c6f212aa55 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -119,7 +119,6 @@ type fterm = | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr @@ -136,7 +135,6 @@ type fterm = type stack_member = | Zapp of fconstr array - | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * constant | Zfix of fconstr * stack diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 3253cddf7c..2cf3f88735 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -56,8 +56,7 @@ let compare_stack_shape stk1 stk2 = | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 - | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1, - (Zcase(c2,_,_)|ZcaseT(c2,_,_,_))::s2) -> + | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -91,9 +90,8 @@ let pure_stack lfts stk = let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,e),(l,pstk)) -> - (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk) - | (Zcase(ci,p,br),(l,pstk)) -> - (l,Zlcase(ci,l,p,br)::pstk)) in + (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk)) + in snd (pure_rec lfts stk) (****************************************************************************) @@ -237,7 +235,6 @@ let rec no_arg_available = function | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk | Zproj _ :: _ -> true - | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true @@ -250,7 +247,6 @@ let rec no_nth_arg_available n = function if n >= k then no_nth_arg_available (n-k) stk else false | Zproj _ :: _ -> true - | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true @@ -260,13 +256,12 @@ let rec no_case_available = function | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk | Zproj (_,_,p) :: _ -> false - | Zcase _ :: _ -> false | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with - | (FLetIn _ | FCase _ | FCaseT _ | FApp _ + | (FLetIn _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk @@ -532,8 +527,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) - | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) - | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) + | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) + | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) -- cgit v1.2.3 From 2bc88f9a536c3db3c2d4a38a8a0da0500b895c7b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Sep 2015 18:35:48 +0200 Subject: Univs: Add universe binding lists to definitions ... lemmas and inductives to control which universes are bound and where in universe polymorphic definitions. Names stay outside the kernel. --- Makefile.build | 1 + intf/vernacexpr.mli | 15 ++++--- parsing/g_vernac.ml4 | 23 +++++----- plugins/funind/glob_term_to_relation.ml | 2 +- plugins/funind/indfun.ml | 26 +++++------ plugins/funind/merge.ml | 2 +- plugins/funind/recdef.ml | 8 +--- pretyping/evd.ml | 76 ++++++++++++++++++++++++--------- pretyping/evd.mli | 9 +++- printing/ppvernac.ml | 32 +++++++++----- proofs/pfedit.ml | 2 +- stm/lemmas.ml | 8 +++- stm/stm.ml | 4 +- stm/texmacspp.ml | 12 +++--- stm/vernac_classifier.ml | 14 +++--- tactics/elimschemes.ml | 4 +- tactics/leminv.ml | 2 +- tactics/rewrite.ml | 4 +- toplevel/command.ml | 53 +++++++++++++---------- toplevel/command.mli | 6 ++- toplevel/obligations.ml | 2 +- toplevel/record.ml | 9 ++-- toplevel/record.mli | 2 +- toplevel/vernacentries.ml | 18 ++++---- 24 files changed, 202 insertions(+), 132 deletions(-) diff --git a/Makefile.build b/Makefile.build index 6ceff2de95..0057b71684 100644 --- a/Makefile.build +++ b/Makefile.build @@ -94,6 +94,7 @@ HIDE := $(if $(VERBOSE),,@) LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) ) MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) +CAMLFLAGS:= $(CAMLFLAGS) -w +a-3-4-6-7-9-27-29-32..39-41..42-44-45-48 OCAMLC := $(OCAMLC) $(CAMLFLAGS) OCAMLOPT := $(OCAMLOPT) $(CAMLFLAGS) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index bb0331fcc4..37218fbf91 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -160,6 +160,9 @@ type option_ref_value = | StringRefValue of string | QualidRefValue of reference +(** Identifier and optional list of bound universes. *) +type plident = lident * lident list option + type sort_expr = glob_sort type definition_expr = @@ -168,10 +171,10 @@ type definition_expr = * constr_expr option type fixpoint_expr = - Id.t located * (Id.t located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option + plident * (Id.t located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option type cofixpoint_expr = - Id.t located * local_binder list * constr_expr * constr_expr option + plident * local_binder list * constr_expr * constr_expr option type local_decl_expr = | AssumExpr of lname * constr_expr @@ -190,14 +193,14 @@ type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list type inductive_expr = - lident with_coercion * local_binder list * constr_expr option * inductive_kind * + plident with_coercion * local_binder list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type one_inductive_expr = - lident * local_binder list * constr_expr option * constructor_expr list + plident * local_binder list * constr_expr option * constructor_expr list type proof_expr = - lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option) + plident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option) type grammar_tactic_prod_item_expr = | TacTerm of string @@ -305,7 +308,7 @@ type vernac_expr = (* Gallina *) | VernacDefinition of - (locality option * definition_object_kind) * lident * definition_expr + (locality option * definition_object_kind) * plident * definition_expr | VernacStartTheoremProof of theorem_kind * proof_expr list * bool | VernacEndProof of proof_end | VernacExactProof of constr_expr diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 11f78c708c..63850713f2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -196,9 +196,9 @@ GEXTEND Gram gallina: (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; + [ [ thm = thm_token; id = pidentref; bl = binders; ":"; c = lconstr; l = LIST0 - [ "with"; id = identref; bl = binders; ":"; c = lconstr -> + [ "with"; id = pidentref; bl = binders; ":"; c = lconstr -> (Some id,(bl,c,None)) ] -> VernacStartTheoremProof (thm, (Some id,(bl,c,None))::l, false) | stre = assumption_token; nl = inline; bl = assum_list -> @@ -206,10 +206,10 @@ GEXTEND Gram | stre = assumptions_token; nl = inline; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, nl, bl) - | d = def_token; id = identref; b = def_body -> + | d = def_token; id = pidentref; b = def_body -> VernacDefinition (d, id, b) | IDENT "Let"; id = identref; b = def_body -> - VernacDefinition ((Some Discharge, Definition), id, b) + VernacDefinition ((Some Discharge, Definition), (id, None), b) (* Gallina inductive declarations *) | priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> @@ -268,6 +268,9 @@ GEXTEND Gram | IDENT "Inline" -> DefaultInline | -> NoInline] ] ; + pidentref: + [ [ i = identref; l = OPT [ "@{" ; l = LIST1 identref; "}" -> l ] -> (i,l) ] ] + ; univ_constraint: [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; r = identref -> (l, ord, r) ] ] @@ -312,7 +315,7 @@ GEXTEND Gram | -> RecordDecl (None, []) ] ] ; inductive_definition: - [ [ oc = opt_coercion; id = identref; indpar = binders; + [ [ oc = opt_coercion; id = pidentref; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; lc=opt_constructors_or_fields; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] @@ -338,14 +341,14 @@ GEXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = identref; + [ [ id = pidentref; bl = binders_fixannot; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ] ; corec_definition: - [ [ id = identref; bl = binders; ty = type_cstr; + [ [ id = pidentref; bl = binders; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> ((id,bl,ty,def),ntn) ] ] ; @@ -605,15 +608,15 @@ GEXTEND Gram d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition - ((Some Global,CanonicalStructure),(Loc.ghost,s),d) + ((Some Global,CanonicalStructure),((Loc.ghost,s),None),d) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((None,Coercion),(Loc.ghost,s),d) + VernacDefinition ((None,Coercion),((Loc.ghost,s),None),d) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((Some Decl_kinds.Local,Coercion),(Loc.ghost,s),d) + VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.ghost,s),None),d) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (true, f, s, t) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 065c12a2d7..07efaae27b 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1395,7 +1395,7 @@ let do_build_inductive (rel_constructors) in let rel_ind i ext_rel_constructors = - ((Loc.ghost,relnames.(i)), + (((Loc.ghost,relnames.(i)), None), rel_params, Some rel_arities.(i), ext_rel_constructors),[] diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 5dcb0c0439..d9d059f8fa 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -150,7 +150,7 @@ let build_newrecursive in let (rec_sign,rec_impls) = List.fold_left - (fun (env,impls) ((_,recname),bl,arityc,_) -> + (fun (env,impls) (((_,recname),_),bl,arityc,_) -> let arityc = Constrexpr_ops.prod_constr_expr arityc bl in let arity,ctx = Constrintern.interp_type env0 sigma arityc in let evdref = ref (Evd.from_env env0) in @@ -323,7 +323,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = - let names = List.map (function ((_, name),_,_,_,_),_ -> name) fix_rec_l in + let names = List.map (function (((_, name),_),_,_,_,_),_ -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in @@ -343,7 +343,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error locate_ind f_R_mut) in - let fname_kn ((fname,_,_,_,_),_) = + let fname_kn (((fname,_),_,_,_,_),_) = let f_ref = Ident fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") @@ -380,15 +380,15 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with - | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> + | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in Command.do_definition fname - (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) + (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); let evd,rev_pconstants = List.fold_left - (fun (evd,l) (((_,fname),_,_,_,_),_) -> + (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in @@ -402,7 +402,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; let evd,rev_pconstants = List.fold_left - (fun (evd,l) (((_,fname),_,_,_,_),_) -> + (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in @@ -614,7 +614,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let _is_struct = match fixpoint_exprl with | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> - let ((((_,name),_,args,types,body)),_) as fixpoint_expr = + let (((((_,name),pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -638,7 +638,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; false |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> - let ((((_,name),_,args,types,body)),_) as fixpoint_expr = + let (((((_,name),_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -672,7 +672,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in let fix_names = - List.map (function (((_,name),_,_,_,_),_) -> name) fixpoint_exprl + List.map (function ((((_,name),_),_,_,_,_),_) -> name) fixpoint_exprl in (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in @@ -867,20 +867,20 @@ let make_graph (f_ref:global_reference) = ) in let b' = add_args (snd id) new_args b in - (((id, ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ((((id,None), ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> let id = Label.to_id (con_label c) in - [((Loc.ghost,id),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + [(((Loc.ghost,id),None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in let mp,dp,_ = repr_con c in do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; (* We register the infos *) List.iter - (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) + (fun ((((_,id),_),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) expr_list); Dumpglob.continue () diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index ea699580b9..69e055c23b 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -841,7 +841,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift (rawlist:(Id.t * glob_constr) list) = - let lident = Loc.ghost, shift.ident in + let lident = (Loc.ghost, shift.ident), None in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in let lcstor_expr : (bool * (lident * constr_expr)) list = diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index d3979748e1..9de15e4071 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1398,9 +1398,7 @@ let com_terminate start_proof ctx tclIDTAC tclIDTAC; try let sigma, new_goal_type = build_new_goal_type () in - let sigma = - Evd.from_env ~ctx:(Evd.evar_universe_context sigma) Environ.empty_env - in + let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in open_new_goal start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) @@ -1437,9 +1435,7 @@ let (com_eqn : int -> Id.t -> | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant") in let (evmap, env) = Lemmas.get_current_context() in - let evmap = - Evd.from_env ~ctx:(Evd.evar_universe_context evmap) Environ.empty_env - in + let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in (Lemmas.start_proof eq_name (Global, false, Proof Lemma) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 168a10df93..fc4f5e040e 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -277,15 +277,15 @@ end type evar_universe_context = { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t; uctx_local : Univ.universe_context_set; (** The local context of variables *) - uctx_univ_variables : Universes.universe_opt_subst; - (** The local universes that are unification variables *) - uctx_univ_algebraic : Univ.universe_set; - (** The subset of unification variables that + uctx_univ_variables : Universes.universe_opt_subst; + (** The local universes that are unification variables *) + uctx_univ_algebraic : Univ.universe_set; + (** The subset of unification variables that can be instantiated with algebraic universes as they appear in types and universe instances only. *) - uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) - uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *) - } + uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) + uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *) + } let empty_evar_universe_context = { uctx_names = UNameMap.empty, Univ.LMap.empty; @@ -769,10 +769,10 @@ let empty = { extras = Store.empty; } -let from_env ?ctx e = - match ctx with - | None -> { empty with universes = evar_universe_context_from e } - | Some ctx -> { empty with universes = ctx } +let from_env e = + { empty with universes = evar_universe_context_from e } + +let from_ctx ctx = { empty with universes = ctx } let has_undefined evd = not (EvMap.is_empty evd.undf_evars) @@ -982,9 +982,43 @@ let evar_universe_context d = d.universes let universe_context_set d = d.universes.uctx_local -let universe_context evd = - Univ.ContextSet.to_context evd.universes.uctx_local +let pr_uctx_level uctx = + let map, map_rev = uctx.uctx_names in + fun l -> + try str(Univ.LMap.find l map_rev) + with Not_found -> + Universes.pr_with_global_universes l +let universe_context ?names evd = + match names with + | None -> Univ.ContextSet.to_context evd.universes.uctx_local + | Some pl -> + let levels = Univ.ContextSet.levels evd.universes.uctx_local in + let newinst, left = + List.fold_right + (fun (loc,id) (newinst, acc) -> + let l = + try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names) + with Not_found -> + user_err_loc (loc, "universe_context", + str"Universe " ++ pr_id id ++ str" is not bound anymore.") + in (l :: newinst, Univ.LSet.remove l acc)) + pl ([], levels) + in + if not (Univ.LSet.is_empty left) then + let n = Univ.LSet.cardinal left in + errorlabstrm "universe_context" + (str(CString.plural n "Universe") ++ spc () ++ + Univ.LSet.pr (pr_uctx_level evd.universes) left ++ + spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") + else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst), + Univ.ContextSet.constraints evd.universes.uctx_local) + +let restrict_universe_context evd vars = + let uctx = evd.universes in + let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in + { evd with universes = { uctx with uctx_local = uctx' } } + let universe_subst evd = evd.universes.uctx_univ_variables @@ -1072,6 +1106,15 @@ let make_flexible_variable evd b u = {evd with universes = {ctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = avars'}} +let make_evar_universe_context e l = + let uctx = evar_universe_context_from e in + match l with + | None -> uctx + | Some us -> + List.fold_left (fun uctx (loc,id) -> + fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) uctx)) + uctx us + (****************************************) (* Operations on constants *) (****************************************) @@ -1703,13 +1746,6 @@ let evar_dependency_closure n sigma = let has_no_evar sigma = EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars -let pr_uctx_level uctx = - let map, map_rev = uctx.uctx_names in - fun l -> - try str(Univ.LMap.find l map_rev) - with Not_found -> - Universes.pr_with_global_universes l - let pr_evd_level evd = pr_uctx_level evd.universes let pr_evar_universe_context ctx = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index f2d8a83350..94d9d5f662 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -129,10 +129,13 @@ type evar_map val empty : evar_map (** The empty evar map. *) -val from_env : ?ctx:evar_universe_context -> env -> evar_map +val from_env : env -> evar_map (** The empty evar map with given universe context, taking its initial universes from env. *) +val from_ctx : evar_universe_context -> evar_map +(** The empty evar map with given universe context *) + val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) @@ -484,6 +487,8 @@ val union_evar_universe_context : evar_universe_context -> evar_universe_context evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst +val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context +val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map (** Raises Not_found if not a name for a universe in this map. *) val universe_of_name : evar_map -> string -> Univ.universe_level val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map @@ -527,7 +532,7 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set -val universe_context : evar_map -> Univ.universe_context +val universe_context : ?names:(Id.t located) list -> evar_map -> Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst val universes : evar_map -> Univ.universes diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 4e889e55f0..71dcd15cc7 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -43,6 +43,12 @@ module Make else pr_id id + let pr_plident (lid, l) = + pr_lident lid ++ + (match l with + | Some l -> prlist_with_sep spc pr_lident l + | None -> mt()) + let string_of_fqid fqid = String.concat "." (List.map Id.to_string fqid) @@ -387,10 +393,16 @@ module Make hov 0 (prlist_with_sep sep pr_production_item pil ++ spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) - let pr_statement head (id,(bl,c,guard)) = - assert (not (Option.is_empty id)); + let pr_univs pl = + match pl with + | None -> mt () + | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}" + + let pr_statement head (idpl,(bl,c,guard)) = + assert (not (Option.is_empty idpl)); + let id, pl = Option.get idpl in hov 2 - (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++ + (head ++ spc() ++ pr_lident id ++ pr_univs pl ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++ str":" ++ pr_spc_lconstr c) @@ -729,7 +741,7 @@ module Make return ( hov 2 ( pr_def_token d ++ spc() - ++ pr_lident id ++ binds ++ typ + ++ pr_plident id ++ binds ++ typ ++ (match c with | None -> mt() | Some cc -> str" :=" ++ spc() ++ cc)) @@ -781,10 +793,10 @@ module Make | RecordDecl (c,fs) -> pr_record_decl b c fs in - let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) = + let pr_oneind key (((coe,(id,pl)),indpar,s,k,lc),ntn) = hov 0 ( str key ++ spc() ++ - (if coe then str"> " else str"") ++ pr_lident id ++ + (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++ pr_and_type_binders_arg indpar ++ spc() ++ Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ str" :=") ++ pr_constructor_list k lc ++ @@ -808,9 +820,9 @@ module Make | None | Some Global -> "" in let pr_onerec = function - | ((loc,id),ro,bl,type_,def),ntn -> + | (((loc,id),pl),ro,bl,type_,def),ntn -> let annot = pr_guard_annot pr_lconstr_expr bl ro in - pr_id id ++ pr_binders_arg bl ++ annot + pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn @@ -826,8 +838,8 @@ module Make | Some Local -> keyword "Local" ++ spc () | None | Some Global -> str "" in - let pr_onecorec (((loc,id),bl,c,def),ntn) = - pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ + let pr_onecorec ((((loc,id),pl),bl,c,def),ntn) = + pr_id id ++ pr_univs pl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_lconstr_expr c ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index d024c01ba5..c77ab06b94 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -133,7 +133,7 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = - let evd = Evd.from_env ~ctx Environ.empty_env in + let evd = Evd.from_ctx ctx in start_proof id goal_kind evd sign typ (fun _ -> ()); try let status = by tac in diff --git a/stm/lemmas.ml b/stm/lemmas.ml index a7ef96c668..7679b1a662 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -212,7 +212,7 @@ let save ?export_seff id const cstrs do_guard (locality,poly,kind) hook = let default_thm_id = Id.of_string "Unnamed_thm" let compute_proof_name locality = function - | Some (loc,id) -> + | Some ((loc,id),pl) -> (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) @@ -431,7 +431,11 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = let start_proof_com kind thms hook = let env0 = Global.env () in - let evdref = ref (Evd.from_env env0) in + let levels = Option.map snd (fst (List.hd thms)) in + let evdref = ref (match levels with + | None -> Evd.from_env env0 + | Some l -> Evd.from_ctx (Evd.make_evar_universe_context env0 l)) + in let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in diff --git a/stm/stm.ml b/stm/stm.ml index e6271f6089..4a303f036e 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -424,8 +424,8 @@ end = struct (* {{{ *) let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make (match x with - | VernacDefinition (_,(_,i),_) -> string_of_id i - | VernacStartTheoremProof (_,[Some (_,i),_],_) -> string_of_id i + | VernacDefinition (_,((_,i),_),_) -> string_of_id i + | VernacStartTheoremProof (_,[Some ((_,i),_),_],_) -> string_of_id i | _ -> "branch") let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index aaa6c2c07d..fb41bb7bea 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -244,7 +244,7 @@ and pp_local_decl_expr lde = (* don't know what it is for now *) match lde with | AssumExpr (_, ce) -> pp_expr ce | DefExpr (_, ce, _) -> pp_expr ce -and pp_inductive_expr ((_, (l, id)), lbl, ceo, _, cl_or_rdexpr) = +and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) = (* inductive_expr *) let b,e = Loc.unloc l in let location = ["begin", string_of_int b; "end", string_of_int e] in @@ -273,7 +273,7 @@ and pp_recursion_order_expr optid roe = (* don't know what it is for now *) | CMeasureRec (e, None) -> "mesrec", [pp_expr e] | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in Element ("recursion_order", ["kind", kind] @ attrs, expr) -and pp_fixpoint_expr ((loc, id), (optid, roe), lbl, ce, ceo) = +and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) = (* fixpoint_expr *) let start, stop = unlock loc in let id = Id.to_string id in @@ -286,7 +286,7 @@ and pp_fixpoint_expr ((loc, id), (optid, roe), lbl, ce, ceo) = | Some ce -> [pp_expr ce] | None -> [] end -and pp_cofixpoint_expr ((loc, id), lbl, ce, ceo) = (* cofixpoint_expr *) +and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *) (* Nota: it is like fixpoint_expr without (optid, roe) * so could be merged if there is no more differences *) let start, stop = unlock loc in @@ -473,7 +473,7 @@ and pp_expr ?(attr=[]) e = xmlApply loc (xmlOperator "fix" loc :: List.flatten (List.map - (fun (a,b,cl,c,d) -> pp_fixpoint_expr (a,b,cl,c,Some d)) + (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d)) fel)) let pp_comment (c) = @@ -540,7 +540,7 @@ let rec tmpp v loc = | VernacConstraint _ | VernacPolymorphic (_, _) as x -> xmlTODO loc x (* Gallina *) - | VernacDefinition (ldk, (_,id), de) -> + | VernacDefinition (ldk, ((_,id),_), de) -> let l, dk = match ldk with | Some l, dk -> (l, dk) @@ -555,7 +555,7 @@ let rec tmpp v loc = let str_dk = Kindops.string_of_definition_kind (l, false, dk) in let str_id = Id.to_string id in (xmlDef str_dk str_id loc [pp_expr e]) - | VernacStartTheoremProof (tk, [ Some (_,id), ([], statement, None) ], b) -> + | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) -> let str_tk = Kindops.string_of_theorem_kind tk in let str_id = Id.to_string id in (xmlThm str_tk str_id loc [pp_expr statement]) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 2b5eb86834..a2b7795166 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -116,25 +116,25 @@ let rec classify_vernac e = | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) | VernacDefinition ( - (Some Decl_kinds.Discharge,Decl_kinds.Definition),(_,i),ProveBody _) -> + (Some Decl_kinds.Discharge,Decl_kinds.Definition),((_,i),_),ProveBody _) -> VtStartProof("Classic",Doesn'tGuaranteeOpacity,[i]), VtLater - | VernacDefinition (_,(_,i),ProveBody _) -> + | VernacDefinition (_,((_,i),_),ProveBody _) -> VtStartProof("Classic",GuaranteesOpacity,[i]), VtLater | VernacStartTheoremProof (_,l,_) -> let ids = - CList.map_filter (function (Some(_,i), _) -> Some i | _ -> None) l in + CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater | VernacGoal _ -> VtStartProof ("Classic",GuaranteesOpacity,[]), VtLater | VernacFixpoint (_,l) -> let ids, open_proof = - List.fold_left (fun (l,b) (((_,id),_,_,_,p),_) -> + List.fold_left (fun (l,b) ((((_,id),_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof then VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater else VtSideff ids, VtLater | VernacCoFixpoint (_,l) -> let ids, open_proof = - List.fold_left (fun (l,b) (((_,id),_,_,p),_) -> + List.fold_left (fun (l,b) ((((_,id),_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof then VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater @@ -143,9 +143,9 @@ let rec classify_vernac e = | VernacAssumption (_,_,l) -> let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map snd l) l) in VtSideff ids, VtLater - | VernacDefinition (_,(_,id),DefineBody _) -> VtSideff [id], VtLater + | VernacDefinition (_,((_,id),_),DefineBody _) -> VtSideff [id], VtLater | VernacInductive (_,_,l) -> - let ids = List.map (fun (((_,(_,id)),_,_,_,cl),_) -> id :: match cl with + let ids = List.map (fun (((_,((_,id),_)),_,_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,((_,id),_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some (_,x) -> [x] | _ -> []) @ CList.map_filter (function diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 749e0d2b5b..e1c9c2de59 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -51,7 +51,7 @@ let optimize_non_type_induction_scheme kind dep sort ind = let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in let ectx = Evd.evar_universe_context_of ctxset in - let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in + let sigma, c = build_induction_scheme env (Evd.from_ctx ectx) (ind,u) dep sort in (c, Evd.evar_universe_context sigma), Declareops.no_seff let build_induction_scheme_in_type dep sort ind = @@ -63,7 +63,7 @@ let build_induction_scheme_in_type dep sort ind = let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in let ectx = Evd.evar_universe_context_of ctxset in - let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in + let sigma, c = build_induction_scheme env (Evd.from_ctx ectx) (ind,u) dep sort in c, Evd.evar_universe_context sigma let rect_scheme_kind_from_type = diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 9a64b03fd1..efd6ded44c 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -194,7 +194,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = errorlabstrm "lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let pf = Proof.start (Evd.from_env ~ctx:(evar_universe_context sigma) invEnv) [invEnv,invGoal] in + let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 719cc7c98d..aa057a3e86 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1824,8 +1824,8 @@ let declare_projection n instance_id r = let build_morphism_signature m = let env = Global.env () in - let m,ctx = Constrintern.interp_constr env Evd.empty m in - let sigma = Evd.from_env ~ctx env in + let m,ctx = Constrintern.interp_constr env (Evd.from_env env) m in + let sigma = Evd.from_ctx ctx in let t = Typing.unsafe_type_of env sigma m in let cstrs = let rec aux t = diff --git a/toplevel/command.ml b/toplevel/command.ml index 04238da2bd..e2e5d8704e 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -77,9 +77,10 @@ let red_constant_entry n ce = function (under_binders env (fst (reduction_of_red_expr env red)) n body,ctx),eff) } -let interp_definition bl p red_option c ctypopt = +let interp_definition pl bl p red_option c ctypopt = let env = Global.env() in - let evdref = ref (Evd.from_env env) in + let ctx = Evd.make_evar_universe_context env pl in + let evdref = ref (Evd.from_ctx ctx) in let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in let nb_args = List.length ctx in let imps,ce = @@ -92,10 +93,10 @@ let interp_definition bl p red_option c ctypopt = let nf,subst = Evarutil.e_nf_evars_and_universes evdref in let body = nf (it_mkLambda_or_LetIn c ctx) in let vars = Universes.universes_of_constr body in - let ctx = Universes.restrict_universe_context - (Evd.universe_context_set !evdref) vars in + let evd = Evd.restrict_universe_context !evdref vars in + let uctx = Evd.universe_context ?names:pl evd in imps1@(Impargs.lift_implicits nb_args imps2), - definition_entry ~univs:(Univ.ContextSet.to_context ctx) ~poly:p body + definition_entry ~univs:uctx ~poly:p body | Some ctyp -> let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in let subst = evd_comb0 Evd.nf_univ_variables evdref in @@ -118,11 +119,11 @@ let interp_definition bl p red_option c ctypopt = strbrk "The term declares more implicits than the type here."); let vars = Univ.LSet.union (Universes.universes_of_constr body) (Universes.universes_of_constr typ) in - let ctx = Universes.restrict_universe_context - (Evd.universe_context_set !evdref) vars in + let ctx = Evd.restrict_universe_context !evdref vars in + let uctx = Evd.universe_context ?names:pl ctx in imps1@(Impargs.lift_implicits nb_args impsty), definition_entry ~types:typ ~poly:p - ~univs:(Univ.ContextSet.to_context ctx) body + ~univs:uctx body in red_constant_entry (rel_context_length ctx) ce red_option, !evdref, imps @@ -172,8 +173,8 @@ let declare_definition ident (local, p, k) ce imps hook = let _ = Obligations.declare_definition_ref := declare_definition -let do_definition ident k bl red_option c ctypopt hook = - let (ce, evd, imps as def) = interp_definition bl (pi2 k) red_option c ctypopt in +let do_definition ident k pl bl red_option c ctypopt hook = + let (ce, evd, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in if Flags.is_program_mode () then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in @@ -290,6 +291,7 @@ let push_types env idl tl = type structured_one_inductive_expr = { ind_name : Id.t; + ind_univs : lident list option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -499,7 +501,8 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = interp_context_evars env0 evdref paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in - + let pl = (List.hd indl).ind_univs in + (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter(fun (_,b,_) -> Option.is_empty b) ctx_params in let params = List.map (fun (na,_,_) -> out_name na) assums in @@ -541,6 +544,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in let ctx_params = map_rel_context nf ctx_params in let evd = !evdref in + let uctx = Evd.universe_context ?names:pl evd in List.iter (check_evars env_params Evd.empty evd) arities; iter_rel_context (check_evars env0 Evd.empty evd) ctx_params; List.iter (fun (_,ctyps,_) -> @@ -568,7 +572,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = mind_entry_inds = entries; mind_entry_polymorphic = poly; mind_entry_private = if prv then Some false else None; - mind_entry_universes = Evd.universe_context evd }, + mind_entry_universes = uctx }, impls (* Very syntactical equality *) @@ -590,8 +594,8 @@ let extract_params indl = params let extract_inductive indl = - List.map (fun ((_,indname),_,ar,lc) -> { - ind_name = indname; + List.map (fun (((_,indname),pl),_,ar,lc) -> { + ind_name = indname; ind_univs = pl; ind_arity = Option.cata (fun x -> x) (CSort (Loc.ghost,GType [])) ar; ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc }) indl @@ -739,6 +743,7 @@ let check_mutuality env isfix fixl = type structured_fixpoint_expr = { fix_name : Id.t; + fix_univs : lident list option; fix_annot : Id.t Loc.located option; fix_binders : local_binder list; fix_body : constr_expr option; @@ -1066,7 +1071,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexe let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - let evd = Evd.from_env ~ctx Environ.empty_env in + let evd = Evd.from_ctx ctx in Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) evd (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) else begin @@ -1102,8 +1107,8 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - let evd = Evd.from_env ~ctx Environ.empty_env in - Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) + let evd = Evd.from_ctx ctx in + Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) evd (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) else begin (* We shortcut the proof process *) @@ -1130,15 +1135,17 @@ let extract_decreasing_argument limit = function let extract_fixpoint_components limit l = let fixl, ntnl = List.split l in - let fixl = List.map (fun ((_,id),ann,bl,typ,def) -> + let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) -> let ann = extract_decreasing_argument limit ann in - {fix_name = id; fix_annot = ann; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in + {fix_name = id; fix_annot = ann; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl in fixl, List.flatten ntnl let extract_cofixpoint_components l = let fixl, ntnl = List.split l in - List.map (fun ((_,id),bl,typ,def) -> - {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + List.map (fun (((_,id),pl),bl,typ,def) -> + {fix_name = id; fix_annot = None; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl, List.flatten ntnl let out_def = function @@ -1191,7 +1198,7 @@ let do_program_recursive local p fixkind fixl ntns = let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with - | [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> + | [(n, CWfRec r)], [((((_,id),_),_,bl,typ,def),ntn)] -> let recarg = match n with | Some n -> mkIdentC (snd n) @@ -1200,7 +1207,7 @@ let do_program_fixpoint local poly l = (str "Recursive argument required for well-founded fixpoints") in build_wellfounded (id, n, bl, typ, out_def def) r recarg ntn - | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] -> + | [(n, CMeasureRec (m, r))], [((((_,id),_),_,bl,typ,def),ntn)] -> build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef (lt_ref,None)) r) m ntn diff --git a/toplevel/command.mli b/toplevel/command.mli index 3a38e52cee..f4d43ec533 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -31,14 +31,14 @@ val get_declare_definition_hook : unit -> (definition_entry -> unit) (** {6 Definitions/Let} *) val interp_definition : - local_binder list -> polymorphic -> red_expr option -> constr_expr -> + lident list option -> local_binder list -> polymorphic -> red_expr option -> constr_expr -> constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits val declare_definition : Id.t -> definition_kind -> definition_entry -> Impargs.manual_implicits -> Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference -val do_definition : Id.t -> definition_kind -> +val do_definition : Id.t -> definition_kind -> lident list option -> local_binder list -> red_expr option -> constr_expr -> constr_expr option -> unit Lemmas.declaration_hook -> unit @@ -70,6 +70,7 @@ val do_assumptions : locality * polymorphic * assumption_object_kind -> type structured_one_inductive_expr = { ind_name : Id.t; + ind_univs : lident list option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -109,6 +110,7 @@ val do_mutual_inductive : type structured_fixpoint_expr = { fix_name : Id.t; + fix_univs : lident list option; fix_annot : Id.t Loc.located option; fix_binders : local_binder list; fix_body : constr_expr option; diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 11857b5724..3c0977784d 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -847,7 +847,7 @@ let rec solve_obligation prg num tac = in let obl = subst_deps_obl obls obl in let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in - let evd = Evd.from_env ~ctx:prg.prg_ctx Environ.empty_env in + let evd = Evd.from_ctx prg.prg_ctx in let auto n tac oblset = auto_solve_obligations n ~oblset tac in let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in let () = Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type hook in diff --git a/toplevel/record.ml b/toplevel/record.ml index 15ad18d9cc..484fd081df 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -90,9 +90,10 @@ let binder_of_decl = function let binders_of_decls = List.map binder_of_decl -let typecheck_params_and_fields def id t ps nots fs = +let typecheck_params_and_fields def id pl t ps nots fs = let env0 = Global.env () in - let evars = ref (Evd.from_env env0) in + let ctx = Evd.make_evar_universe_context env0 pl in + let evars = ref (Evd.from_ctx ctx) in let _ = let error bk (loc, name) = match bk, name with @@ -502,7 +503,7 @@ open Vernacexpr (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances *) -let definition_structure (kind,poly,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = +let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in let cfs,priorities = List.split cfs in let coers,fs = List.split cfs in @@ -519,7 +520,7 @@ let definition_structure (kind,poly,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild (* Now, younger decl in params and fields is on top *) let ctx, arity, template, implpars, params, implfs, fields = States.with_state_protection (fun () -> - typecheck_params_and_fields (kind = Class true) idstruc s ps notations fs) () in + typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in let sign = structure_signature (fields@params) in match kind with | Class def -> diff --git a/toplevel/record.mli b/toplevel/record.mli index 91dccb96e1..eccb5d29d6 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -38,7 +38,7 @@ val declare_structure : Decl_kinds.recursivity_kind -> inductive val definition_structure : - inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * lident with_coercion * local_binder list * + inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * plident with_coercion * local_binder list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index cfbdaccec4..8efcccaaae 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -461,7 +461,7 @@ let vernac_definition_hook p = function | SubClass -> Class.add_subclass_hook p | _ -> no_hook -let vernac_definition locality p (local,k) (loc,id as lid) def = +let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = let local = enforce_locality_exp locality local in let hook = vernac_definition_hook p k in let () = match local with @@ -471,20 +471,20 @@ let vernac_definition locality p (local,k) (loc,id as lid) def = (match def with | ProveBody (bl,t) -> (* local binders, typ *) start_proof_and_print (local,p,DefinitionBody Definition) - [Some lid, (bl,t,None)] no_hook + [Some (lid,pl), (bl,t,None)] no_hook | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with | None -> None | Some r -> let (evc,env)= get_current_context () in Some (snd (interp_redexp env evc r)) in - do_definition id (local,p,k) bl red_option c typ_opt hook) + do_definition id (local,p,k) pl bl red_option c typ_opt hook) let vernac_start_proof p kind l lettop = if Dumpglob.dump () then List.iter (fun (id, _) -> match id with - | Some lid -> Dumpglob.dump_definition lid false "prf" + | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; if not(refining ()) then if lettop then @@ -525,11 +525,11 @@ let vernac_assumption locality poly (local, kind) l nl = let vernac_record k poly finite struc binders sort nameopt cfs = let const = match nameopt with - | None -> add_prefix "Build_" (snd (snd struc)) + | None -> add_prefix "Build_" (snd (fst (snd struc))) | Some (_,id as lid) -> Dumpglob.dump_definition lid false "constr"; id in if Dumpglob.dump () then ( - Dumpglob.dump_definition (snd struc) false "rec"; + Dumpglob.dump_definition (fst (snd struc)) false "rec"; List.iter (fun (((_, x), _), _) -> match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" @@ -538,7 +538,7 @@ let vernac_record k poly finite struc binders sort nameopt cfs = let vernac_inductive poly lo finite indl = if Dumpglob.dump () then - List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> + List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> match cstrs with | Constructors cstrs -> Dumpglob.dump_definition lid false "ind"; @@ -578,13 +578,13 @@ let vernac_inductive poly lo finite indl = let vernac_fixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then - List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; do_fixpoint local poly l let vernac_cofixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then - List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; do_cofixpoint local poly l let vernac_scheme l = -- cgit v1.2.3 From f5e0f609c8c2c77205fcfb296535a7d8856db584 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 15 Sep 2015 15:20:47 +0200 Subject: STM: Reset takes Ltac into account (Close #4316) --- stm/vernac_classifier.ml | 6 +++++- test-suite/bugs/closed/4316.v | 3 +++ 2 files changed, 8 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4316.v diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index a2b7795166..8aa2a59177 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -173,9 +173,13 @@ let rec classify_vernac e = | VernacDeclareReduction _ | VernacDeclareClass _ | VernacDeclareInstances _ | VernacRegister _ - | VernacDeclareTacticDefinition _ | VernacNameSectionHypSet _ | VernacComments _ -> VtSideff [], VtLater + | VernacDeclareTacticDefinition (_,l) -> + let open Libnames in + VtSideff (List.map (function + | (Ident (_,r),_,_) -> r + | (Qualid (_,q),_,_) -> snd(repr_qualid q)) l), VtLater (* Who knows *) | VernacLoad _ -> VtSideff [], VtNow (* (Local) Notations have to disappear *) diff --git a/test-suite/bugs/closed/4316.v b/test-suite/bugs/closed/4316.v new file mode 100644 index 0000000000..68dec1334a --- /dev/null +++ b/test-suite/bugs/closed/4316.v @@ -0,0 +1,3 @@ +Ltac tac := idtac. +Reset tac. +Ltac tac := idtac. -- cgit v1.2.3 From 150cbcc8f4a6e011a089ffd1d6126058ef6e107d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Sep 2015 16:23:57 +0200 Subject: Fixing bug #4269: [Print Assumptions] lies about which axioms a term depends on. This was because the traversal algorithm used canonical names instead of user names, confusing which term was defined and which term was an axiom. --- toplevel/assumptions.ml | 20 ++++++++++---------- toplevel/assumptions.mli | 4 ++-- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index a11653a43b..4d8ba0f789 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -171,28 +171,28 @@ let rec traverse current ctx accu t = match kind_of_term t with and traverse_object ?inhabits (curr, data, ax2ty) body obj = let data, ax2ty = - let already_in = Refmap.mem obj data in + let already_in = Refmap_env.mem obj data in match body () with | None -> let data = - if not already_in then Refmap.add obj Refset.empty data else data in + if not already_in then Refmap_env.add obj Refset_env.empty data else data in let ax2ty = if Option.is_empty inhabits then ax2ty else let ty = Option.get inhabits in - try let l = Refmap.find obj ax2ty in Refmap.add obj (ty::l) ax2ty - with Not_found -> Refmap.add obj [ty] ax2ty in + try let l = Refmap_env.find obj ax2ty in Refmap_env.add obj (ty::l) ax2ty + with Not_found -> Refmap_env.add obj [ty] ax2ty in data, ax2ty | Some body -> if already_in then data, ax2ty else let contents,data,ax2ty = - traverse (label_of obj) [] (Refset.empty,data,ax2ty) body in - Refmap.add obj contents data, ax2ty + traverse (label_of obj) [] (Refset_env.empty,data,ax2ty) body in + Refmap_env.add obj contents data, ax2ty in - (Refset.add obj curr, data, ax2ty) + (Refset_env.add obj curr, data, ax2ty) let traverse current t = let () = modcache := MPmap.empty in - traverse current [] (Refset.empty, Refmap.empty, Refmap.empty) t + traverse current [] (Refset_env.empty, Refmap_env.empty, Refmap_env.empty) t (** Hopefully bullet-proof function to recover the type of a constant. It just ignores all the universe stuff. There are many issues that can arise when @@ -215,7 +215,7 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let cb = lookup_constant kn in if not (Declareops.constant_has_body cb) then let t = type_of_constant cb in - let l = try Refmap.find obj ax2ty with Not_found -> [] in + let l = try Refmap_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (kn,l)) t accu else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then let t = type_of_constant cb in @@ -227,4 +227,4 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = accu | IndRef _ | ConstructRef _ -> accu in - Refmap.fold fold graph ContextObjectMap.empty + Refmap_env.fold fold graph ContextObjectMap.empty diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli index a608fe5050..9c9f81bd2f 100644 --- a/toplevel/assumptions.mli +++ b/toplevel/assumptions.mli @@ -21,8 +21,8 @@ open Printer *) val traverse : Label.t -> constr -> - (Refset.t * Refset.t Refmap.t * - (label * Context.rel_context * types) list Refmap.t) + (Refset_env.t * Refset_env.t Refmap_env.t * + (label * Context.rel_context * types) list Refmap_env.t) (** Collects all the assumptions (optionally including opaque definitions) on which a term relies (together with their type). The above warning of -- cgit v1.2.3 From dffd1a75c7ecf8870935f48c8aff2a9e750be4aa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Sep 2015 16:39:24 +0200 Subject: Test for bug #4269. --- test-suite/output/PrintAssumptions.out | 2 ++ test-suite/output/PrintAssumptions.v | 16 ++++++++++++++++ 2 files changed, 18 insertions(+) diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 23f33081b4..66458543aa 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -16,3 +16,5 @@ extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Closed under the global context Closed under the global context +Axioms: +M.foo : False diff --git a/test-suite/output/PrintAssumptions.v b/test-suite/output/PrintAssumptions.v index f23bc49808..c2003816ca 100644 --- a/test-suite/output/PrintAssumptions.v +++ b/test-suite/output/PrintAssumptions.v @@ -94,3 +94,19 @@ Proof (false_positive.add_comm 5). Print Assumptions comm_plus5. (* Should answer : Closed under the global context *) + +(** Print Assumption and Include *) + +Module INCLUDE. + +Module M. +Axiom foo : False. +End M. + +Module N. +Include M. +End N. + +Print Assumptions N.foo. + +End INCLUDE. -- cgit v1.2.3 From 42ab65d7c7eed4f6696dacedceaf7c695e0d06d6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Sep 2015 16:56:42 +0200 Subject: Removing a warning in CoqOps. --- ide/coqOps.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index c6d3149475..ba9ab9672e 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -204,7 +204,7 @@ object(self) let on_changed (i, f) = segment#add i (flags_to_color f) in let on_push s = set_index s document_length; - (SentenceId.connect s)#changed on_changed; + ignore ((SentenceId.connect s)#changed on_changed); document_length <- succ document_length; segment#set_length document_length; let flags = List.map mem_flag_of_flag s.flags in -- cgit v1.2.3 From 6af9f644b64acf485c1628247f5435d09b990b79 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 16 Sep 2015 06:41:04 +0200 Subject: Properly handle {|...|} patterns when patterns are not asymmetric. (Fix bug #4268) --- interp/constrintern.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index ecaf2b8c13..c754f1910c 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1142,7 +1142,11 @@ let drop_notations_pattern looked_for = sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in begin match sorted_fields with | None -> RCPatAtom (loc, None) - | Some (_, head, pl) -> + | Some (n, head, pl) -> + let pl = + if !oldfashion_patterns then pl else + let pars = List.make n (CPatAtom (loc, None)) in + List.rev_append pars pl in match drop_syndef top env head pl with |Some (a,b,c) -> RCPatCstr(loc, a, b, c) |None -> raise (InternalizationError (loc,NotAConstructor head)) -- cgit v1.2.3 From 95903cc3bcb9aed92459e644d295be4d9ca25405 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 16 Sep 2015 07:41:03 +0200 Subject: Change coq_makefile's default from "-Q . Top" to "-R . Top". (Fix bug #3603) --- tools/coq_makefile.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 934a632dd1..d3374675d2 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -769,7 +769,7 @@ let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((ml_inc,i_inc,r_inc) as l && not_tops mllib && not_tops mlpack) then l else - ((".",here)::ml_inc,(".","Top",here)::i_inc,r_inc) + ((".",here)::ml_inc,i_inc,(".","Top",here)::r_inc) let warn_install_at_root_directory (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_ml,inc_i,inc_r) = -- cgit v1.2.3 From e91327a01f725f6c709adba9ddf3b41212b488ca Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 16 Sep 2015 08:42:14 +0200 Subject: Continuing investigation on how to preserve the locality of the action of "apply ... in ... as ..." in the context. Fixing a regression done by 7e00e8d60 and f2130a88e1: when an evar is created, the statement of the refined hypothesis virtually depends on the whole context and has to be left at the top. --- tactics/tactics.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0235126cc0..d0724804b4 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2283,7 +2283,9 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in Proofview.Goal.enter begin fun gl -> - let destopt = get_previous_hyp_position id gl in + let destopt = + if with_evars then MoveLast (* evars would depend on the whole context *) + else get_previous_hyp_position id gl in let naming,ipat_tac = prepare_intros (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = let last,first = List.sep_last lemmas in -- cgit v1.2.3 From 8c638c2a0dda99e557f0613cb06e1cd745820258 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 16 Sep 2015 15:24:31 +0200 Subject: In configure: -no-native-compiler -> -native-compiler no --- configure.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ml b/configure.ml index 3fe34d6cae..cafd7ec29d 100644 --- a/configure.ml +++ b/configure.ml @@ -331,8 +331,8 @@ let args_options = Arg.align [ " Dumps ml annotation files while compiling Coq"; "-makecmd", Arg.Set_string Prefs.makecmd, " Name of GNU Make command"; - "-no-native-compiler", Arg.Clear Prefs.nativecompiler, - " No compilation to native code for conversion and normalization"; + "-native-compiler", arg_bool Prefs.nativecompiler, + " (yes|no) Compilation to native code for conversion and normalization"; "-coqwebsite", Arg.Set_string Prefs.coqwebsite, " URL of the coq website"; "-force-caml-version", arg_bool Prefs.force_caml_version, -- cgit v1.2.3 From 206cecb06a959dae0ccdeeb0a5d26121b4e1b961 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 16 Sep 2015 18:00:26 +0200 Subject: Disable native_compute on Windows by default. Native_compute is not working properly on Windows due to command line size limitations and the lack of namespaces in OCaml. Using compiler-libs could solve this, but it is unclear how to ensure stability w.r.t. future versions of OCaml. --- configure.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ml b/configure.ml index cafd7ec29d..806ac381b2 100644 --- a/configure.ml +++ b/configure.ml @@ -252,7 +252,7 @@ module Prefs = struct let profile = ref false let annotate = ref false let makecmd = ref "make" - let nativecompiler = ref true + let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false end -- cgit v1.2.3 From 498cbad3e5e5d69d2ee771f90de45c0fe28cc494 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 16 Sep 2015 18:19:50 +0200 Subject: Explain new flags for native_compute in CHANGES. --- CHANGES | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES b/CHANGES index 70ddb81f4d..c8fca217fd 100644 --- a/CHANGES +++ b/CHANGES @@ -46,6 +46,11 @@ API Tools - Added an option -w to control the output of coqtop warnings. +- Configure now takes an optional -native-compiler (yes|no) flag replacing + -no-native-compiler. The new flag is set to no by default under Windows. +- Flag -no-native-compiler was removed and became the default for coqc. If + precompilation of files for native conversion test is desired, use + -native-compiler. Changes from V8.5beta1 to V8.5beta2 =================================== -- cgit v1.2.3 From 16db94e6c142217a81cc78be8788137617c24de7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 16 Sep 2015 21:44:47 +0200 Subject: In pat/constr introduction patterns, fixing in a better way clearing problems of temporary hypotheses than 76f27140e6e34 did. --- tactics/tactics.ml | 9 ++++++++- test-suite/success/intros.v | 8 ++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d0724804b4..ad7ff14e6b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2209,6 +2209,11 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with | IntroApplyOn (f,(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc (IntroIdentifier id) destopt pat in + let doclear = + if naming = NamingMustBe (loc,id) then + Proofview.tclUNIT () (* apply_in_once do a replacement *) + else + Proofview.V82.tactic (clear [id]) in Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -2217,7 +2222,9 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with (Tacticals.New.tclTHENFIRST (* Skip the side conditions of the apply *) (apply_in_once false true true true naming id - (None,(sigma,(c,NoBindings))) tac_ipat) (tac ((dloc,id)::thin) None [])) + (None,(sigma,(c,NoBindings))) + (fun id -> Tacticals.New.tclTHEN doclear (tac_ipat id))) + (tac thin None [])) sigma end diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index ae1694c58c..35ba94fb67 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -61,3 +61,11 @@ Goal forall n, n = S n -> 0=0. intros n H/n_Sn. destruct H. Qed. + +(* Another check about generated names and cleared hypotheses with + pat/c patterns *) +Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. +intros H (H1,?)/H. +change (1=1) in H0. +exact H1. +Qed. -- cgit v1.2.3 From 5a0da4d8ea9b590e30ba9b194789b348be6bbc4f Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 17 Sep 2015 07:49:19 +0200 Subject: Fix Windows installer. The theories/ directory contains no cmi/cmxs files when native_compute is disabled, so do not try to ship them. --- dev/nsis/coq.nsi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index 5b421e49dd..676490510c 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -95,8 +95,8 @@ Section "Coq" Sec1 File /r ${COQ_SRC_PATH}\theories\*.vo File /r ${COQ_SRC_PATH}\theories\*.v File /r ${COQ_SRC_PATH}\theories\*.glob - File /r ${COQ_SRC_PATH}\theories\*.cmi - File /r ${COQ_SRC_PATH}\theories\*.cmxs + ; File /r ${COQ_SRC_PATH}\theories\*.cmi + ; File /r ${COQ_SRC_PATH}\theories\*.cmxs SetOutPath "$INSTDIR\lib\plugins" File /r ${COQ_SRC_PATH}\plugins\*.vo File /r ${COQ_SRC_PATH}\plugins\*.v -- cgit v1.2.3 From fbb3ccdb099170e5a39c9f39512b1ab2503951ea Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 17 Sep 2015 09:43:02 +0200 Subject: Revert changes in Makefile.build done as part of 2bc88f9a. If it was intentional, please commit again separately. --- Makefile.build | 1 - 1 file changed, 1 deletion(-) diff --git a/Makefile.build b/Makefile.build index 0057b71684..6ceff2de95 100644 --- a/Makefile.build +++ b/Makefile.build @@ -94,7 +94,6 @@ HIDE := $(if $(VERBOSE),,@) LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) ) MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) -CAMLFLAGS:= $(CAMLFLAGS) -w +a-3-4-6-7-9-27-29-32..39-41..42-44-45-48 OCAMLC := $(OCAMLC) $(CAMLFLAGS) OCAMLOPT := $(OCAMLOPT) $(CAMLFLAGS) -- cgit v1.2.3 From 48c78b719392276b2e87be5ea368c71c01f14c85 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 17 Sep 2015 10:21:41 +0200 Subject: Fix previous merge. --- proofs/pfedit.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 3363d0300d..5e8221b811 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -133,7 +133,7 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = - let evd = Evd.from_env ~ctx in + let evd = Evd.from_ctx ctx in let terminator = Proof_global.make_terminator (fun _ -> ()) in start_proof id goal_kind evd sign typ terminator; try -- cgit v1.2.3 From 04e9be59051ca60bf61d5142ac14386920876926 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 18 Sep 2015 08:00:14 +0200 Subject: Do not compress match constructs when the inner match contains no branch. (Fix bug #4348) --- pretyping/detyping.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 28fb8cbe36..8bd57290b0 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -276,6 +276,7 @@ and align_tree nal isgoal (e,c as rhs) = match nal with match kind_of_term c with | Case (ci,p,c,cl) when eq_constr c (mkRel (List.index Name.equal na (fst (snd e)))) + && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> let clauses = build_tree na isgoal e ci cl in -- cgit v1.2.3 From 8bba34395e520ac606fc3efd0a875699fe968e69 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 20 Sep 2015 00:08:35 +0200 Subject: Better debug printers for module paths. Now distinguishes between bound modules (Top#X) and submodules (Top.X). Could be useful for the regular printer as well (e.g. in error messages), but I don't know what the compatibility constraints are, so leaving it as it is for now. --- dev/db | 1 + dev/top_printers.ml | 4 ++-- kernel/names.ml | 19 ++++++++++++++----- kernel/names.mli | 7 +++++++ 4 files changed, 24 insertions(+), 7 deletions(-) diff --git a/dev/db b/dev/db index f259b50eb3..ece22b3f44 100644 --- a/dev/db +++ b/dev/db @@ -13,6 +13,7 @@ install_printer Top_printers.ppexistentialset install_printer Top_printers.ppintset install_printer Top_printers.pplab install_printer Top_printers.ppdir +install_printer Top_printers.ppmbid install_printer Top_printers.ppmp install_printer Top_printers.ppkn install_printer Top_printers.ppcon diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f9f2e1b09e..0900bb0962 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -40,10 +40,10 @@ let ppid id = pp (pr_id id) let pplab l = pp (pr_lab l) let ppmbid mbid = pp (str (MBId.debug_to_string mbid)) let ppdir dir = pp (pr_dirpath dir) -let ppmp mp = pp(str (string_of_mp mp)) +let ppmp mp = pp(str (ModPath.debug_to_string mp)) let ppcon con = pp(debug_pr_con con) let ppproj con = pp(debug_pr_con (Projection.constant con)) -let ppkn kn = pp(pr_kn kn) +let ppkn kn = pp(str (KerName.to_string kn)) let ppmind kn = pp(debug_pr_mind kn) let ppind (kn,i) = pp(debug_pr_mind kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) diff --git a/kernel/names.ml b/kernel/names.ml index ae2b3b6389..9e4e8cd61d 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -204,7 +204,7 @@ struct DirPath.to_string p ^ "." ^ s let debug_to_string (i, s, p) = - "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">" + "<"^DirPath.to_string p ^"#" ^ s ^"#"^ string_of_int i^">" let compare (x : t) (y : t) = if x == y then 0 @@ -282,6 +282,11 @@ module ModPath = struct | MPbound uid -> MBId.to_string uid | MPdot (mp,l) -> to_string mp ^ "." ^ Label.to_string l + let rec debug_to_string = function + | MPfile sl -> DirPath.to_string sl + | MPbound uid -> MBId.debug_to_string uid + | MPdot (mp,l) -> debug_to_string mp ^ "." ^ Label.to_string l + (** we compare labels first if both are MPdots *) let rec compare mp1 mp2 = if mp1 == mp2 then 0 @@ -375,12 +380,16 @@ module KerName = struct let modpath kn = kn.modpath let label kn = kn.knlabel - let to_string kn = + let to_string_gen mp_to_string kn = let dp = if DirPath.is_empty kn.dirpath then "." else "#" ^ DirPath.to_string kn.dirpath ^ "#" in - ModPath.to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel + mp_to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel + + let to_string kn = to_string_gen ModPath.to_string kn + + let debug_to_string kn = to_string_gen ModPath.debug_to_string kn let print kn = str (to_string kn) @@ -500,9 +509,9 @@ module KerPair = struct let print kp = str (to_string kp) let debug_to_string = function - | Same kn -> "(" ^ KerName.to_string kn ^ ")" + | Same kn -> "(" ^ KerName.debug_to_string kn ^ ")" | Dual (knu,knc) -> - "(" ^ KerName.to_string knu ^ "," ^ KerName.to_string knc ^ ")" + "(" ^ KerName.debug_to_string knu ^ "," ^ KerName.debug_to_string knc ^ ")" let debug_print kp = str (debug_to_string kp) diff --git a/kernel/names.mli b/kernel/names.mli index 7cc4443752..77139f1c31 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -217,6 +217,9 @@ sig val to_string : t -> string + val debug_to_string : t -> string + (** Same as [to_string], but outputs information related to debug. *) + val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) @@ -244,6 +247,10 @@ sig (** Display *) val to_string : t -> string + + val debug_to_string : t -> string + (** Same as [to_string], but outputs information related to debug. *) + val print : t -> Pp.std_ppcmds (** Comparisons *) -- cgit v1.2.3 From bfd0ee9503cf04b51b2dd40d4ad2a904b07ac323 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 20 Sep 2015 00:06:33 +0200 Subject: Fix #3948 Anomaly: unknown constant in Print Assumptions Substitution on bound modules was incorrectly extended without sequential composition. --- kernel/mod_subst.ml | 2 +- kernel/mod_subst.mli | 5 +++-- toplevel/assumptions.ml | 12 ++++++------ 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index f7ae30e7af..ba14f65d9e 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -122,7 +122,7 @@ let add_kn_delta_resolver kn kn' = let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2 -(** Extending a [substitution] *) +(** Extending a [substitution] without sequential composition *) let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index fc2b0441ca..cd9fa79216 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -68,8 +68,9 @@ val empty_subst : substitution val is_empty_subst : substitution -> bool -(** add_* add [arg2/arg1]\{arg3\} to the substitution with no - sequential composition *) +(** add_* add [arg2/arg1]\{arg3\} to the substitution with no sequential + composition. Most often this is not what you want. For sequential + composition, try [join (map_mbid mp delta) subs] **) val add_mbid : MBId.t -> module_path -> delta_resolver -> substitution -> substitution val add_mp : diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index 4d8ba0f789..a6bd968efc 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -55,7 +55,7 @@ let rec fields_of_functor f subs mp0 args = function match args with | [] -> assert false (* we should only encounter applied functors *) | mpa :: args -> - let subs = add_mbid mbid mpa empty_delta_resolver (*TODO*) subs in + let subs = join (map_mbid mbid mpa empty_delta_resolver (*TODO*)) subs in fields_of_functor f subs mp0 args e let rec lookup_module_in_impl mp = @@ -64,11 +64,11 @@ let rec lookup_module_in_impl mp = (* The module we search might not be exported by its englobing module(s). We access the upper layer, and then do a manual search *) match mp with - | MPfile _ | MPbound _ -> - raise Not_found (* should have been found by [lookup_module] *) - | MPdot (mp',lab') -> - let fields = memoize_fields_of_mp mp' in - search_mod_label lab' fields + | MPfile _ -> raise Not_found (* can happen if mp is an open module *) + | MPbound _ -> assert false + | MPdot (mp',lab') -> + let fields = memoize_fields_of_mp mp' in + search_mod_label lab' fields and memoize_fields_of_mp mp = try MPmap.find mp !modcache -- cgit v1.2.3 From b712864e9cf499f1298c1aca1ad8a8b17e145079 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 18 Sep 2015 12:12:05 +0200 Subject: Revert "On MacOS X, ensuring that files found in the file system have the" and "Continuing incomplete 4b5af0d6e9ec1 (on MacOS X, ensuring that files" and "Continuing 4b5af0d6e9 and 69941d4e19 about filename case check on MacOS X." This reverts commits 4b5af0d6e9ec1343a2c3ff9f856a019fa93c3606 and 69941d4e195650bf59285b897c14d6287defea0f and e7043eec55085f4101bfb126d8829de6f6086c5a. Trying to emulate a case sensitive file system on top of a case aware one is too costly: 3x slowdown when compiling the stdlib or CompCert. --- lib/envars.ml | 19 +++---------------- lib/system.ml | 16 ++-------------- lib/system.mli | 2 -- 3 files changed, 5 insertions(+), 32 deletions(-) diff --git a/lib/envars.ml b/lib/envars.ml index ac0b6f722e..b0eed8386b 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -39,25 +39,12 @@ let path_to_list p = let user_path () = path_to_list (Sys.getenv "PATH") (* may raise Not_found *) - (* Duplicated from system.ml to minimize dependencies *) -let file_exists_respecting_case f = - if Coq_config.arch = "Darwin" then - (* ensure that the file exists with expected case on the - case-insensitive but case-preserving default MacOS file system *) - let rec aux f = - let bf = Filename.basename f in - let df = Filename.dirname f in - String.equal df "." || String.equal df "/" || - aux df && Array.exists (String.equal bf) (Sys.readdir df) - in aux f - else Sys.file_exists f - let rec which l f = match l with | [] -> raise Not_found | p :: tl -> - if file_exists_respecting_case (p / f) then + if Sys.file_exists (p / f) then p else which tl f @@ -115,7 +102,7 @@ let _ = If the check fails, then [oth ()] is evaluated. *) let check_file_else ~dir ~file oth = let path = if Coq_config.local then coqroot else coqroot / dir in - if file_exists_respecting_case (path / file) then path else oth () + if Sys.file_exists (path / file) then path else oth () let guess_coqlib fail = let prelude = "theories/Init/Prelude.vo" in @@ -147,7 +134,7 @@ let coqpath = let coqpath = getenv_else "COQPATH" (fun () -> "") in let make_search_path path = let paths = path_to_list path in - let valid_paths = List.filter file_exists_respecting_case paths in + let valid_paths = List.filter Sys.file_exists paths in List.rev valid_paths in make_search_path coqpath diff --git a/lib/system.ml b/lib/system.ml index 27e21204cc..d1cdd8efc9 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -53,18 +53,6 @@ let all_subdirs ~unix_path:root = if exists_dir root then traverse root []; List.rev !l -let file_exists_respecting_case f = - if Coq_config.arch = "Darwin" then - (* ensure that the file exists with expected case on the - case-insensitive but case-preserving default MacOS file system *) - let rec aux f = - let bf = Filename.basename f in - let df = Filename.dirname f in - (String.equal df "." || String.equal df "/" || aux df) - && Array.exists (String.equal bf) (Sys.readdir df) - in aux f - else Sys.file_exists f - let rec search paths test = match paths with | [] -> [] @@ -89,7 +77,7 @@ let where_in_path ?(warn=true) path filename = in check_and_warn (search path (fun lpe -> let f = Filename.concat lpe filename in - if file_exists_respecting_case f then [lpe,f] else [])) + if Sys.file_exists f then [lpe,f] else [])) let where_in_path_rex path rex = search path (fun lpe -> @@ -105,7 +93,7 @@ let where_in_path_rex path rex = let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then - if file_exists_respecting_case filename then + if Sys.file_exists filename then let root = Filename.dirname filename in root, filename else diff --git a/lib/system.mli b/lib/system.mli index 051e92f166..a3d66d577a 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -29,8 +29,6 @@ val exists_dir : string -> bool val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string -val file_exists_respecting_case : string -> bool - (** {6 I/O functions } *) (** Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] -- cgit v1.2.3 From bcba542aac3e17bab78f74e0fd3600e12cc0e492 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 20 Sep 2015 00:23:59 +0200 Subject: Test file for #3948 - Anomaly: unknown constant in Print Assumptions. --- test-suite/bugs/closed/3948.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 test-suite/bugs/closed/3948.v diff --git a/test-suite/bugs/closed/3948.v b/test-suite/bugs/closed/3948.v new file mode 100644 index 0000000000..56b1e3ffb4 --- /dev/null +++ b/test-suite/bugs/closed/3948.v @@ -0,0 +1,24 @@ +Module Type S. +Parameter t : Type. +End S. + +Module Bar(X : S). +Definition elt := X.t. +Axiom fold : elt. +End Bar. + +Module Make (Z: S) := Bar(Z). + +Declare Module Y : S. + +Module Type Interface. +Parameter constant : unit. +End Interface. + +Module DepMap : Interface. +Module Dom := Make(Y). +Definition constant : unit := + let _ := @Dom.fold in tt. +End DepMap. + +Print Assumptions DepMap.constant. -- cgit v1.2.3 From 7f0346ea0cc5d76ff7c5aa6f95cfd43769ae21aa Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 20 Sep 2015 00:56:02 +0200 Subject: Remove unused type_in_type field in safe_env. Was left over after Hugo's 9c732a5c878b. --- kernel/safe_typing.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 907ad2a1d4..55e767321b 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -81,8 +81,7 @@ open Declarations These fields could be deduced from [revstruct], but they allow faster name freshness checks. - [univ] and [future_cst] : current and future universe constraints - - [engagement] : are we Set-impredicative? - - [type_in_type] : does the universe hierarchy collapse? + - [engagement] : are we Set-impredicative? does the universe hierarchy collapse? - [required] : names and digests of Require'd libraries since big-bang. This field will only grow - [loads] : list of libraries Require'd inside the current module. @@ -122,7 +121,6 @@ type safe_environment = univ : Univ.constraints; future_cst : Univ.constraints Future.computation list; engagement : engagement option; - type_in_type : bool; required : vodigest DPMap.t; loads : (module_path * module_body) list; local_retroknowledge : Retroknowledge.action list; @@ -152,7 +150,6 @@ let empty_environment = future_cst = []; univ = Univ.Constraint.empty; engagement = None; - type_in_type = false; required = DPMap.empty; loads = []; local_retroknowledge = []; -- cgit v1.2.3 From 40479227cba680496bf358e196e57a9a64f9c65b Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 20 Sep 2015 00:58:25 +0200 Subject: Nametab: print debug notice only in debug mode. --- library/nametab.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/library/nametab.ml b/library/nametab.ml index 6af1e686b0..5b6d7cd982 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -524,7 +524,8 @@ let shortest_qualid_of_tactic kn = let pr_global_env env ref = try str (string_of_qualid (shortest_qualid_of_global env ref)) - with Not_found as e -> prerr_endline "pr_global_env not found"; raise e + with Not_found as e -> + if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e let global_inductive r = match global r with -- cgit v1.2.3 From 0c766b2e3b54d96713a79e40661653c5486822a8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 20 Sep 2015 01:23:26 +0200 Subject: Print Assumptions shows engagement. Seems to be morally required since we have the -type-in-type flag. --- printing/printer.ml | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/printing/printer.ml b/printing/printer.ml index 33b95c2f56..18e4902255 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -742,7 +742,8 @@ module ContextObjectSet = Set.Make (OrderedContextObject) module ContextObjectMap = Map.Make (OrderedContextObject) let pr_assumptionset env s = - if ContextObjectMap.is_empty s then + if ContextObjectMap.is_empty s && + engagement env = (PredicativeSet, StratifiedType) then str "Closed under the global context" else let safe_pr_constant env kn = @@ -788,6 +789,16 @@ let pr_assumptionset env s = let (vars, axioms, opaque, trans) = ContextObjectMap.fold fold s ([], [], [], []) in + let theory = + if is_impredicative_set env then + [str "Set is impredicative"] + else [] + in + let theory = + if type_in_type env then + str "Type hierarchy is collapsed (logic is inconsistent)" :: theory + else theory + in let opt_list title = function | [] -> None | l -> @@ -801,6 +812,7 @@ let pr_assumptionset env s = opt_list (str "Section Variables:") vars; opt_list (str "Axioms:") axioms; opt_list (str "Opaque constants:") opaque; + opt_list (str "Theory:") theory; ] in prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums) -- cgit v1.2.3 From 06d1ad739b952febce3220c372aa2dedf18e1c79 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 17 Aug 2015 23:30:16 +0200 Subject: Adding a tag preference --- ide/preferences.ml | 152 ++++++++++++++++++++++++++++++++++++++++++++++++++++ ide/preferences.mli | 10 ++++ 2 files changed, 162 insertions(+) diff --git a/ide/preferences.ml b/ide/preferences.ml index 765dc7e59f..aea00d98de 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -17,6 +17,14 @@ let style_manager = GSourceView2.source_style_scheme_manager ~default:true let () = style_manager#set_search_path ((Minilib.coqide_data_dirs ())@style_manager#search_path) +type tag = { + tag_fg_color : string option; + tag_bg_color : string option; + tag_bold : bool; + tag_italic : bool; + tag_underline : bool; +} + (** Generic preferences *) type obj = { @@ -170,6 +178,30 @@ object | _ -> None end +let tag : tag repr = +let _to s = if s = "" then None else Some s in +let _of = function None -> "" | Some s -> s in +object + method from tag = [ + _of tag.tag_fg_color; + _of tag.tag_bg_color; + string_of_bool tag.tag_bold; + string_of_bool tag.tag_italic; + string_of_bool tag.tag_underline; + ] + method into = function + | [fg; bg; bd; it; ul] -> + (try Some { + tag_fg_color = _to fg; + tag_bg_color = _to bg; + tag_bold = bool_of_string bd; + tag_italic = bool_of_string it; + tag_underline = bool_of_string ul; + } + with _ -> None) + | _ -> None +end + end let get_config_file name = @@ -354,6 +386,18 @@ let processing_color = let _ = attach_bg processing_color Tags.Script.to_process let _ = attach_bg processing_color Tags.Script.incomplete +let default_tag = { + tag_fg_color = None; + tag_bg_color = None; + tag_bold = false; + tag_italic = false; + tag_underline = false; +} + +let tags = ref Util.String.Map.empty + +let list_tags () = !tags + let processed_color = new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string) @@ -400,6 +444,74 @@ let highlight_current_line = let nanoPG = new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool) +class tag_button (box : Gtk.box Gtk.obj) = +object (self) + + inherit GObj.widget box + + val fg_color = GButton.color_button () + val fg_unset = GButton.toggle_button () + val bg_color = GButton.color_button () + val bg_unset = GButton.toggle_button () + val bold = GButton.toggle_button () + val italic = GButton.toggle_button () + val underline = GButton.toggle_button () + + method set_tag tag = + let track c but set = match c with + | None -> set#set_active true + | Some c -> + set#set_active false; + but#set_color (Tags.color_of_string c) + in + track tag.tag_bg_color bg_color bg_unset; + track tag.tag_fg_color fg_color fg_unset; + bold#set_active tag.tag_bold; + italic#set_active tag.tag_italic; + underline#set_active tag.tag_underline; + + method tag = + let get but set = + if set#active then None + else Some (Tags.string_of_color but#color) + in + { + tag_bg_color = get bg_color bg_unset; + tag_fg_color = get fg_color fg_unset; + tag_bold = bold#active; + tag_italic = italic#active; + tag_underline = underline#active; + } + + initializer + let box = new GPack.box box in + let set_stock button stock = + let stock = GMisc.image ~stock ~icon_size:`BUTTON () in + button#set_image stock#coerce + in + set_stock fg_unset `CANCEL; + set_stock bg_unset `CANCEL; + set_stock bold `BOLD; + set_stock italic `ITALIC; + set_stock underline `UNDERLINE; + box#pack fg_color#coerce; + box#pack fg_unset#coerce; + box#pack bg_color#coerce; + box#pack bg_unset#coerce; + box#pack bold#coerce; + box#pack italic#coerce; + box#pack underline#coerce; + let cb but obj = obj#set_sensitive (not but#active) in + let _ = fg_unset#connect#toggled (fun () -> cb fg_unset fg_color#misc) in + let _ = bg_unset#connect#toggled (fun () -> cb bg_unset bg_color#misc) in + () + +end + +let tag_button () = + let box = GPack.hbox () in + new tag_button (Gobject.unsafe_cast box#as_widget) + (** Old style preferences *) let save_pref () = @@ -503,6 +615,44 @@ let configure ?(apply=(fun () -> ())) () = custom ~label box callback true in + let config_tags = + let box = GPack.vbox () in + let scroll = GBin.scrolled_window + ~hpolicy:`NEVER + ~vpolicy:`AUTOMATIC + ~packing:(box#pack ~expand:true) + () + in + let table = GPack.table + ~row_spacings:5 + ~col_spacings:5 + ~border_width:2 + ~packing:scroll#add_with_viewport () + in + let reset_button = GButton.button + ~label:"Reset" + ~packing:box#pack () + in + let i = ref 0 in + let cb = ref [] in + let iter text tag = + let label = GMisc.label + ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) () + in + let () = label#set_xalign 0. in + let button = tag_button () in + let callback () = tag#set button#tag in + button#set_tag tag#get; + table#attach ~left:1 ~top:!i button#coerce; + incr i; + cb := callback :: !cb; + in + let () = Util.String.Map.iter iter !tags in + let label = "Tag configuration" in + let callback () = List.iter (fun f -> f ()) !cb in + custom ~label box callback true + in + let config_editor = let label = "Editor configuration" in let box = GPack.vbox () in @@ -706,6 +856,8 @@ let configure ?(apply=(fun () -> ())) () = [config_font]); Section("Colors", Some `SELECT_COLOR, [config_color; source_language; source_style]); + Section("Tags", Some `SELECT_COLOR, + [config_tags]); Section("Editor", Some `EDIT, [config_editor]); Section("Files", Some `DIRECTORY, [global_auto_revert;global_auto_revert_delay; diff --git a/ide/preferences.mli b/ide/preferences.mli index d815c01ddf..b5c7ea2221 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -12,6 +12,14 @@ val style_manager : GSourceView2.source_style_scheme_manager type project_behavior = Ignore_args | Append_args | Subst_args type inputenc = Elocale | Eutf8 | Emanual of string +type tag = { + tag_fg_color : string option; + tag_bg_color : string option; + tag_bold : bool; + tag_italic : bool; + tag_underline : bool; +} + class type ['a] repr = object method into : string list -> 'a option @@ -33,6 +41,8 @@ object method default : 'a end +val list_tags : unit -> tag preference Util.String.Map.t + val cmd_coqtop : string option preference val cmd_coqc : string preference val cmd_make : string preference -- cgit v1.2.3 From 05fc256eecfea634d8c726c5b7f81269a87eca18 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 21 Aug 2015 18:07:23 +0200 Subject: Adding standard printing tags to CoqIDE. --- ide/preferences.ml | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/ide/preferences.ml b/ide/preferences.ml index aea00d98de..743f6e2a62 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -398,6 +398,29 @@ let tags = ref Util.String.Map.empty let list_tags () = !tags +let () = + let iter name = + let pref = new preference ~name:[name] ~init:default_tag ~repr:Repr.(tag) in + tags := Util.String.Map.add name pref !tags + in + List.iter iter [ + "constr.evar"; + "constr.keyword"; + "constr.notation"; + "constr.path"; + "constr.reference"; + "constr.type"; + "constr.variable"; + "message.debug"; + "message.error"; + "message.warning"; + "module.definition"; + "module.keyword"; + "tactic.keyword"; + "tactic.primitive"; + "tactic.string"; + ] + let processed_color = new preference ~name:["processed_color"] ~init:"light green" ~repr:Repr.(string) -- cgit v1.2.3 From 8b609e4e6df906dc16e8fa506a71046ab3b8f16c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 21 Aug 2015 18:09:48 +0200 Subject: Pluging in tag preferences into buffer printing. --- ide/ideutils.ml | 18 ++++++++++++++++++ ide/preferences.ml | 38 ++++++++++++++++++++++++++++++++++---- 2 files changed, 52 insertions(+), 4 deletions(-) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 053bba805d..88a8486f47 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -37,7 +37,25 @@ let flash_info = let flash_context = status#new_context ~name:"Flash" in (fun ?(delay=5000) s -> flash_context#flash ~delay s) +module StringMap = Map.Make(String) +let translate s = s + +let insert_xml ?(tags = []) (buf : #GText.buffer_skel) xml = + let open Xml_datatype in + let tag name = + let name = translate name in + match GtkText.TagTable.lookup buf#tag_table name with + | None -> raise Not_found + | Some tag -> new GText.tag tag + in + let rec insert tags = function + | PCData s -> buf#insert ~tags:(List.rev tags) s + | Element (t, _, children) -> + let tags = try tag t :: tags with Not_found -> tags in + List.iter (fun xml -> insert tags xml) children + in + insert tags xml let set_location = ref (function s -> failwith "not ready") diff --git a/ide/preferences.ml b/ide/preferences.ml index 743f6e2a62..dedd62902c 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -398,11 +398,41 @@ let tags = ref Util.String.Map.empty let list_tags () = !tags -let () = - let iter name = - let pref = new preference ~name:[name] ~init:default_tag ~repr:Repr.(tag) in - tags := Util.String.Map.add name pref !tags +let create_tag name default = + let pref = new preference ~name:[name] ~init:default ~repr:Repr.(tag) in + let set_tag tag = + begin match pref#get.tag_bg_color with + | None -> () + | Some c -> tag#set_property (`BACKGROUND c) + end; + begin match pref#get.tag_fg_color with + | None -> () + | Some c -> tag#set_property (`FOREGROUND c) + end; + begin match pref#get.tag_bold with + | false -> () + | true -> tag#set_property (`WEIGHT `BOLD) + end; + begin match pref#get.tag_italic with + | false -> () + | true -> tag#set_property (`STYLE `ITALIC) + end; + begin match pref#get.tag_underline with + | false -> () + | true -> tag#set_property (`UNDERLINE `SINGLE) + end; + in + let iter table = + let tag = GText.tag ~name () in + table#add tag#as_tag; + pref#connect#changed (fun _ -> set_tag tag); + set_tag tag; in + List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table]; + tags := Util.String.Map.add name pref !tags + +let () = + let iter name = create_tag name default_tag in List.iter iter [ "constr.evar"; "constr.keyword"; -- cgit v1.2.3 From 481d2b681463d2758fec6b2417631491be69f216 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 13 Sep 2015 16:29:48 +0200 Subject: Do not canonicalize messages received by CoqIDE. --- ide/coq.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ide/coq.ml b/ide/coq.ml index d061df6fd0..8392b7dbf4 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -336,7 +336,7 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = let lex = Lexing.from_string s in let p = Xml_parser.make (Xml_parser.SLexbuf lex) in let rec loop () = - let xml = Xml_parser.parse p in + let xml = Xml_parser.parse ~do_not_canonicalize:true p in let l_end = Lexing.lexeme_end lex in state.fragment <- String.sub s l_end (String.length s - l_end); state.lexerror <- None; -- cgit v1.2.3 From f4584f8a332c9077844e227c8b86d3cb1daf8b12 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 14 Sep 2015 16:40:28 +0200 Subject: Adding rich printing primitives. --- ide/coqOps.ml | 8 ++++++++ ide/ideutils.ml | 6 ++---- ide/ideutils.mli | 3 +++ ide/interface.mli | 1 + lib/richpp.ml | 34 ++++++++++++++++++++++++++++++++++ lib/richpp.mli | 26 ++++++++++++++++++++++++++ lib/serialize.ml | 4 ++++ lib/serialize.mli | 2 ++ 8 files changed, 80 insertions(+), 4 deletions(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index e97a2eceef..6a7c2e8195 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -164,6 +164,14 @@ let flags_to_color f = else if List.mem `INCOMPLETE f then `NAME "gray" else `NAME Preferences.processed_color#get +let validate s = + let open Xml_datatype in + let rec validate = function + | PCData s -> Glib.Utf8.validate s + | Element (_, _, children) -> List.for_all validate children + in + validate (Richpp.repr s) + module Doc = Document class coqops diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 88a8486f47..25cb89be3c 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -37,11 +37,9 @@ let flash_info = let flash_context = status#new_context ~name:"Flash" in (fun ?(delay=5000) s -> flash_context#flash ~delay s) -module StringMap = Map.Make(String) - let translate s = s -let insert_xml ?(tags = []) (buf : #GText.buffer_skel) xml = +let insert_xml ?(tags = []) (buf : #GText.buffer_skel) msg = let open Xml_datatype in let tag name = let name = translate name in @@ -55,7 +53,7 @@ let insert_xml ?(tags = []) (buf : #GText.buffer_skel) xml = let tags = try tag t :: tags with Not_found -> tags in List.iter (fun xml -> insert tags xml) children in - insert tags xml + insert tags (Richpp.repr msg) let set_location = ref (function s -> failwith "not ready") diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 1fb30e4d72..ea4c41ff0a 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -52,6 +52,9 @@ val pop_info : unit -> unit val clear_info : unit -> unit val flash_info : ?delay:int -> string -> unit +val insert_xml : ?tags:GText.tag list -> + #GText.buffer_skel -> Richpp.richpp -> unit + val set_location : (string -> unit) ref (* In win32, when a command-line is to be executed via cmd.exe diff --git a/ide/interface.mli b/ide/interface.mli index 464e851f6d..9d19f1c3c5 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -12,6 +12,7 @@ type raw = bool type verbose = bool +type richpp = Richpp.richpp (** The type of coqtop goals *) type goal = { diff --git a/lib/richpp.ml b/lib/richpp.ml index c4a9c39d5a..fff989ce0a 100644 --- a/lib/richpp.ml +++ b/lib/richpp.ml @@ -163,4 +163,38 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml = in node xml +type richpp = xml +let repr xml = xml +let richpp_of_xml xml = xml +let richpp_of_string s = PCData s + +let richpp_of_pp pp = + let annotate t = match Pp.Tag.prj t Ppstyle.tag with + | None -> None + | Some key -> Some (Ppstyle.repr key) + in + let rec drop = function + | PCData s -> [PCData s] + | Element (_, annotation, cs) -> + let cs = List.concat (List.map drop cs) in + match annotation.annotation with + | None -> cs + | Some s -> [Element (String.concat "." s, [], cs)] + in + let xml = rich_pp annotate pp in + Element ("_", [], drop xml) + +let raw_print xml = + let buf = Buffer.create 1024 in + let rec print = function + | PCData s -> Buffer.add_string buf s + | Element (_, _, cs) -> List.iter print cs + in + let () = print xml in + Buffer.contents buf + +let of_richpp x = Element ("richpp", [], [x]) +let to_richpp xml = match xml with +| Element ("richpp", [], [x]) -> x +| _ -> raise Serialize.Marshal_error diff --git a/lib/richpp.mli b/lib/richpp.mli index a0d3c374b2..7e4b58c9a6 100644 --- a/lib/richpp.mli +++ b/lib/richpp.mli @@ -39,3 +39,29 @@ val xml_of_rich_pp : ('annotation -> (string * string) list) -> 'annotation located Xml_datatype.gxml -> Xml_datatype.xml + +(** {5 Enriched text} *) + +type richpp +(** Type of text with style annotations *) + +val richpp_of_pp : Pp.std_ppcmds -> richpp +(** Extract style information from formatted text *) + +val richpp_of_xml : Xml_datatype.xml -> richpp +(** Do not use outside of dedicated areas *) + +val richpp_of_string : string -> richpp +(** Make a styled text out of a normal string *) + +val repr : richpp -> Xml_datatype.xml +(** Observe the styled text as XML *) + +(** {5 Serialization} *) + +val of_richpp : richpp -> Xml_datatype.xml +val to_richpp : Xml_datatype.xml -> richpp + +(** Represent the semi-structured document as a string, dropping any additional + information. *) +val raw_print : richpp -> string diff --git a/lib/serialize.ml b/lib/serialize.ml index aa2e3f02a4..b14bfb2833 100644 --- a/lib/serialize.ml +++ b/lib/serialize.ml @@ -114,3 +114,7 @@ let to_loc xml = with Not_found | Invalid_argument _ -> raise Marshal_error) | _ -> raise Marshal_error +let of_xml x = Element ("xml", [], [x]) +let to_xml xml = match xml with +| Element ("xml", [], [x]) -> x +| _ -> raise Marshal_error diff --git a/lib/serialize.mli b/lib/serialize.mli index 34d3e054cd..f4eac5a6b9 100644 --- a/lib/serialize.mli +++ b/lib/serialize.mli @@ -35,3 +35,5 @@ val of_edit_id: int -> xml val to_edit_id: xml -> int val of_loc : Loc.t -> xml val to_loc : xml -> Loc.t +val of_xml : xml -> xml +val to_xml : xml -> xml -- cgit v1.2.3 From 85fca507c6c4810d0858d6fbd8f5a1ece52e755c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 15 Aug 2015 20:16:07 +0200 Subject: Rich printing of goals. --- ide/ide_slave.ml | 5 +++-- ide/interface.mli | 4 ++-- ide/wg_ProofView.ml | 27 ++++++++++++++++----------- ide/xmlprotocol.ml | 15 +++++++-------- 4 files changed, 28 insertions(+), 23 deletions(-) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 94f9c9a361..562de45620 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -184,12 +184,13 @@ let process_goal sigma g = let id = Goal.uid g in let ccl = let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in - string_of_ppcmds (pr_goal_concl_style_env env sigma norm_constr) in + Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) + in let process_hyp d (env,l) = let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in (List.fold_right Environ.push_named d' env, - (string_of_ppcmds (pr_var_list_decl env sigma d)) :: l) in + (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in let (_env, hyps) = Context.fold_named_list_context process_hyp (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in diff --git a/ide/interface.mli b/ide/interface.mli index 9d19f1c3c5..848fb817d4 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -18,9 +18,9 @@ type richpp = Richpp.richpp type goal = { goal_id : string; (** Unique goal identifier *) - goal_hyp : string list; + goal_hyp : richpp list; (** List of hypotheses *) - goal_ccl : string; + goal_ccl : richpp; (** Goal conclusion *) } diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 6402789ec3..148add6e9c 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -8,6 +8,7 @@ open Util open Preferences +open Ideutils class type proof_view = object @@ -83,7 +84,8 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with let () = hook_tag_cb tag hint sel_cb on_hover in [tag], hints in - let () = proof#buffer#insert ~tags (hyp ^ "\n") in + let () = insert_xml ~tags proof#buffer hyp in + proof#buffer#insert "\n"; insert_hyp rem_hints hs in let () = proof#buffer#insert head_str in @@ -96,13 +98,14 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with else [] in proof#buffer#insert (goal_str 1 goals_cnt); - proof#buffer#insert ~tags cur_goal; + insert_xml proof#buffer cur_goal; proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = proof#buffer#insert (goal_str i goals_cnt); - proof#buffer#insert (g ^ "\n") + insert_xml proof#buffer g; + proof#buffer#insert "\n" in let () = Util.List.fold_left_i fold_goal 2 () rem_goals in @@ -116,10 +119,12 @@ let mode_cesar (proof : #GText.view_skel) = function | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ -> proof#buffer#insert " *** Declarative Mode ***\n"; List.iter - (fun hyp -> proof#buffer#insert (hyp^"\n")) + (fun hyp -> insert_xml proof#buffer hyp; proof#buffer#insert "\n") hyps; proof#buffer#insert "______________________________________\n"; - proof#buffer#insert ("thesis := \n "^cur_goal^"\n"); + proof#buffer#insert "thesis := \n "; + insert_xml proof#buffer cur_goal; + proof#buffer#insert "\n"; ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT)) let rec flatten = function @@ -152,8 +157,8 @@ let display mode (view : #GText.view_skel) goals hints evars = (* The proof is finished, with the exception of given up goals. *) view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; let iter goal = - let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in - view#buffer#insert msg + insert_xml view#buffer goal.Interface.goal_ccl; + view#buffer#insert "\n" in List.iter iter given_up_goals; view#buffer#insert "\nYou need to go back and solve them." @@ -161,8 +166,8 @@ let display mode (view : #GText.view_skel) goals hints evars = (* All the goals have been resolved but those on the shelf. *) view#buffer#insert "All the remaining goals are on the shelf:\n\n"; let iter goal = - let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in - view#buffer#insert msg + insert_xml view#buffer goal.Interface.goal_ccl; + view#buffer#insert "\n" in List.iter iter shelved_goals | _, _, _, _ -> @@ -174,8 +179,8 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n"; let iter i goal = let () = view#buffer#insert (goal_str (succ i)) in - let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in - view#buffer#insert msg + insert_xml view#buffer goal.Interface.goal_ccl; + view#buffer#insert "\n" in List.iteri iter bg end diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index d337a911d8..8afe1cd56e 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -10,7 +10,7 @@ (** WARNING: TO BE UPDATED WHEN MODIFIED! *) -let protocol_version = "20140312" +let protocol_version = "20150815" (** * Interface of calls to Coq by CoqIde *) @@ -131,14 +131,14 @@ let to_evar = function | _ -> raise Marshal_error let of_goal g = - let hyp = of_list of_string g.goal_hyp in - let ccl = of_string g.goal_ccl in + let hyp = of_list Richpp.of_richpp g.goal_hyp in + let ccl = Richpp.of_richpp g.goal_ccl in let id = of_string g.goal_id in Element ("goal", [], [id; hyp; ccl]) let to_goal = function | Element ("goal", [], [id; hyp; ccl]) -> - let hyp = to_list to_string hyp in - let ccl = to_string ccl in + let hyp = to_list Richpp.to_richpp hyp in + let ccl = Richpp.to_richpp ccl in let id = to_string id in { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } | _ -> raise Marshal_error @@ -318,10 +318,9 @@ end = struct (List.length lg + List.length rg) pr_focus l in Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals else - let pr_menu s = s in let pr_goal { goal_hyp = hyps; goal_ccl = goal } = - "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^ - pr_menu goal ^ "]" in + "[" ^ String.concat "; " (List.map Richpp.raw_print hyps) ^ " |- " ^ + Richpp.raw_print goal ^ "]" in String.concat " " (List.map pr_goal g.fg_goals) let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]" let pr_status (s : status) = -- cgit v1.2.3 From f20fce1259563f2081fadc62ccab1304bb8161d5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 21 Aug 2015 19:00:59 +0200 Subject: Rich printing of messages. --- ide/coq.ml | 12 ++++++------ ide/coqOps.ml | 28 ++++++++++++++-------------- ide/coqide.ml | 32 ++++++++++++++++---------------- ide/ide_slave.ml | 6 +++--- ide/ideutils.ml | 15 +++++++++++++-- ide/ideutils.mli | 6 ++++-- ide/wg_Command.ml | 5 ++++- ide/wg_MessageView.ml | 22 +++++++++++++++------- ide/wg_MessageView.mli | 9 +++++---- ide/xmlprotocol.ml | 2 +- lib/feedback.ml | 6 +++--- lib/feedback.mli | 2 +- lib/pp.ml | 6 +++--- lib/pp.mli | 4 ++-- stm/asyncTaskQueue.ml | 2 +- 15 files changed, 91 insertions(+), 66 deletions(-) diff --git a/ide/coq.ml b/ide/coq.ml index 8392b7dbf4..a60f327b4f 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -302,13 +302,13 @@ let handle_intermediate_message handle xml = let logger = match handle.waiting_for with | Some (_, l) -> l | None -> function - | Pp.Error -> Minilib.log ~level:`ERROR - | Pp.Info -> Minilib.log ~level:`INFO - | Pp.Notice -> Minilib.log ~level:`NOTICE - | Pp.Warning -> Minilib.log ~level:`WARNING - | Pp.Debug _ -> Minilib.log ~level:`DEBUG + | Pp.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s) + | Pp.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s) + | Pp.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s) + | Pp.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s) + | Pp.Debug _ -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s) in - logger level content + logger level (Richpp.richpp_of_xml content) let handle_feedback feedback_processor xml = let feedback = Feedback.to_feedback xml in diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 6a7c2e8195..80a32cc65b 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -329,14 +329,14 @@ object(self) let display_error s = if not (Glib.Utf8.validate s) then flash_info "This error is so nasty that I can't even display it." - else messages#add s; + else messages#add_string s; in let query = Coq.query ~logger:messages#push (phrase,Stateid.dummy) in let next = function | Fail (_, _, err) -> display_error err; Coq.return () | Good msg -> - messages#add msg; Coq.return () + messages#add_string msg; Coq.return () in Coq.bind (Coq.seq action query) next @@ -564,7 +564,7 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - logger Pp.Error "You muse close the proof with Qed or Admitted"; + logger Pp.Error (Richpp.richpp_of_string "You muse close the proof with Qed or Admitted"); self#discard_command_queue queue; conclude [] | `Skip(start,stop), (_,s) :: topstack -> @@ -580,7 +580,7 @@ object(self) let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; - logger Pp.Notice msg; + logger Pp.Notice (Richpp.richpp_of_string msg); self#commit_queue_transaction sentence; loop id [] | Good (id, (Util.Inr (* Unfocus *) tip, msg)) -> @@ -588,13 +588,13 @@ object(self) let topstack, _ = Doc.context document in self#exit_focus; self#cleanup (Doc.cut_at document tip); - logger Pp.Notice msg; + logger Pp.Notice (Richpp.richpp_of_string msg); self#mark_as_needed sentence; if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) | Fail (id, loc, msg) -> let sentence = Doc.pop document in - self#process_interp_error queue sentence loc msg tip id in + self#process_interp_error queue sentence loc (Richpp.richpp_of_string msg) tip id in Coq.bind coq_query handle_answer in let tip = @@ -607,7 +607,7 @@ object(self) let next = function | Good _ -> messages#clear; - messages#push Pp.Info "All proof terms checked by the kernel"; + messages#push Pp.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); Coq.return () | Fail x -> self#handle_failure x in Coq.bind (Coq.status ~logger:messages#push true) next @@ -701,8 +701,8 @@ object(self) self#cleanup (Doc.cut_at document to_id); conclusion () | Fail (safe_id, loc, msg) -> - if loc <> None then messages#push Pp.Error "Fixme LOC"; - messages#push Pp.Error msg; + if loc <> None then messages#push Pp.Error (Richpp.richpp_of_string "Fixme LOC"); + messages#push Pp.Error (Richpp.richpp_of_string msg); if Stateid.equal safe_id Stateid.dummy then self#show_goals else undo safe_id (Doc.focused document && Doc.is_in_focus document safe_id)) @@ -720,7 +720,7 @@ object(self) ?(move_insert=false) (safe_id, (loc : (int * int) option), msg) = messages#clear; - messages#push Pp.Error msg; + messages#push Pp.Error (Richpp.richpp_of_string msg); ignore(self#process_feedback ()); if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ()) else @@ -779,7 +779,7 @@ object(self) let display_error (loc, s) = if not (Glib.Utf8.validate s) then flash_info "This error is so nasty that I can't even display it." - else messages#add s + else messages#add_string s in let try_phrase phrase stop more = let action = log "Sending to coq now" in @@ -787,10 +787,10 @@ object(self) let next = function | Fail (_, l, str) -> (* FIXME: check *) display_error (l, str); - messages#add ("Unsuccessfully tried: "^phrase); + messages#add (Richpp.richpp_of_string ("Unsuccessfully tried: "^phrase)); more | Good msg -> - messages#add msg; + messages#add_string msg; stop Tags.Script.processed in Coq.bind (Coq.seq action query) next @@ -834,7 +834,7 @@ object(self) method initialize = let get_initial_state = let next = function - | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return () + | Fail _ -> messages#set (Richpp.richpp_of_string "Couln't initialize Coq"); Coq.return () | Good id -> initial_state <- id; Coq.return () in Coq.bind (Coq.init (get_filename ())) next in Coq.seq get_initial_state Coq.PrintOpt.enforce diff --git a/ide/coqide.ml b/ide/coqide.ml index 6769ce768b..e591f205f9 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -318,10 +318,10 @@ let export kind sn = local_cd f ^ cmd_coqdoc#get ^ " --" ^ kind ^ " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1" in - sn.messages#set ("Running: "^cmd); + sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); let finally st = flash_info (cmd ^ pr_exit_status st) in - run_command sn.messages#add finally cmd + run_command (fun msg -> sn.messages#add_string msg) finally cmd let export kind = cb_on_current_term (export kind) @@ -431,9 +431,9 @@ let compile sn = ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in - sn.messages#set ("Running: "^cmd); + sn.messages#set (Richpp.richpp_of_string ("Running: "^cmd)); let display s = - sn.messages#add s; + sn.messages#add_string s; Buffer.add_string buf s in let finally st = @@ -441,8 +441,8 @@ let compile sn = flash_info (f ^ " successfully compiled") else begin flash_info (f ^ " failed to compile"); - sn.messages#set "Compilation output:\n"; - sn.messages#add (Buffer.contents buf); + sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); + sn.messages#add (Richpp.richpp_of_string (Buffer.contents buf)); end in run_command display finally cmd @@ -464,13 +464,13 @@ let make sn = |Some f -> File.saveall (); let cmd = local_cd f ^ cmd_make#get ^ " 2>&1" in - sn.messages#set "Compilation output:\n"; + sn.messages#set (Richpp.richpp_of_string "Compilation output:\n"); Buffer.reset last_make_buf; last_make := ""; last_make_index := 0; last_make_dir := Filename.dirname f; let display s = - sn.messages#add s; + sn.messages#add_string s; Buffer.add_string last_make_buf s in let finally st = flash_info (cmd_make#get ^ pr_exit_status st) @@ -508,11 +508,11 @@ let next_error sn = let stopi = b#get_iter_at_byte ~line:(line-1) stop in b#apply_tag Tags.Script.error ~start:starti ~stop:stopi; b#place_cursor ~where:starti; - sn.messages#set error_msg; + sn.messages#set (Richpp.richpp_of_string error_msg); sn.script#misc#grab_focus () with Not_found -> last_make_index := 0; - sn.messages#set "No more errors.\n" + sn.messages#set (Richpp.richpp_of_string "No more errors.\n") let next_error = cb_on_current_term next_error @@ -718,7 +718,7 @@ let initial_about () = else "" in let msg = initial_string ^ version_info ^ log_file_message () in - on_current_term (fun term -> term.messages#add msg) + on_current_term (fun term -> term.messages#add_string msg) let coq_icon () = (* May raise Nof_found *) @@ -783,7 +783,7 @@ let coqtop_arguments sn = let args = String.concat " " args in let msg = Printf.sprintf "Invalid arguments: %s" args in let () = sn.messages#clear in - sn.messages#push Pp.Error msg + sn.messages#push Pp.Error (Richpp.richpp_of_string msg) else dialog#destroy () in let _ = entry#connect#activate ok_cb in @@ -1140,17 +1140,17 @@ let build_ui () = item "Help" ~label:"_Help"; item "Browse Coq Manual" ~label:"Browse Coq _Manual" ~callback:(fun _ -> - browse notebook#current_term.messages#add (doc_url ())); + browse notebook#current_term.messages#add_string (doc_url ())); item "Browse Coq Library" ~label:"Browse Coq _Library" ~callback:(fun _ -> - browse notebook#current_term.messages#add library_url#get); + browse notebook#current_term.messages#add_string library_url#get); item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP ~callback:(fun _ -> on_current_term (fun sn -> - browse_keyword sn.messages#add (get_current_word sn))); + browse_keyword sn.messages#add_string (get_current_word sn))); item "Help for μPG mode" ~label:"Help for μPG mode" ~callback:(fun _ -> on_current_term (fun sn -> sn.messages#clear; - sn.messages#add (NanoPG.get_documentation ()))); + sn.messages#add_string (NanoPG.get_documentation ()))); item "About Coq" ~label:"_About" ~stock:`ABOUT ~callback:MiscMenu.about ]; diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 562de45620..414c360246 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -429,12 +429,12 @@ let print_xml = let slave_logger xml_oc level message = (* convert the message into XML *) - let msg = string_of_ppcmds (hov 0 message) in + let msg = hov 0 message in let message = { Pp.message_level = level; - Pp.message_content = msg; + Pp.message_content = (Richpp.repr (Richpp.richpp_of_pp msg)); } in - let () = pr_debug (Printf.sprintf "-> %S" msg) in + let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in let xml = Pp.of_message message in print_xml xml_oc xml diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 25cb89be3c..2e4adba735 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -37,6 +37,17 @@ let flash_info = let flash_context = status#new_context ~name:"Flash" in (fun ?(delay=5000) s -> flash_context#flash ~delay s) +let xml_to_string xml = + let open Xml_datatype in + let buf = Buffer.create 1024 in + let rec iter = function + | PCData s -> Buffer.add_string buf s + | Element (_, _, children) -> + List.iter iter children + in + let () = iter (Richpp.repr xml) in + Buffer.contents buf + let translate s = s let insert_xml ?(tags = []) (buf : #GText.buffer_skel) msg = @@ -288,7 +299,7 @@ let textview_width (view : #GText.view_skel) = let char_width = GPango.to_pixels metrics#approx_char_width in pixel_width / char_width -type logger = Pp.message_level -> string -> unit +type logger = Pp.message_level -> Richpp.richpp -> unit let default_logger level message = let level = match level with @@ -298,7 +309,7 @@ let default_logger level message = | Pp.Warning -> `WARNING | Pp.Error -> `ERROR in - Minilib.log ~level message + Minilib.log ~level (xml_to_string message) (** {6 File operations} *) diff --git a/ide/ideutils.mli b/ide/ideutils.mli index ea4c41ff0a..db2dce5a39 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -52,6 +52,8 @@ val pop_info : unit -> unit val clear_info : unit -> unit val flash_info : ?delay:int -> string -> unit +val xml_to_string : Richpp.richpp -> string + val insert_xml : ?tags:GText.tag list -> #GText.buffer_skel -> Richpp.richpp -> unit @@ -67,9 +69,9 @@ val requote : string -> string val textview_width : #GText.view_skel -> int (** Returns an approximate value of the character width of a textview *) -type logger = Pp.message_level -> string -> unit +type logger = Pp.message_level -> Richpp.richpp -> unit -val default_logger : Pp.message_level -> string -> unit +val default_logger : logger (** Default logger. It logs messages that the casual user should not see. *) (** {6 I/O operations} *) diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 163bd28b13..0ae57ee748 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,7 +100,10 @@ object(self) if Str.string_match (Str.regexp "\\. *$") com 0 then com else com ^ " " ^ arg ^" . " in - let log level message = result#buffer#insert (message^"\n") in + let log level message = + Ideutils.insert_xml result#buffer message; + result#buffer#insert "\n"; + in let process = Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 30bb48e3f3..615e989de9 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -12,7 +12,7 @@ class type message_view_signals = object inherit GObj.misc_signals inherit GUtil.add_ml_signals - method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id + method pushed : callback:Ideutils.logger -> GtkSignal.id end class message_view_signals_impl obj (pushed : 'a GUtil.signal) : message_view_signals = @@ -28,9 +28,10 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : string -> unit - method set : string -> unit - method push : Pp.message_level -> string -> unit + method add : Richpp.richpp -> unit + method add_string : string -> unit + method set : Richpp.richpp -> unit + method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer (** for more advanced text edition *) @@ -76,14 +77,21 @@ let message_view () : message_view = | Pp.Warning -> [Tags.Message.warning] | _ -> [] in - if msg <> "" then begin - buffer#insert ~tags msg; - buffer#insert ~tags "\n"; + let rec non_empty = function + | Xml_datatype.PCData "" -> false + | Xml_datatype.PCData _ -> true + | Xml_datatype.Element (_, _, children) -> List.exists non_empty children + in + if non_empty (Richpp.repr msg) then begin + Ideutils.insert_xml buffer ~tags msg; + buffer#insert (*~tags*) "\n"; push#call (level, msg) end method add msg = self#push Pp.Notice msg + method add_string s = self#add (Richpp.richpp_of_string s) + method set msg = self#clear; self#add msg method buffer = text_buffer diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 457ece0900..388ab259fd 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -10,7 +10,7 @@ class type message_view_signals = object inherit GObj.misc_signals inherit GUtil.add_ml_signals - method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id + method pushed : callback:Ideutils.logger -> GtkSignal.id end class type message_view = @@ -18,9 +18,10 @@ class type message_view = inherit GObj.widget method connect : message_view_signals method clear : unit - method add : string -> unit - method set : string -> unit - method push : Pp.message_level -> string -> unit + method add : Richpp.richpp -> unit + method add_string : string -> unit + method set : Richpp.richpp -> unit + method push : Ideutils.logger (** same as [add], but with an explicit level instead of [Notice] *) method buffer : GText.buffer (** for more advanced text edition *) diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 8afe1cd56e..46e5d6f370 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -10,7 +10,7 @@ (** WARNING: TO BE UPDATED WHEN MODIFIED! *) -let protocol_version = "20150815" +let protocol_version = "20150821" (** * Interface of calls to Coq by CoqIde *) diff --git a/lib/feedback.ml b/lib/feedback.ml index a5e16ea04c..1726da2fdb 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -18,7 +18,7 @@ type message_level = type message = { message_level : message_level; - message_content : string; + message_content : xml; } let of_message_level = function @@ -39,12 +39,12 @@ let to_message_level = let of_message msg = let lvl = of_message_level msg.message_level in - let content = Serialize.of_string msg.message_content in + let content = Serialize.of_xml msg.message_content in Xml_datatype.Element ("message", [], [lvl; content]) let to_message xml = match xml with | Xml_datatype.Element ("message", [], [lvl; content]) -> { message_level = to_message_level lvl; - message_content = Serialize.to_string content } + message_content = Serialize.to_xml content } | _ -> raise Serialize.Marshal_error let is_message = function diff --git a/lib/feedback.mli b/lib/feedback.mli index 52a0e9fe6f..38c867f5b5 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -18,7 +18,7 @@ type message_level = type message = { message_level : message_level; - message_content : string; + message_content : xml; } val of_message : message -> xml diff --git a/lib/pp.ml b/lib/pp.ml index 30bc30a9ad..01df2510cf 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -412,7 +412,7 @@ type message_level = Feedback.message_level = type message = Feedback.message = { message_level : message_level; - message_content : string; + message_content : Xml_datatype.xml; } let of_message = Feedback.of_message @@ -511,11 +511,11 @@ let string_of_ppcmds c = msg_with Format.str_formatter c; Format.flush_str_formatter () -let log_via_feedback () = logger := (fun ~id lvl msg -> +let log_via_feedback printer = logger := (fun ~id lvl msg -> !feeder { Feedback.contents = Feedback.Message { message_level = lvl; - message_content = string_of_ppcmds msg }; + message_content = printer msg }; Feedback.route = !feedback_route; Feedback.id = id }) diff --git a/lib/pp.mli b/lib/pp.mli index 3b1123a9dc..d034e67617 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -116,7 +116,7 @@ type message_level = Feedback.message_level = type message = Feedback.message = { message_level : message_level; - message_content : string; + message_content : Xml_datatype.xml; } type logger = message_level -> std_ppcmds -> unit @@ -154,7 +154,7 @@ val std_logger : logger val set_logger : logger -> unit -val log_via_feedback : unit -> unit +val log_via_feedback : (std_ppcmds -> Xml_datatype.xml) -> unit val of_message : message -> Xml_datatype.xml val to_message : Xml_datatype.xml -> message diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index e3fb0b607a..e525031e63 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -297,7 +297,7 @@ module Make(T : Task) = struct let slave_feeder oc fb = Marshal.to_channel oc (RespFeedback fb) []; flush oc in Pp.set_feeder (fun x -> slave_feeder (Option.get !slave_oc) x); - Pp.log_via_feedback (); + Pp.log_via_feedback (fun msg -> Richpp.repr (Richpp.richpp_of_pp msg)); Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; match unmarshal_more_data (Option.get !slave_ic) with -- cgit v1.2.3 From 002cd2e8f6ae5722e72a5db136cda7414f9218d5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 13 Sep 2015 17:19:18 +0200 Subject: Rich printing of CoqIDE protocol failure. --- ide/coqOps.ml | 14 +++++++------- ide/ide_slave.ml | 10 +++++++--- ide/interface.mli | 4 ++-- ide/wg_Command.ml | 2 +- ide/xmlprotocol.ml | 15 ++++++++------- 5 files changed, 25 insertions(+), 20 deletions(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 80a32cc65b..8bfc70b63f 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -327,9 +327,9 @@ object(self) method raw_coq_query phrase = let action = log "raw_coq_query starting now" in let display_error s = - if not (Glib.Utf8.validate s) then + if not (validate s) then flash_info "This error is so nasty that I can't even display it." - else messages#add_string s; + else messages#add s; in let query = Coq.query ~logger:messages#push (phrase,Stateid.dummy) in @@ -594,7 +594,7 @@ object(self) else loop tip (List.rev topstack) | Fail (id, loc, msg) -> let sentence = Doc.pop document in - self#process_interp_error queue sentence loc (Richpp.richpp_of_string msg) tip id in + self#process_interp_error queue sentence loc msg tip id in Coq.bind coq_query handle_answer in let tip = @@ -702,7 +702,7 @@ object(self) conclusion () | Fail (safe_id, loc, msg) -> if loc <> None then messages#push Pp.Error (Richpp.richpp_of_string "Fixme LOC"); - messages#push Pp.Error (Richpp.richpp_of_string msg); + messages#push Pp.Error msg; if Stateid.equal safe_id Stateid.dummy then self#show_goals else undo safe_id (Doc.focused document && Doc.is_in_focus document safe_id)) @@ -720,7 +720,7 @@ object(self) ?(move_insert=false) (safe_id, (loc : (int * int) option), msg) = messages#clear; - messages#push Pp.Error (Richpp.richpp_of_string msg); + messages#push Pp.Error msg; ignore(self#process_feedback ()); if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ()) else @@ -777,9 +777,9 @@ object(self) self#show_goals in let display_error (loc, s) = - if not (Glib.Utf8.validate s) then + if not (validate s) then flash_info "This error is so nasty that I can't even display it." - else messages#add_string s + else messages#add s in let try_phrase phrase stop more = let action = log "Sending to coq now" in diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 414c360246..c28ed68605 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -330,10 +330,14 @@ let handle_exn (e, info) = let loc_of e = match Loc.get_loc e with | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc) | _ -> None in - let mk_msg () = read_stdout ()^"\n"^string_of_ppcmds (Errors.print ~info e) in + let mk_msg () = + let msg = read_stdout () in + let msg = str msg ++ fnl () ++ Errors.print ~info e in + Richpp.richpp_of_pp msg + in match e with - | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!" - | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!" + | Errors.Drop -> dummy, None, Richpp.richpp_of_string "Drop is not allowed by coqide!" + | Errors.Quit -> dummy, None, Richpp.richpp_of_string "Quit is not allowed by coqide!" | e -> match Stateid.get info with | Some (valid, _) -> valid, loc_of info, mk_msg () diff --git a/ide/interface.mli b/ide/interface.mli index 848fb817d4..f3777ba36c 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -118,7 +118,7 @@ type edit_id = Feedback.edit_id should probably retract to that point *) type 'a value = | Good of 'a - | Fail of (state_id * location * string) + | Fail of (state_id * location * richpp) type ('a, 'b) union = ('a, 'b) Util.union @@ -202,7 +202,7 @@ type about_sty = unit type about_rty = coq_info type handle_exn_sty = Exninfo.iexn -type handle_exn_rty = state_id * location * string +type handle_exn_rty = state_id * location * richpp (* Retrocompatibility stuff *) type interp_sty = (raw * verbose) * string diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 0ae57ee748..7d8993aa8b 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -107,7 +107,7 @@ object(self) let process = Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function | Interface.Fail (_,l,str) -> - result#buffer#insert str; + Ideutils.insert_xml result#buffer str; notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce; Coq.return () | Interface.Good res -> diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 46e5d6f370..7445ce5ca0 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -10,7 +10,7 @@ (** WARNING: TO BE UPDATED WHEN MODIFIED! *) -let protocol_version = "20150821" +let protocol_version = "20150913" (** * Interface of calls to Coq by CoqIde *) @@ -90,7 +90,7 @@ let of_value f = function | None -> [] | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in let id = Stateid.to_xml id in - Element ("value", ["val", "fail"] @ loc, [id;PCData msg]) + Element ("value", ["val", "fail"] @ loc, [id; Richpp.of_richpp msg]) let to_value f = function | Element ("value", attrs, l) -> let ans = massoc "val" attrs in @@ -103,8 +103,9 @@ let to_value f = function Some (loc_s, loc_e) with Marshal_error | Failure _ -> None in - let id = Stateid.of_xml (List.hd l) in - let msg = raw_string (List.tl l) in + let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise Marshal_error in + let id = Stateid.of_xml id in + let msg = Richpp.to_richpp msg in Fail (id, loc, msg) else raise Marshal_error | _ -> raise Marshal_error @@ -671,10 +672,10 @@ let to_call : xml -> unknown call = let pr_value_gen pr = function | Good v -> "GOOD " ^ pr v - | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^str^"]" + | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^Richpp.raw_print str^"]" | Fail (id,Some(i,j),str) -> "FAIL "^Stateid.to_string id^ - " ("^string_of_int i^","^string_of_int j^")["^str^"]" + " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]" let pr_value v = pr_value_gen (fun _ -> "FIXME") v let pr_full_value call value = match call with | Add _ -> pr_value_gen (print add_rty_t ) (Obj.magic value) @@ -730,7 +731,7 @@ let document to_string_fmt = (to_string_fmt (of_value (fun _ -> PCData "b") (Good ()))); Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n" (to_string_fmt (of_value (fun _ -> PCData "b") - (Fail (Stateid.initial,Some (15,34),"error message")))); + (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message")))); document_type_encoding to_string_fmt (* vim: set foldmethod=marker: *) -- cgit v1.2.3 From b3bd2696c31ad2cb544f3436ddb5a237fe7fa6fe Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Sun, 20 Sep 2015 15:34:19 +0200 Subject: Proof: suggest Admitted->Qed only if the proof is really complete (#4349) --- proofs/proof.ml | 10 ++++++++-- proofs/proof.mli | 3 +++ proofs/proof_global.ml | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/proofs/proof.ml b/proofs/proof.ml index a7077d9110..c7aa5bad97 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -173,6 +173,12 @@ let is_done p = (* spiwack: for compatibility with <= 8.2 proof engine *) let has_unresolved_evar p = Proofview.V82.has_unresolved_evar p.proofview +let has_shelved_goals p = not (CList.is_empty (p.shelf)) +let has_given_up_goals p = not (CList.is_empty (p.given_up)) + +let is_complete p = + is_done p && not (has_unresolved_evar p) && + not (has_shelved_goals p) && not (has_given_up_goals p) (* Returns the list of partial proofs to initial goals *) let partial_proof p = Proofview.partial_proof p.entry p.proofview @@ -305,9 +311,9 @@ end let return p = if not (is_done p) then raise UnfinishedProof - else if not (CList.is_empty (p.shelf)) then + else if has_shelved_goals p then raise HasShelvedGoals - else if not (CList.is_empty (p.given_up)) then + else if has_given_up_goals p then raise HasGivenUpGoals else if has_unresolved_evar p then (* spiwack: for compatibility with <= 8.3 proof engine *) diff --git a/proofs/proof.mli b/proofs/proof.mli index a2e10d8133..a0ed0654db 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -75,6 +75,9 @@ val initial_euctx : proof -> Evd.evar_universe_context to be considered (this does not require that all evars have been solved). *) val is_done : proof -> bool +(* Like is_done, but this time it really means done (i.e. nothing left to do) *) +val is_complete : proof -> bool + (* Returns the list of partial proofs to initial goals. *) val partial_proof : proof -> Term.constr list diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index c02b909164..6c963bf705 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -341,7 +341,7 @@ type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.ev let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in if allow_partial then begin - if Proof.is_done proof then begin + if Proof.is_complete proof then begin msg_warning (str"The proof of " ++ str (Names.Id.to_string pid) ++ str" is complete, no need to end it with Admitted"); end; -- cgit v1.2.3 From 0ac3a2f4de0dc02b973c9f5d59b3c0a97f888141 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 21 Sep 2015 10:35:56 +0200 Subject: Change the default modifiers for navigation. (Fix bug #4295) On most systems (including Windows, according to the bug report), shortcuts Ctrl+Alt+Arrows are preempted by the window manager by default. So don't use them for navigation in Coqide by default. Note that this change only has an impact when installing on a fresh system; it won't change anything for existing users. --- ide/preferences.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ide/preferences.ml b/ide/preferences.ml index 1bd9f587c7..90862d0647 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -190,7 +190,7 @@ let current = { automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; - modifier_for_navigation = ""; + modifier_for_navigation = ""; modifier_for_templates = ""; modifier_for_tactics = ""; modifier_for_display = ""; -- cgit v1.2.3 From 7c5356ed487dcf7cf915e5471832852f7002586c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Sep 2015 15:54:19 +0200 Subject: Fixing tutorial. The V7 to V8 translator lost part of term annotations. --- doc/tutorial/Tutorial.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex index 836944ab1c..e09feeb8eb 100644 --- a/doc/tutorial/Tutorial.tex +++ b/doc/tutorial/Tutorial.tex @@ -208,7 +208,7 @@ Definition two : nat := S one. Actually \Coq~ allows several possible syntaxes: \begin{coq_example} -Definition three : nat := S two. +Definition three := S two : nat. \end{coq_example} Here is a way to define the doubling function, which expects an -- cgit v1.2.3 From f2f146a997e92f3380d9cd9aa0f7aef80f50dba8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 22 Sep 2015 13:27:26 +0200 Subject: Fixing fake_ide. --- tools/fake_ide.ml | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index a9a7251c51..dfe6093d61 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -17,7 +17,18 @@ type coqtop = { xml_parser : Xml_parser.t; } -let logger level content = prerr_endline content +let print_xml chan xml = + let rec print = function + | Xml_datatype.PCData s -> output_string chan s + | Xml_datatype.Element (_, _, children) -> List.iter print children + in + print xml + +let error_xml s = + Printf.eprintf "fake_id: error: %a\n%!" print_xml s; + exit 1 + +let logger level content = Printf.eprintf "%a\n%! " print_xml content let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -38,8 +49,8 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop = let res = loop () in if print then prerr_endline (Xmlprotocol.pr_full_value call res); match res with - | Interface.Fail (_,_,s) when fail -> error s - | Interface.Fail (_,_,s) as x -> prerr_endline s; x + | Interface.Fail (_,_,s) when fail -> error_xml (Richpp.repr s) + | Interface.Fail (_,_,s) as x -> Printf.eprintf "%a\n%!" print_xml (Richpp.repr s); x | x -> x let eval_call c q = ignore(base_eval_call c q) @@ -188,7 +199,7 @@ let print_document () = module GUILogic = struct let after_add = function - | Interface.Fail (_,_,s) -> error s + | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) | Interface.Good (id, (Util.Inl (), _)) -> Document.assign_tip_id doc id | Interface.Good (id, (Util.Inr tip, _)) -> @@ -200,7 +211,7 @@ module GUILogic = struct let at id id' _ = Stateid.equal id' id let after_edit_at (id,need_unfocus) = function - | Interface.Fail (_,_,s) -> error s + | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) | Interface.Good (Util.Inl ()) -> if need_unfocus then Document.unfocus doc; ignore(Document.cut_at doc id); @@ -323,7 +334,7 @@ let main = let finish () = match base_eval_call (Xmlprotocol.status true) coq with | Interface.Good _ -> exit 0 - | Interface.Fail (_,_,s) -> error s in + | Interface.Fail (_,_,s) -> error_xml (Richpp.repr s) in (* The main loop *) init (); while true do -- cgit v1.2.3 From e1146f44229b380a8f52c67e1a51df4d6c03086e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 22 Sep 2015 15:40:40 +0200 Subject: Fixing bug #4207: setoid_rewrite creates self-referring hypotheses. We purge the environment given to the morphism searcher from all dependencies on the considered variable. I hope it is not too costly. --- tactics/rewrite.ml | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index aa057a3e86..3c4550a3cf 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1542,7 +1542,7 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let open Proofview.Notations in - let treat sigma (res, is_hyp) = + let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> Proofview.tclUNIT () @@ -1550,7 +1550,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in let gls = List.rev (Evd.fold_undefined fold undef []) in - match is_hyp, prf with + match clause, prf with | Some id, Some p -> let tac = Proofview.Refine.refine ~unsafe:false (fun h -> (h, p)) <*> Proofview.Unsafe.tclNEWGOALS gls in Proofview.Unsafe.tclEVARS undef <*> @@ -1582,17 +1582,25 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let ty, is_hyp = - match clause with - | Some id -> Environ.named_type id env, Some id - | None -> concl, None + let ty = match clause with + | None -> concl + | Some id -> Environ.named_type id env + in + let env = match clause with + | None -> env + | Some id -> + (** Only consider variables not depending on [id] *) + let ctx = Environ.named_context env in + let filter decl = not (occur_var_in_decl env id decl) in + let nctx = List.filter filter ctx in + Environ.reset_with_named_context (Environ.val_of_named_context nctx) env in try let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp + cl_rewrite_clause_aux ?abs strat env [] sigma ty clause in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in - treat sigma (res, is_hyp) <*> + treat sigma res <*> (** For compatibility *) beta <*> opt_beta <*> Proofview.shelve_unifiable with -- cgit v1.2.3 From 6459c0e8c240f0997873c50d4ec749effaba2f44 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 31 Jul 2015 18:33:06 +0200 Subject: Removing the generalization of the body of inductive schemes from Auto_ind_decl over the internal lemmas. The schemes are built in the main process and the internal lemmas are actually already also in the environment. --- proofs/pfedit.ml | 4 ++-- proofs/pfedit.mli | 2 +- toplevel/auto_ind_decl.ml | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index c77ab06b94..ceb4facc1e 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -145,12 +145,12 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo delete_current_proof (); iraise reraise -let build_by_tactic env ctx ?(poly=false) typ tac = +let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in let gk = Global, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in - let ce = Term_typing.handle_entry_side_effects env ce in + let ce = if side_eff then Term_typing.handle_entry_side_effects env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun (pt, _) -> pt, Declareops.no_seff) } in let (cb, ctx), se = Future.force ce.const_entry_body in assert(Declareops.side_effects_is_empty se); assert(Univ.ContextSet.is_empty ctx); diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 5e0fb4dd36..4aa3c3bfd2 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -153,7 +153,7 @@ val build_constant_by_tactic : types -> unit Proofview.tactic -> Entries.definition_entry * bool * Evd.evar_universe_context -val build_by_tactic : env -> Evd.evar_universe_context -> ?poly:polymorphic -> +val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> constr * bool * Evd.evar_universe_context diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index d1452fca21..16683d243e 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -637,7 +637,7 @@ let make_bl_scheme mind = context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in let ctx = Evd.empty_evar_universe_context (*FIXME univs *) in - let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx bl_goal + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff:false (Global.env()) ctx bl_goal (compute_bl_tact (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -759,7 +759,7 @@ let make_lb_scheme mind = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in let ctx = Evd.empty_evar_universe_context in - let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx lb_goal + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff:false (Global.env()) ctx lb_goal (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in ([|ans|], ctx (* FIXME *)), eff @@ -930,7 +930,7 @@ let make_eq_decidability mind = let ctx = Evd.empty_evar_universe_context (* FIXME *)in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff:false (Global.env()) ctx (compute_dec_goal (ind,u) lnamesparrec nparrec) (compute_dec_tact ind lnamesparrec nparrec) in -- cgit v1.2.3 From 13716dc6561a3379ba130f07ce7ecd1df379475c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 31 Jul 2015 18:45:41 +0200 Subject: Give a way to control if the decidable-equality schemes are built like in 8.4 with the schemes of the subcomponent of an inductive added to the environment or discharged as let-ins over the main scheme. As of today, decidable-equality schemes are built when calling vernacular command (Inductive with option Set Dedicable Equality Schemes, or Scheme Equality), so there is no need to discharge the sub-schemes as let-ins. But if ever the schemes are built from within an opaque proof and one would not like the schemes and a fortiori the subschemes to appear in the env, the new addition of a parameter internal_flag to "find_scheme" allows this possibility (then to be set to KernelSilent). --- tactics/elimschemes.ml | 20 ++++++++++---------- tactics/eqschemes.ml | 18 +++++++++--------- toplevel/auto_ind_decl.ml | 42 +++++++++++++++++++++++++----------------- toplevel/ind_tables.ml | 32 +++++++++++++++----------------- toplevel/ind_tables.mli | 15 ++++++--------- 5 files changed, 65 insertions(+), 62 deletions(-) diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index e1c9c2de59..e6a8cbe3ad 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -21,7 +21,7 @@ open Ind_tables (* Induction/recursion schemes *) -let optimize_non_type_induction_scheme kind dep sort ind = +let optimize_non_type_induction_scheme kind dep sort _ ind = let env = Global.env () in let sigma = Evd.from_env env in if check_scheme kind ind then @@ -68,15 +68,15 @@ let build_induction_scheme_in_type dep sort ind = let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" - (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" - (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" - (fun x -> build_induction_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type true InType x, Declareops.no_seff) let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" @@ -109,24 +109,24 @@ let build_case_analysis_scheme_in_type dep sort ind = let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" - (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" - (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" - (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" - (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" - (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" - (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 8643fe10f0..f7d3ad5d0a 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -191,7 +191,7 @@ let build_sym_scheme env ind = let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" - (fun ind -> + (fun _ ind -> let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in (c, ctx), Declareops.no_seff) @@ -262,7 +262,7 @@ let build_sym_involutive_scheme env ind = let sym_involutive_scheme_kind = declare_individual_scheme_object "_sym_involutive" - (fun ind -> + (fun _ ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) (**********************************************************************) @@ -650,7 +650,7 @@ let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme (**********************************************************************) let rew_l2r_dep_scheme_kind = declare_individual_scheme_object "_rew_r_dep" - (fun ind -> build_l2r_rew_scheme true (Global.env()) ind InType) + (fun _ ind -> build_l2r_rew_scheme true (Global.env()) ind InType) (**********************************************************************) (* Dependent rewrite from right-to-left in conclusion *) @@ -660,7 +660,7 @@ let rew_l2r_dep_scheme_kind = (**********************************************************************) let rew_r2l_dep_scheme_kind = declare_individual_scheme_object "_rew_dep" - (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) (**********************************************************************) (* Dependent rewrite from right-to-left in hypotheses *) @@ -670,7 +670,7 @@ let rew_r2l_dep_scheme_kind = (**********************************************************************) let rew_r2l_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_dep" - (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) (**********************************************************************) (* Dependent rewrite from left-to-right in hypotheses *) @@ -680,7 +680,7 @@ let rew_r2l_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_r_dep" - (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) @@ -693,7 +693,7 @@ let rew_l2r_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" - (fun ind -> fix_r2l_forward_rew_scheme + (fun _ ind -> fix_r2l_forward_rew_scheme (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Declareops.no_seff) (**********************************************************************) @@ -704,7 +704,7 @@ let rew_l2r_scheme_kind = (**********************************************************************) let rew_r2l_scheme_kind = declare_individual_scheme_object "_rew" - (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Declareops.no_seff) + (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Declareops.no_seff) (* End of rewriting schemes *) @@ -780,6 +780,6 @@ let build_congr env (eq,refl,ctx) ind = in c, Evd.evar_universe_context_of ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" - (fun ind -> + (fun _ ind -> (* May fail if equality is not defined *) build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 16683d243e..118ffb3e80 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -111,7 +111,7 @@ let check_bool_is_defined () = let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") -let build_beq_scheme kn = +let build_beq_scheme mode kn = check_bool_is_defined (); (* fetching global env *) let env = Global.env() in @@ -188,7 +188,7 @@ let build_beq_scheme kn = else begin try let eq, eff = - let c, eff = find_scheme (!beq_scheme_kind_aux()) (kn',i) in + let c, eff = find_scheme ~mode (!beq_scheme_kind_aux()) (kn',i) in mkConst c, eff in let eqa, eff = let eqa, effs = List.split (List.map aux a) in @@ -330,7 +330,7 @@ let destruct_ind c = so from Ai we can find the the correct eq_Ai bl_ai or lb_ai *) (* used in the leib -> bool side*) -let do_replace_lb lb_scheme_key aavoid narg p q = +let do_replace_lb mode lb_scheme_key aavoid narg p q = let avoid = Array.of_list aavoid in let do_arg v offset = try @@ -360,7 +360,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = let u,v = destruct_ind type_of_pq in let lb_type_of_p = try - let c, eff = find_scheme lb_scheme_key (out_punivs u) (*FIXME*) in + let c, eff = find_scheme ~mode lb_scheme_key (out_punivs u) (*FIXME*) in Proofview.tclUNIT (mkConst c, eff) with Not_found -> (* spiwack: the format of this error message should probably @@ -388,7 +388,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = end (* used in the bool -> leib side *) -let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = +let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let avoid = Array.of_list aavoid in let do_arg v offset = try @@ -551,7 +551,7 @@ let compute_bl_goal ind lnamesparrec nparrec = (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) ))), eff -let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec = +let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let avoid = ref [] in let first_intros = @@ -608,7 +608,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). if eq_gr (IndRef indeq) Coqlib.glob_eq then Tacticals.New.tclTHEN - (do_replace_bl bl_scheme_key ind + (do_replace_bl mode bl_scheme_key ind (!avoid) nparrec (ca.(2)) (ca.(1))) @@ -625,7 +625,12 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") -let make_bl_scheme mind = +let side_effect_of_mode = function + | Declare.KernelVerbose -> false + | Declare.KernelSilent -> true + | Declare.UserVerbose -> false + +let make_bl_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then errorlabstrm "" @@ -637,8 +642,9 @@ let make_bl_scheme mind = context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in let ctx = Evd.empty_evar_universe_context (*FIXME univs *) in - let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff:false (Global.env()) ctx bl_goal - (compute_bl_tact (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) + let side_eff = side_effect_of_mode mode in + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx bl_goal + (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -688,7 +694,7 @@ let compute_lb_goal ind lnamesparrec nparrec = (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))), eff -let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec = +let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let avoid = ref [] in let first_intros = @@ -732,7 +738,7 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec = | App(c,ca) -> (match (kind_of_term ca.(1)) with | App(c',ca') -> let n = Array.length ca' in - do_replace_lb lb_scheme_key + do_replace_lb mode lb_scheme_key (!avoid) nparrec ca'.(n-2) ca'.(n-1) @@ -747,7 +753,7 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec = let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") -let make_lb_scheme mind = +let make_lb_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then errorlabstrm "" @@ -759,8 +765,9 @@ let make_lb_scheme mind = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in let ctx = Evd.empty_evar_universe_context in - let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff:false (Global.env()) ctx lb_goal - (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) + let side_eff = side_effect_of_mode mode in + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx lb_goal + (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in ([|ans|], ctx (* FIXME *)), eff @@ -919,7 +926,7 @@ let compute_dec_tact ind lnamesparrec nparrec = ] end -let make_eq_decidability mind = +let make_eq_decidability mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then raise DecidabilityMutualNotSupported; @@ -930,7 +937,8 @@ let make_eq_decidability mind = let ctx = Evd.empty_evar_universe_context (* FIXME *)in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff:false (Global.env()) ctx + let side_eff = side_effect_of_mode mode in + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx (compute_dec_goal (ind,u) lnamesparrec nparrec) (compute_dec_tact ind lnamesparrec nparrec) in diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 0d39466ede..b59d6fc8ae 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -28,11 +28,10 @@ open Pp (**********************************************************************) (* Registering schemes in the environment *) - type mutual_scheme_object_function = - mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects type individual_scheme_object_function = - inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects type 'a scheme_kind = string @@ -141,32 +140,31 @@ let define internal id c p univs = in kn -let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) = - let (c, ctx), eff = f ind in +let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = + let (c, ctx), eff = f mode ind in let mib = Global.lookup_mind mind in let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let const = define internal id c mib.mind_polymorphic ctx in + let const = define mode id c mib.mind_polymorphic ctx in declare_scheme kind [|ind,const|]; const, Declareops.cons_side_effects (Safe_typing.sideff_of_scheme kind (Global.safe_env()) [ind,const]) eff -let define_individual_scheme kind internal names (mind,i as ind) = +let define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with | _,MutualSchemeFunction f -> assert false | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f internal names ind + define_individual_scheme_base kind s f mode names ind -let define_mutual_scheme_base kind suff f internal names mind = - let (cl, ctx), eff = f mind in +let define_mutual_scheme_base kind suff f mode names mind = + let (cl, ctx), eff = f mode mind in let mib = Global.lookup_mind mind in let ids = Array.init (Array.length mib.mind_packets) (fun i -> try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in - let consts = Array.map2 (fun id cl -> - define internal id cl mib.mind_polymorphic ctx) ids cl in + define mode id cl mib.mind_polymorphic ctx) ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; consts, @@ -175,11 +173,11 @@ let define_mutual_scheme_base kind suff f internal names mind = kind (Global.safe_env()) (Array.to_list schemes)) eff -let define_mutual_scheme kind internal names mind = +let define_mutual_scheme kind mode names mind = match Hashtbl.find scheme_object_table kind with | _,IndividualSchemeFunction _ -> assert false | s,MutualSchemeFunction f -> - define_mutual_scheme_base kind s f internal names mind + define_mutual_scheme_base kind s f mode names mind let find_scheme_on_env_too kind ind = let s = String.Map.find kind (Indmap.find ind !scheme_map) in @@ -188,14 +186,14 @@ let find_scheme_on_env_too kind ind = kind (Global.safe_env()) [ind, s]) Declareops.no_seff -let find_scheme kind (mind,i as ind) = +let find_scheme ?(mode=KernelSilent) kind (mind,i as ind) = try find_scheme_on_env_too kind ind with Not_found -> match Hashtbl.find scheme_object_table kind with | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f KernelSilent None ind + define_individual_scheme_base kind s f mode None ind | s,MutualSchemeFunction f -> - let ca, eff = define_mutual_scheme_base kind s f KernelSilent [] mind in + let ca, eff = define_mutual_scheme_base kind s f mode [] mind in ca.(i), eff let check_scheme kind ind = diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index 98eaac0928..d0844dd946 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -8,6 +8,7 @@ open Term open Names +open Declare (** This module provides support for registering inductive scheme builders, declaring schemes and generating schemes on demand *) @@ -19,9 +20,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects type individual_scheme_object_function = - inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects (** Main functions to register a scheme builder *) @@ -32,21 +33,17 @@ val declare_individual_scheme_object : string -> ?aux:string -> individual_scheme_object_function -> individual scheme_kind -(* -val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit -*) - (** Force generation of a (mutually) scheme with possibly user-level names *) val define_individual_scheme : individual scheme_kind -> - Declare.internal_flag (** internal *) -> + internal_flag (** internal *) -> Id.t option -> inductive -> constant * Declareops.side_effects -val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** internal *) -> +val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> (int * Id.t) list -> mutual_inductive -> constant array * Declareops.side_effects (** Main function to retrieve a scheme in the cache or to generate it *) -val find_scheme : 'a scheme_kind -> inductive -> constant * Declareops.side_effects +val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> constant * Declareops.side_effects val check_scheme : 'a scheme_kind -> inductive -> bool -- cgit v1.2.3 From 2ba2ca96be88bad5cd75a02c94cc48ef4f5209b7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 23 Sep 2015 18:25:15 +0200 Subject: Hopefully better names to constructors of internal_flag, as discussed with Enrico. --- library/declare.ml | 10 +++++----- library/declare.mli | 6 +++--- tactics/extratactics.ml4 | 2 +- tactics/rewrite.ml | 2 +- tactics/tactics.ml | 2 +- toplevel/auto_ind_decl.ml | 6 +++--- toplevel/classes.ml | 4 ++-- toplevel/ind_tables.ml | 8 ++++---- toplevel/indschemes.ml | 36 ++++++++++++++++++------------------ toplevel/record.ml | 2 +- 10 files changed, 39 insertions(+), 39 deletions(-) diff --git a/library/declare.ml b/library/declare.ml index c3181e4c75..8438380c9c 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -28,9 +28,9 @@ open Decl_kinds (** flag for internal message display *) type internal_flag = - | KernelVerbose (* kernel action, a message is displayed *) - | KernelSilent (* kernel action, no message is displayed *) - | UserVerbose (* user action, a message is displayed *) + | UserAutomaticRequest (* kernel action, a message is displayed *) + | InternalTacticRequest (* kernel action, no message is displayed *) + | UserIndividualRequest (* user action, a message is displayed *) (** Declaration of section variables and local definitions *) @@ -253,7 +253,7 @@ let declare_sideff env fix_exn se = if Constant.equal c c' then Some (x,kn) else None) inds_consts) knl)) -let declare_constant ?(internal = UserVerbose) ?(local = false) id ?(export_seff=false) (cd, kind) = +let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = let cd = (* We deal with side effects *) match cd with | Entries.DefinitionEntry de -> @@ -283,7 +283,7 @@ let declare_constant ?(internal = UserVerbose) ?(local = false) id ?(export_seff let kn = declare_constant_common id cst in kn -let declare_definition ?(internal=UserVerbose) +let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) ?(poly=false) id ?types (body,ctx) = let cb = diff --git a/library/declare.mli b/library/declare.mli index d8a00db0cf..76538a6248 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -43,9 +43,9 @@ type constant_declaration = constant_entry * logical_kind *) type internal_flag = - | KernelVerbose - | KernelSilent - | UserVerbose + | UserAutomaticRequest + | InternalTacticRequest + | UserIndividualRequest (* Defaut definition entries, transparent with no secctx or proj information *) val definition_entry : ?opaque:bool -> ?inline:bool -> ?types:types -> diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index e4240cb5cc..af0870bc92 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -320,7 +320,7 @@ let project_hint pri l2r r = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in let ctx = Evd.universe_context_set sigma in - let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in + let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 3c4550a3cf..c64a1226ab 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1896,7 +1896,7 @@ let add_morphism_infer glob m n = let instance = build_morphism_signature m in let evd = Evd.empty (*FIXME *) in if Lib.is_modtype () then - let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry (None,poly,(instance,Univ.UContext.empty),None), Decl_kinds.IsAssumption Decl_kinds.Logical) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index ad7ff14e6b..b113ed31e9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4450,7 +4450,7 @@ let abstract_subproof id gk tac = let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in (** ppedrot: seems legit to have abstracted subproofs as local*) - let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in let evd = Evd.set_universe_context evd ectx in diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 118ffb3e80..4122487e23 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -626,9 +626,9 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") let side_effect_of_mode = function - | Declare.KernelVerbose -> false - | Declare.KernelSilent -> true - | Declare.UserVerbose -> false + | Declare.UserAutomaticRequest -> false + | Declare.InternalTacticRequest -> true + | Declare.UserIndividualRequest -> false let make_bl_scheme mode mind = let mib = Global.lookup_mind mind in diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 33891ad94c..7fe79d948b 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -186,7 +186,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro in Evarutil.check_evars env Evd.empty !evars termtype; let ctx = Evd.universe_context !evars in - let cst = Declare.declare_constant ~internal:Declare.KernelSilent id + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (Entries.ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in instance_hook k None global imps ?hook (ConstRef cst); id @@ -363,7 +363,7 @@ let context poly l = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then let uctx = Univ.ContextSet.to_context uctx in let decl = (ParameterEntry (None,poly,(t,uctx),None), IsAssumption Logical) in - let cst = Declare.declare_constant ~internal:Declare.KernelSilent id decl in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in match class_of_constr t with | Some (rels, ((tc,_), args) as _cl) -> add_instance (Typeclasses.new_instance tc None false (*FIXME*) diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index b59d6fc8ae..218c47b28d 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -113,8 +113,8 @@ let is_visible_name id = let compute_name internal id = match internal with - | KernelVerbose | UserVerbose -> id - | KernelSilent -> + | UserAutomaticRequest | UserIndividualRequest -> id + | InternalTacticRequest -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name let define internal id c p univs = @@ -135,7 +135,7 @@ let define internal id c p univs = } in let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in let () = match internal with - | KernelSilent -> () + | InternalTacticRequest -> () | _-> definition_message id in kn @@ -186,7 +186,7 @@ let find_scheme_on_env_too kind ind = kind (Global.safe_env()) [ind, s]) Declareops.no_seff -let find_scheme ?(mode=KernelSilent) kind (mind,i as ind) = +let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = try find_scheme_on_env_too kind ind with Not_found -> match Hashtbl.find scheme_object_table kind with diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index 286d164c42..452d5fbe50 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -146,8 +146,8 @@ let declare_beq_scheme_gen internal names kn = let alarm what internal msg = let debug = false in match internal with - | KernelVerbose - | KernelSilent -> + | UserAutomaticRequest + | InternalTacticRequest -> (if debug then msg_warning (hov 0 msg ++ fnl () ++ what ++ str " not defined.")) @@ -195,13 +195,13 @@ let beq_scheme_msg mind = (List.init (Array.length mib.mind_packets) (fun i -> (mind,i))) let declare_beq_scheme_with l kn = - try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn + try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserIndividualRequest l kn let try_declare_beq_scheme kn = (* TODO: handle Fix, eventually handle proof-irrelevance; improve decidability by depending on decidability for the parameters rather than on the bl and lb properties *) - try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen KernelVerbose [] kn + try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserAutomaticRequest [] kn let declare_beq_scheme = declare_beq_scheme_with [] @@ -215,7 +215,7 @@ let declare_one_case_analysis_scheme ind = induction scheme, the other ones share the same code with the apropriate type *) if Sorts.List.mem InType kelim then - ignore (define_individual_scheme dep KernelVerbose None ind) + ignore (define_individual_scheme dep UserAutomaticRequest None ind) (* Induction/recursion schemes *) @@ -238,7 +238,7 @@ let declare_one_induction_scheme ind = List.map_filter (fun (sort,kind) -> if Sorts.List.mem sort kelim then Some kind else None) (if from_prop then kinds_from_prop else kinds_from_type) in - List.iter (fun kind -> ignore (define_individual_scheme kind KernelVerbose None ind)) + List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind)) elims let declare_induction_schemes kn = @@ -261,11 +261,11 @@ let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) let declare_eq_decidability_scheme_with l kn = try_declare_scheme (eq_dec_scheme_msg (kn,0)) - declare_eq_decidability_gen UserVerbose l kn + declare_eq_decidability_gen UserIndividualRequest l kn let try_declare_eq_decidability kn = try_declare_scheme (eq_dec_scheme_msg (kn,0)) - declare_eq_decidability_gen KernelVerbose [] kn + declare_eq_decidability_gen UserAutomaticRequest [] kn let declare_eq_decidability = declare_eq_decidability_scheme_with [] @@ -274,17 +274,17 @@ let ignore_error f x = let declare_rewriting_schemes ind = if Hipattern.is_inductive_equality ind then begin - ignore (define_individual_scheme rew_r2l_scheme_kind KernelVerbose None ind); - ignore (define_individual_scheme rew_r2l_dep_scheme_kind KernelVerbose None ind); + ignore (define_individual_scheme rew_r2l_scheme_kind UserAutomaticRequest None ind); + ignore (define_individual_scheme rew_r2l_dep_scheme_kind UserAutomaticRequest None ind); ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind - KernelVerbose None ind); + UserAutomaticRequest None ind); (* These ones expect the equality to be symmetric; the first one also *) (* needs eq *) - ignore_error (define_individual_scheme rew_l2r_scheme_kind KernelVerbose None) ind; + ignore_error (define_individual_scheme rew_l2r_scheme_kind UserAutomaticRequest None) ind; ignore_error - (define_individual_scheme rew_l2r_dep_scheme_kind KernelVerbose None) ind; + (define_individual_scheme rew_l2r_dep_scheme_kind UserAutomaticRequest None) ind; ignore_error - (define_individual_scheme rew_l2r_forward_dep_scheme_kind KernelVerbose None) ind + (define_individual_scheme rew_l2r_forward_dep_scheme_kind UserAutomaticRequest None) ind end let declare_congr_scheme ind = @@ -293,7 +293,7 @@ let declare_congr_scheme ind = try Coqlib.check_required_library Coqlib.logic_module_name; true with e when Errors.noncritical e -> false then - ignore (define_individual_scheme congr_scheme_kind KernelVerbose None ind) + ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind) else msg_warning (strbrk "Cannot build congruence scheme because eq is not found") end @@ -301,7 +301,7 @@ let declare_congr_scheme ind = let declare_sym_scheme ind = if Hipattern.is_inductive_equality ind then (* Expect the equality to be symmetric *) - ignore_error (define_individual_scheme sym_scheme_kind KernelVerbose None) ind + ignore_error (define_individual_scheme sym_scheme_kind UserAutomaticRequest None) ind (* Scheme command *) @@ -372,7 +372,7 @@ let do_mutual_induction_scheme lnamedepindsort = let decltype = Retyping.get_type_of env0 sigma decl in (* let decltype = refresh_universes decltype in *) let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Declareops.no_seff) in - let cst = define fi UserVerbose sigma proof_output (Some decltype) in + let cst = define fi UserIndividualRequest sigma proof_output (Some decltype) in ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in @@ -470,7 +470,7 @@ let do_combined_scheme name schemes = in let body,typ = build_combined_scheme (Global.env ()) csts in let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Declareops.no_seff) in - ignore (define (snd name) UserVerbose Evd.empty proof_output (Some typ)); + ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ)); fixpoint_message None [snd name] (**********************************************************************) diff --git a/toplevel/record.ml b/toplevel/record.ml index 484fd081df..e214f9ca71 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -298,7 +298,7 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field const_entry_inline_code = false; const_entry_feedback = None } in let k = (DefinitionEntry entry,IsDefinition kind) in - let kn = declare_constant ~internal:KernelSilent fid k in + let kn = declare_constant ~internal:InternalTacticRequest fid k in let constr_fip = let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in applist (mkConstU (kn,u),proj_args) -- cgit v1.2.3 From 8a031dc29abf1e16b2ee78322a7221b8b5c19a33 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Sep 2015 08:23:36 +0200 Subject: Fixing unsetting of CoqIDE tags. --- ide/preferences.ml | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/ide/preferences.ml b/ide/preferences.ml index dedd62902c..313d97086f 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -402,24 +402,34 @@ let create_tag name default = let pref = new preference ~name:[name] ~init:default ~repr:Repr.(tag) in let set_tag tag = begin match pref#get.tag_bg_color with - | None -> () - | Some c -> tag#set_property (`BACKGROUND c) + | None -> tag#set_property (`BACKGROUND_SET false) + | Some c -> + tag#set_property (`BACKGROUND_SET true); + tag#set_property (`BACKGROUND c) end; begin match pref#get.tag_fg_color with - | None -> () - | Some c -> tag#set_property (`FOREGROUND c) + | None -> tag#set_property (`FOREGROUND_SET false) + | Some c -> + tag#set_property (`FOREGROUND_SET true); + tag#set_property (`FOREGROUND c) end; begin match pref#get.tag_bold with - | false -> () - | true -> tag#set_property (`WEIGHT `BOLD) + | false -> tag#set_property (`WEIGHT_SET false) + | true -> + tag#set_property (`WEIGHT_SET true); + tag#set_property (`WEIGHT `BOLD) end; begin match pref#get.tag_italic with - | false -> () - | true -> tag#set_property (`STYLE `ITALIC) + | false -> tag#set_property (`STYLE_SET false) + | true -> + tag#set_property (`STYLE_SET true); + tag#set_property (`STYLE `ITALIC) end; begin match pref#get.tag_underline with - | false -> () - | true -> tag#set_property (`UNDERLINE `SINGLE) + | false -> tag#set_property (`UNDERLINE_SET false) + | true -> + tag#set_property (`UNDERLINE_SET true); + tag#set_property (`UNDERLINE `SINGLE) end; in let iter table = -- cgit v1.2.3 From b6725a2d0077239e51385a62a526ab9465eea26d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Sep 2015 18:45:40 +0200 Subject: The -compile option now accepts ".v" files and outputs a warning otherwise. --- library/library.ml | 12 ++++++------ library/library.mli | 10 ++++++---- toplevel/vernac.ml | 16 +++++++++++++--- 3 files changed, 25 insertions(+), 13 deletions(-) diff --git a/library/library.ml b/library/library.ml index f7ca4e9760..1bcffcd147 100644 --- a/library/library.ml +++ b/library/library.ml @@ -678,22 +678,22 @@ let check_module_name s = | c -> err c let start_library f = - let paths = Loadpath.get_paths () in - let _, longf = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in + let () = if not (Sys.file_exists f) then + errorlabstrm "" (hov 0 (str "Can't find file" ++ spc () ++ str f)) + in let ldir0 = try - let lp = Loadpath.find_load_path (Filename.dirname longf) in + let lp = Loadpath.find_load_path (Filename.dirname f) in Loadpath.logical lp with Not_found -> Nameops.default_root_prefix in - let file = Filename.basename f in + let file = Filename.chop_extension (Filename.basename f) in let id = Id.of_string file in check_module_name file; check_coq_overwriting ldir0 id; let ldir = add_dirpath_suffix ldir0 id in Declaremods.start_library ldir; - ldir,longf + ldir let load_library_todo f = let paths = Loadpath.get_paths () in diff --git a/library/library.mli b/library/library.mli index 967a54e4c8..f2e60718d6 100644 --- a/library/library.mli +++ b/library/library.mli @@ -25,7 +25,7 @@ val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> u val require_library_from_file : Id.t option -> CUnix.physical_path -> bool option -> unit -(** {6 ... } *) +(** {6 Start the compilation of a library } *) (** Segments of a library *) type seg_sum @@ -39,10 +39,12 @@ type seg_proofs = Term.constr Future.computation array an export otherwise just a simple import *) val import_module : bool -> qualid located list -> unit -(** {6 Start the compilation of a library } *) -val start_library : string -> DirPath.t * string +(** Start the compilation of a file as a library. The argument must be an + existing file on the system, and the returned path is the associated + absolute logical path of the library. *) +val start_library : CUnix.physical_path -> DirPath.t -(** {6 End the compilation of a library and save it to a ".vo" file } *) +(** End the compilation of a library and save it to a ".vo" file *) val save_library_to : ?todo:(((Future.UUID.t,'document) Stateid.request * bool) list * 'counters) -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 266d8f9b4f..14d2bcea41 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -294,7 +294,15 @@ let load_vernac verb file = if !Flags.beautify_file then close_out !chan_beautify; raise_with_file file (disable_drop e, info) -(* Compile a vernac file (f is assumed without .v suffix) *) +let ensure_v f = + if Filename.check_suffix f ".v" then f + else begin + msg_warning (str "File \"" ++ str f ++ strbrk "\" has been implicitly \ + expanded to \"" ++ str f ++ str ".v\""); + f ^ ".v" + end + +(* Compile a vernac file *) let compile verbosely f = let check_pending_proofs () = let pfs = Pfedit.get_all_proof_names () in @@ -302,7 +310,8 @@ let compile verbosely f = (msg_error (str "There are pending proofs"); flush_all (); exit 1) in match !Flags.compilation_mode with | BuildVo -> - let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in + let long_f_dot_v = ensure_v f in + let ldir = Flags.verbosely Library.start_library long_f_dot_v in Stm.set_compilation_hints long_f_dot_v; Aux_file.start_aux_file_for long_f_dot_v; Dumpglob.start_dump_glob long_f_dot_v; @@ -318,7 +327,8 @@ let compile verbosely f = Aux_file.stop_aux_file (); Dumpglob.end_dump_glob () | BuildVio -> - let ldir, long_f_dot_v = Flags.verbosely Library.start_library f in + let long_f_dot_v = ensure_v f in + let ldir = Flags.verbosely Library.start_library long_f_dot_v in Dumpglob.noglob (); Stm.set_compilation_hints long_f_dot_v; let _ = load_vernac verbosely long_f_dot_v in -- cgit v1.2.3 From 3930c586507bfb3b80297d7a2fdbbc6049aa509b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Sep 2015 19:13:30 +0200 Subject: Updating the documentation and the toolchain w.r.t. the change in -compile. --- CHANGES | 3 +++ Makefile.build | 4 ++-- doc/refman/RefMan-com.tex | 4 ++-- man/coqtop.1 | 4 ++-- test-suite/Makefile | 6 +++--- tools/coqc.ml | 7 +------ toplevel/usage.ml | 4 ++-- 7 files changed, 15 insertions(+), 17 deletions(-) diff --git a/CHANGES b/CHANGES index c8fca217fd..e3224db048 100644 --- a/CHANGES +++ b/CHANGES @@ -51,6 +51,9 @@ Tools - Flag -no-native-compiler was removed and became the default for coqc. If precompilation of files for native conversion test is desired, use -native-compiler. +- The -compile command-line option now takes the full path of the considered + file, including the ".v" extension, and outputs a warning if such an extension + is lacking. Changes from V8.5beta1 to V8.5beta2 =================================== diff --git a/Makefile.build b/Makefile.build index 6ceff2de95..39f60bd595 100644 --- a/Makefile.build +++ b/Makefile.build @@ -587,7 +587,7 @@ pluginsbyte: $(PLUGINS) theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d $(SHOW)'COQC -noinit $<' $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) theories/Init/$* -noinit -R theories Coq + $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) @@ -1038,7 +1038,7 @@ plugins/%_mod.ml: plugins/%.mllib %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) | %.v.d $(SHOW)'COQC $<' $(HIDE)rm -f $*.glob - $(HIDE)$(BOOTCOQC) $* + $(HIDE)$(BOOTCOQC) $< ifdef VALIDATE $(SHOW)'COQCHK $(call vo_to_mod,$@)' $(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 6335dfd324..2f9758fdee 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -162,11 +162,11 @@ Add physical path {\em directory} to the {\ocaml} loadpath. Load \Coq~compiled file {\em file}{\tt .vo} and import it ({\tt Require} {\em file}). -\item[{\tt -compile} {\em file},{\tt -compile-verbose} {\em file}, {\tt -batch}]\ +\item[{\tt -compile} {\em file.v},{\tt -compile-verbose} {\em file.v}, {\tt -batch}]\ {\tt coqtop} options only used internally by {\tt coqc}. - This compiles file {\em file}{\tt .v} into {\em file}{\tt .vo} without/with a + This compiles file {\em file.v} into {\em file}{\tt .vo} without/with a copy of the contents of the file on standard input. This option implies options {\tt -batch} (exit just after arguments parsing). It is only available for {\tt coqtop}. diff --git a/man/coqtop.1 b/man/coqtop.1 index 1bc4629d0f..705ea43f67 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -84,7 +84,7 @@ load Coq object file and import it (Require Import filename.) .TP -.BI \-compile \ filename +.BI \-compile \ filename.v compile Coq file .I filename.v (implies @@ -92,7 +92,7 @@ compile Coq file ) .TP -.BI \-compile\-verbose \ filename +.BI \-compile\-verbose \ filename.v verbosely compile Coq file .I filename.v (implies diff --git a/test-suite/Makefile b/test-suite/Makefile index d2466250ab..39c36d5414 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -208,7 +208,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -238,7 +238,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" $(call get_coq_prog_args,"$<") -async-proofs on \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ -async-proofs-private-flags fallback-to-lazy-if-marshal-error=no,fallback-to-lazy-if-slave-dies=no \ $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ @@ -352,7 +352,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v # Additionnal dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v - $(HIDE)$(coqtop) -R modules Mods -compile $(<:.v=) + $(HIDE)$(coqtop) -R modules Mods -compile $< ####################################################################### # Miscellaneous tests diff --git a/tools/coqc.ml b/tools/coqc.ml index 5710b97f2a..e7239da682 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -30,13 +30,8 @@ let verbose = ref false let rec make_compilation_args = function | [] -> [] | file :: fl -> - let file_noext = - if Filename.check_suffix file ".v" then - Filename.chop_suffix file ".v" - else file - in (if !verbose then "-compile-verbose" else "-compile") - :: file_noext :: (make_compilation_args fl) + :: file :: (make_compilation_args fl) (* compilation of files [files] with command [command] and args [args] *) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index a5d8450b9d..3c001eadcc 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -43,8 +43,8 @@ let print_usage_channel co command = \n -lv f (idem)\ \n -load-vernac-object f load Coq object file f.vo\ \n -require f load Coq object file f.vo and import it (Require f.)\ -\n -compile f compile Coq file f.v (implies -batch)\ -\n -compile-verbose f verbosely compile Coq file f.v (implies -batch)\ +\n -compile f.v compile Coq file f.v (implies -batch)\ +\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ \n -quick quickly compile .v files to .vio files (skip proofs)\ \n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ \n into fi.vo\ -- cgit v1.2.3 From 8e25e107a8715728a7227934d7b11035863ee5f0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Sep 2015 12:25:35 +0200 Subject: The -require option now accepts a logical path instead of a physical one. --- CHANGES | 2 ++ doc/refman/RefMan-com.tex | 6 +++--- library/library.ml | 20 +++++--------------- library/library.mli | 3 +-- man/coqide.1 | 10 +++++----- man/coqtop.1 | 8 ++++---- toplevel/coqtop.ml | 8 ++++---- toplevel/usage.ml | 2 +- toplevel/vernacentries.mli | 3 +++ 9 files changed, 28 insertions(+), 34 deletions(-) diff --git a/CHANGES b/CHANGES index e3224db048..950f2fab18 100644 --- a/CHANGES +++ b/CHANGES @@ -54,6 +54,8 @@ Tools - The -compile command-line option now takes the full path of the considered file, including the ".v" extension, and outputs a warning if such an extension is lacking. +- The -require command-line option now takes a logical path of a given library + rather than a physical path. Changes from V8.5beta1 to V8.5beta2 =================================== diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 2f9758fdee..0f1823a021 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -157,10 +157,10 @@ Add physical path {\em directory} to the {\ocaml} loadpath. Load \Coq~compiled file {\em file}{\tt .vo} -\item[{\tt -require} {\em file}]\ +\item[{\tt -require} {\em path}]\ - Load \Coq~compiled file {\em file}{\tt .vo} and import it ({\tt - Require} {\em file}). + Load \Coq~compiled library {\em path} and import it (equivalent to {\tt + Require Import} {\em path}). \item[{\tt -compile} {\em file.v},{\tt -compile-verbose} {\em file.v}, {\tt -batch}]\ diff --git a/library/library.ml b/library/library.ml index 1bcffcd147..a09f91b15a 100644 --- a/library/library.ml +++ b/library/library.ml @@ -488,18 +488,8 @@ let rec_intern_library libs mref = let _, libs = intern_library libs mref None in libs -let check_library_short_name f dir = function - | Some id when not (Id.equal id (snd (split_dirpath dir))) -> - errorlabstrm "check_library_short_name" - (str "The file " ++ str f ++ str " contains library" ++ spc () ++ - pr_dirpath dir ++ spc () ++ str "and not library" ++ spc () ++ - pr_id id) - | _ -> () - -let rec_intern_by_filename_only id f = +let rec_intern_by_filename_only f = let m = try intern_from_file f with Sys_error s -> error s in - (* Only the base name is expected to match *) - check_library_short_name f m.library_name id; (* We check no other file containing same library is loaded *) if library_is_loaded m.library_name then begin @@ -518,12 +508,12 @@ let native_name_from_filename f = let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in Nativecode.mod_uid_of_dirpath lmd.md_name -let rec_intern_library_from_file idopt f = +let rec_intern_library_from_file f = (* A name is specified, we have to check it contains library id *) let paths = Loadpath.get_paths () in let _, f = System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in - rec_intern_by_filename_only idopt f + rec_intern_by_filename_only f (**********************************************************************) (*s [require_library] loads and possibly opens a library. This is a @@ -600,8 +590,8 @@ let require_library_from_dirpath modrefl export = add_anonymous_leaf (in_require (needed,modrefl,export)); add_frozen_state () -let require_library_from_file idopt file export = - let modref,needed = rec_intern_library_from_file idopt file in +let require_library_from_file file export = + let modref,needed = rec_intern_library_from_file file in let needed = List.rev_map snd needed in if Lib.is_module_or_modtype () then begin add_anonymous_leaf (in_require (needed,[modref],None)); diff --git a/library/library.mli b/library/library.mli index f2e60718d6..3d96f9a751 100644 --- a/library/library.mli +++ b/library/library.mli @@ -22,8 +22,7 @@ open Libnames (** Require = load in the environment + open (if the optional boolean is not [None]); mark also for export if the boolean is [Some true] *) val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit -val require_library_from_file : - Id.t option -> CUnix.physical_path -> bool option -> unit +val require_library_from_file : CUnix.physical_path -> bool option -> unit (** {6 Start the compilation of a library } *) diff --git a/man/coqide.1 b/man/coqide.1 index 3fa7f0e418..cfd9c3b4a2 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -67,11 +67,11 @@ Load Coq file Load Coq object file .IR f .vo. .TP -.BI \-require\ f -Load Coq object file -.IR f .vo -and import it (Require -.IR f .). +.BI \-require\ path +Load Coq library +.IR path +and import it (Require Import +.IR path .). .TP .BI \-compile\ f Compile Coq file diff --git a/man/coqtop.1 b/man/coqtop.1 index 705ea43f67..e079bee39b 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -78,10 +78,10 @@ load Coq object file .I filename.vo .TP -.BI \-require \ filename -load Coq object file -.I filename.vo -and import it (Require Import filename.) +.BI \-require \ path +load Coq library +.I path +and import it (Require Import path.) .TP .BI \-compile \ filename.v diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index d67559d77f..32ac9a496d 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -171,7 +171,7 @@ let load_vernacular () = let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj let load_vernac_obj () = - List.iter (fun f -> Library.require_library_from_file None f None) + List.iter (fun f -> Library.require_library_from_file f None) (List.rev !load_vernacular_obj) let require_prelude () = @@ -185,9 +185,9 @@ let require_prelude () = let require_list = ref ([] : string list) let add_require s = require_list := s :: !require_list let require () = - if !load_init then silently require_prelude (); - List.iter (fun s -> Library.require_library_from_file None s (Some false)) - (List.rev !require_list) + let () = if !load_init then silently require_prelude () in + let map dir = Qualid (Loc.ghost, qualid_of_string dir) in + Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list) let compile_list = ref ([] : (bool * string) list) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 3c001eadcc..472503ced2 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -42,7 +42,7 @@ let print_usage_channel co command = \n -load-vernac-source-verbose f load Coq file f.v (Load Verbose f.)\ \n -lv f (idem)\ \n -load-vernac-object f load Coq object file f.vo\ -\n -require f load Coq object file f.vo and import it (Require f.)\ +\n -require path load Coq library path and import it (Require Import path.)\ \n -compile f.v compile Coq file f.v (implies -batch)\ \n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ \n -quick quickly compile .v files to .vio files (skip proofs)\ diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 4b1cd7a013..c6d87596dc 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -16,6 +16,9 @@ val show_prooftree : unit -> unit val show_node : unit -> unit +val vernac_require : + Libnames.reference option -> bool option -> Libnames.reference list -> unit + (** This function can be used by any command that want to observe terms in the context of the current goal *) val get_current_context_of_args : int option -> Evd.evar_map * Environ.env -- cgit v1.2.3 From 592151e323036f0044a0ac285b8b13c964825989 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Sep 2015 14:06:38 +0200 Subject: Fixing bug #4347: Not_found Exception with some Records. A term was reduced in an improper environment. --- pretyping/evarutil.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index ee6bbe7fbe..8ebb037c24 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -757,7 +757,7 @@ let define_evar_as_product evd (evk,args) = let define_pure_evar_as_lambda env evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in - let typ = whd_betadeltaiota env evd (evar_concl evi) in + let typ = whd_betadeltaiota evenv evd (evar_concl evi) in let evd1,(na,dom,rng) = match kind_of_term typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ -- cgit v1.2.3 From 802f3a5c313c8ef98109a3f29c3c862de63bd53c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Sep 2015 14:17:45 +0200 Subject: Test for bug #4347. --- test-suite/bugs/closed/4347.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 test-suite/bugs/closed/4347.v diff --git a/test-suite/bugs/closed/4347.v b/test-suite/bugs/closed/4347.v new file mode 100644 index 0000000000..29686a26c1 --- /dev/null +++ b/test-suite/bugs/closed/4347.v @@ -0,0 +1,17 @@ +Fixpoint demo_recursion(n:nat) := match n with + |0 => Type + |S k => (demo_recursion k) -> Type + end. + +Record Demonstration := mkDemo +{ + demo_law : forall n:nat, demo_recursion n; + demo_stuff : forall n:nat, forall q:(fix demo_recursion (n : nat) : Type := + match n with + | 0 => Type + | S k => demo_recursion k -> Type + end) n, (demo_law (S n)) q +}. + +Theorem DemoError : Demonstration. +Fail apply mkDemo. (*Anomaly: Uncaught exception Not_found. Please report.*) -- cgit v1.2.3 From 5481ff4f6935874ac3798a61f5a2a810006bde37 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 26 Sep 2015 15:00:33 +0200 Subject: Clarifying the doc of coqdoc --utf8 as discussed on coq-club on August 19, 2015. --- doc/refman/coqdoc.tex | 14 ++++++++------ tools/coqdoc/main.ml | 4 ++-- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/doc/refman/coqdoc.tex b/doc/refman/coqdoc.tex index ee2b042f4e..30467a5e6e 100644 --- a/doc/refman/coqdoc.tex +++ b/doc/refman/coqdoc.tex @@ -285,7 +285,7 @@ suffix \verb!.tex!. Select a \texmacs\ output. -\item[\texttt{--stdout}] ~\par +\item[\texttt{\mm{}stdout}] ~\par Write output to stdout. @@ -496,14 +496,16 @@ Default behavior is to assume ASCII 7 bits input files. \item[\texttt{-latin1}, \texttt{\mm{}latin1}] ~\par Select ISO-8859-1 input files. It is equivalent to - \texttt{--inputenc latin1 --charset iso-8859-1}. + \texttt{\mm{}inputenc latin1 \mm{}charset iso-8859-1}. \item[\texttt{-utf8}, \texttt{\mm{}utf8}] ~\par - Select UTF-8 (Unicode) input files. It is equivalent to - \texttt{--inputenc utf8 --charset utf-8}. - \LaTeX\ UTF-8 support can be found at - \url{http://www.ctan.org/pkg/unicode}. + Set \texttt{\mm{}inputenc utf8x} for \LaTeX\ output and + \texttt{\mm{}charset utf-8} for HTML output. Also use Unicode + replacements for a couple of standard plain ASCII notations such + as $\rightarrow$ for \texttt{->} and $\forall$ for + \texttt{forall}. \LaTeX\ UTF-8 support can be found at + \url{http://www.ctan.org/pkg/unicode}. \item[\texttt{\mm{}inputenc} \textit{string}] ~\par diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 2554ed495b..22febd6a64 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -61,8 +61,8 @@ let usage () = prerr_endline " --coqlib_path set the path where Coq files are installed"; prerr_endline " -R map physical dir to Coq dir"; prerr_endline " -Q map physical dir to Coq dir"; - prerr_endline " --latin1 set ISO-8859-1 input language"; - prerr_endline " --utf8 set UTF-8 input language"; + prerr_endline " --latin1 set ISO-8859-1 mode"; + prerr_endline " --utf8 set UTF-8 mode"; prerr_endline " --charset set HTML charset"; prerr_endline " --inputenc set LaTeX input encoding"; prerr_endline " --interpolate try to typeset identifiers in comments using definitions in the same module"; -- cgit v1.2.3 From 4b88d774729e0ab7916730e8e6ebedc2033a87f2 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 26 Sep 2015 16:31:29 +0200 Subject: Documenting how to support some special unicode characters in coqdoc (thanks to coq-club, Sep 2015). --- doc/refman/coqdoc.tex | 9 +++++++++ tools/coqdoc/output.ml | 7 +++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/doc/refman/coqdoc.tex b/doc/refman/coqdoc.tex index 30467a5e6e..26dbd59e76 100644 --- a/doc/refman/coqdoc.tex +++ b/doc/refman/coqdoc.tex @@ -507,6 +507,15 @@ Default behavior is to assume ASCII 7 bits input files. \texttt{forall}. \LaTeX\ UTF-8 support can be found at \url{http://www.ctan.org/pkg/unicode}. + For the interpretation of Unicode characters by \LaTeX, extra + packages which {\coqdoc} does not provide by default might be + required, such as \texttt{textgreek} for some Greek letters or + \texttt{stmaryrd} for some mathematical symbols. If a Unicode + character is missing an interpretation in the \texttt{utf8x} input + encoding, add + \verb=\DeclareUnicodeCharacter{=\textit{code}\verb=}{=\textit{latex-interpretation}\verb=}=. Packages + and declarations can be added with option \texttt{-p}. + \item[\texttt{\mm{}inputenc} \textit{string}] ~\par Give a \LaTeX\ input encoding, as an option to \LaTeX\ package diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 06030c45a6..8589f94a01 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -197,8 +197,11 @@ module Latex = struct printf "\n"; printf "%%Warning: tipa declares many non-standard macros used by utf8x to\n"; printf "%%interpret utf8 characters but extra packages might have to be added\n"; - printf "%%(e.g. \"textgreek\" for Greek letters not already in tipa).\n"; - printf "%%Use coqdoc's option -p to add new packages.\n"; + printf "%%such as \"textgreek\" for Greek letters not already in tipa\n"; + printf "%%or \"stmaryrd\" for mathematical symbols.\n"; + printf "%%Utf8 codes missing a LaTeX interpretation can be defined by using\n"; + printf "%%\\DeclareUnicodeCharacter{code}{interpretation}.\n"; + printf "%%Use coqdoc's option -p to add new packages or declarations.\n"; printf "\\usepackage{tipa}\n"; printf "\n" -- cgit v1.2.3 From 39b2c31fed01073a4308e2e85d8a53ccecde73e7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Sep 2015 16:45:30 +0200 Subject: Use default GTK styles for CoqIDE tags. --- ide/preferences.ml | 40 ++++++++++++++++++++++++---------------- 1 file changed, 24 insertions(+), 16 deletions(-) diff --git a/ide/preferences.ml b/ide/preferences.ml index 23426cad65..a605014f2c 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -398,6 +398,14 @@ let tags = ref Util.String.Map.empty let list_tags () = !tags +let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) () = { + tag_fg_color = fg; + tag_bg_color = bg; + tag_bold = bold; + tag_italic = italic; + tag_underline = underline; +} + let create_tag name default = let pref = new preference ~name:[name] ~init:default ~repr:Repr.(tag) in let set_tag tag = @@ -442,23 +450,23 @@ let create_tag name default = tags := Util.String.Map.add name pref !tags let () = - let iter name = create_tag name default_tag in + let iter (name, tag) = create_tag name tag in List.iter iter [ - "constr.evar"; - "constr.keyword"; - "constr.notation"; - "constr.path"; - "constr.reference"; - "constr.type"; - "constr.variable"; - "message.debug"; - "message.error"; - "message.warning"; - "module.definition"; - "module.keyword"; - "tactic.keyword"; - "tactic.primitive"; - "tactic.string"; + ("constr.evar", make_tag ()); + ("constr.keyword", make_tag ~fg:"dark green" ()); + ("constr.notation", make_tag ()); + ("constr.path", make_tag ()); + ("constr.reference", make_tag ~fg:"navy"()); + ("constr.type", make_tag ~fg:"#008080" ()); + ("constr.variable", make_tag ()); + ("message.debug", make_tag ()); + ("message.error", make_tag ()); + ("message.warning", make_tag ()); + ("module.definition", make_tag ~fg:"orange red" ~bold:true ()); + ("module.keyword", make_tag ()); + ("tactic.keyword", make_tag ()); + ("tactic.primitive", make_tag ()); + ("tactic.string", make_tag ()); ] let processed_color = -- cgit v1.2.3 From f52826877059858fb3fcd4314c629ed63d90a042 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Sep 2015 19:50:41 +0200 Subject: Hardening the API of evarmaps. The evar counter has been moved from Evarutil to Evd, and all functions in Evarutil now go through a dedicated primitive to create a fresh evar from an evarmap. --- engine/evd.ml | 45 +++++++++++++++++++++------------------------ engine/evd.mli | 18 ++++++++++-------- pretyping/evarconv.ml | 2 +- pretyping/evarutil.ml | 31 +++++++++++++------------------ pretyping/evarutil.mli | 1 - stm/stm.ml | 2 +- 6 files changed, 46 insertions(+), 53 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index fc4f5e040e..1af8565bdb 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -632,14 +632,30 @@ let reassign_name_defined evk evk' (evtoid,idtoev) = (EvMap.add evk' id (EvMap.remove evk evtoid), Idmap.add id evk' (Idmap.remove id idtoev)) -let add d e i = match i.evar_body with +let add_with_name ?(naming = Misctypes.IntroAnonymous) d e i = match i.evar_body with | Evar_empty -> - let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in + let evar_names = add_name_undefined naming e i d.evar_names in { d with undf_evars = EvMap.add e i d.undf_evars; evar_names } | Evar_defined _ -> let evar_names = remove_name_possibly_already_defined e d.evar_names in { d with defn_evars = EvMap.add e i d.defn_evars; evar_names } +let add d e i = add_with_name d e i + +(** New evars *) + +let evar_counter_summary_name = "evar counter" + +(* Generator of existential names *) +let new_untyped_evar = + let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in + fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr + +let new_evar evd ?naming evi = + let evk = new_untyped_evar () in + let evd = add_with_name evd ?naming evk evi in + (evd, evk) + let remove d e = let undf_evars = EvMap.remove e d.undf_evars in let defn_evars = EvMap.remove e d.defn_evars in @@ -831,27 +847,8 @@ let define evk body evd = let evar_names = remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } -let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole)) - ?(filter=Filter.identity) ?candidates ?(store=Store.empty) - ?(naming=Misctypes.IntroAnonymous) evd = - let () = match Filter.repr filter with - | None -> () - | Some filter -> - assert (Int.equal (List.length filter) (List.length (named_context_of_val hyps))) - in - let evar_info = { - evar_hyps = hyps; - evar_concl = ty; - evar_body = Evar_empty; - evar_filter = filter; - evar_source = src; - evar_candidates = candidates; - evar_extra = store; } - in - let evar_names = add_name_newly_undefined naming evk evar_info evd.evar_names in - { evd with undf_evars = EvMap.add evk evar_info evd.undf_evars; evar_names } - -let restrict evk evk' filter ?candidates evd = +let restrict evk filter ?candidates evd = + let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in let evar_info' = { evar_info with evar_filter = filter; @@ -863,7 +860,7 @@ let restrict evk evk' filter ?candidates evd = let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; - defn_evars; evar_names } + defn_evars; evar_names }, evk' let downcast evk ccl evd = let evar_info = EvMap.find evk evd.undf_evars in diff --git a/engine/evd.mli b/engine/evd.mli index 94d9d5f662..e240ebc310 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -143,6 +143,10 @@ val has_undefined : evar_map -> bool (** [has_undefined sigma] is [true] if and only if there are uninstantiated evars in [sigma]. *) +val new_evar : evar_map -> + ?naming:Misctypes.intro_pattern_naming_expr -> evar_info -> evar_map * evar +(** Creates a fresh evar mapping to the given information. *) + val add : evar_map -> evar -> evar_info -> evar_map (** [add sigma ev info] adds [ev] with evar info [info] in sigma. Precondition: ev must not preexist in [sigma]. *) @@ -230,14 +234,8 @@ val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> (** {6 Misc} *) -val evar_declare : - named_context_val -> evar -> types -> ?src:Loc.t * Evar_kinds.t -> - ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> evar_map -> evar_map -(** Convenience function. Just a wrapper around {!add}. *) - -val restrict : evar -> evar -> Filter.t -> ?candidates:constr list -> - evar_map -> evar_map +val restrict : evar -> Filter.t -> ?candidates:constr list -> + evar_map -> evar_map * evar (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) @@ -614,3 +612,7 @@ val create_evar_defs : evar_map -> evar_map (** Create an [evar_map] with empty meta map: *) val create_goal_evar_defs : evar_map -> evar_map + +(** {5 Summary names} *) + +val evar_counter_summary_name : string diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index bb07bf0563..d5bb564f66 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -830,7 +830,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (i,t2::ks, m-1, test) else let dloc = (Loc.ghost,Evar_kinds.InternalHole) in - let (i',ev) = new_evar env i ~src:dloc (substl ks b) in + let (i',ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in (i', ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index ee6bbe7fbe..6684b06048 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -239,17 +239,6 @@ let make_pure_subst evi args = | _ -> anomaly (Pp.str "Instance does not match its signature")) (evar_filtered_context evi) (Array.rev_to_list args,[])) -(**********************) -(* Creating new evars *) -(**********************) - -let evar_counter_summary_name = "evar counter" - -(* Generator of existential names *) -let new_untyped_evar = - let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in - fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr - (*------------------------------------* * functional operations on evar sets * *------------------------------------*) @@ -354,17 +343,15 @@ let push_rel_context_to_named_context env typ = let default_source = (Loc.ghost,Evar_kinds.InternalHole) let restrict_evar evd evk filter candidates = - let evk' = new_untyped_evar () in - let evd = Evd.restrict evk evk' filter ?candidates evd in + let evd, evk' = Evd.restrict evk filter ?candidates evd in Evd.declare_future_goal evk' evd, evk' let new_pure_evar_full evd evi = - let evk = new_untyped_evar () in - let evd = Evd.add evd evk evi in + let (evd, evk) = Evd.new_evar evd evi in let evd = Evd.declare_future_goal evk evd in (evd, evk) -let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ = +let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = let default_naming = if principal then (* waiting for a more principled approach @@ -374,8 +361,16 @@ let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?nam Misctypes.IntroAnonymous in let naming = Option.default default_naming naming in - let newevk = new_untyped_evar() in - let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in + let evi = { + evar_hyps = sign; + evar_concl = typ; + evar_body = Evar_empty; + evar_filter = filter; + evar_source = src; + evar_candidates = candidates; + evar_extra = store; } + in + let (evd, newevk) = Evd.new_evar evd ~naming evi in let evd = if principal then Evd.declare_principal_goal newevk evd else Evd.declare_future_goal newevk evd diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index f1d94b0a4f..76d67c748d 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -252,4 +252,3 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located val meta_counter_summary_name : string -val evar_counter_summary_name : string diff --git a/stm/stm.ml b/stm/stm.ml index 4a303f036e..f178c3ae4a 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -166,7 +166,7 @@ type visit = { step : step; next : Stateid.t } (* Parts of the system state that are morally part of the proof state *) let summary_pstate = [ Evarutil.meta_counter_summary_name; - Evarutil.evar_counter_summary_name; + Evd.evar_counter_summary_name; "program-tcc-table" ] type state = { system : States.state; -- cgit v1.2.3 From ca14b0bb67c9db000736333a056fc147c6f5199c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Sep 2015 14:16:54 +0200 Subject: Removing uselessly duplicated function in Evd. --- engine/evd.ml | 4 ---- engine/evd.mli | 2 -- plugins/decl_mode/decl_proof_instr.ml | 2 +- proofs/clenv.ml | 2 +- proofs/clenvtac.ml | 2 +- proofs/logic.ml | 4 ++-- tactics/equality.ml | 2 +- 7 files changed, 6 insertions(+), 12 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index 1af8565bdb..ae382cab45 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -766,10 +766,6 @@ let cmap f evd = (* spiwack: deprecated *) let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } -(* spiwack: tentatively deprecated *) -let create_goal_evar_defs sigma = { sigma with - (* conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } *) - metas=Metamap.empty } let empty = { defn_evars = EvMap.empty; diff --git a/engine/evd.mli b/engine/evd.mli index e240ebc310..0902191818 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -611,8 +611,6 @@ val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds val create_evar_defs : evar_map -> evar_map (** Create an [evar_map] with empty meta map: *) -val create_goal_evar_defs : evar_map -> evar_map - (** {5 Summary names} *) val evar_counter_summary_name : string diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 714cd86341..f8ddd5f80c 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -86,7 +86,7 @@ Please \"suppose\" something or \"end\" it now." | _ -> () let mk_evd metalist gls = - let evd0= create_goal_evar_defs (sig_sig gls) in + let evd0= clear_metas (sig_sig gls) in let add_one (meta,typ) evd = meta_declare meta typ evd in List.fold_right add_one metalist evd0 diff --git a/proofs/clenv.ml b/proofs/clenv.ml index a2cccc0e0b..16146f4846 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -119,7 +119,7 @@ let clenv_environments evd bound t = clrec (evd,[]) bound t let mk_clenv_from_env env sigma n (c,cty) = - let evd = create_goal_evar_defs sigma in + let evd = clear_metas sigma in let (evd,args,concl) = clenv_environments evd n cty in { templval = mk_freelisted (applist (c,args)); templtyp = mk_freelisted concl; diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index aaa49f1169..f54d4c4470 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -121,7 +121,7 @@ let unify ?(flags=fail_quick_unif_flags) m = Proofview.Goal.enter begin fun gl -> let env = Tacmach.New.pf_env gl in let n = Tacmach.New.pf_nf_concl gl in - let evd = create_goal_evar_defs (Proofview.Goal.sigma gl) in + let evd = clear_metas (Proofview.Goal.sigma gl) in try let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' diff --git a/proofs/logic.ml b/proofs/logic.ml index 5c48995fc7..7d101b4c72 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -95,12 +95,12 @@ let check_typability env sigma c = forces the user to give them in order). *) let clear_hyps env sigma ids sign cl = - let evdref = ref (Evd.create_goal_evar_defs sigma) in + let evdref = ref (Evd.clear_metas sigma) in let (hyps,cl) = Evarutil.clear_hyps_in_evi env evdref sign cl ids in (hyps, cl, !evdref) let clear_hyps2 env sigma ids sign t cl = - let evdref = ref (Evd.create_goal_evar_defs sigma) in + let evdref = ref (Evd.clear_metas sigma) in let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in (hyps, t, cl, !evdref) diff --git a/tactics/equality.ml b/tactics/equality.ml index ec0e1d2f4e..a10d8a0747 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1095,7 +1095,7 @@ let minimal_free_rels_rec env sigma = let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let sigdata = find_sigma_data env sort_of_ty in - let evdref = ref (Evd.create_goal_evar_defs sigma) in + let evdref = ref (Evd.clear_metas sigma) in let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) -- cgit v1.2.3 From b6d5a9f47634371aa18c6e3159c6bc24203d229f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Sep 2015 14:22:29 +0200 Subject: Fixing loss of extra data in Evd. --- pretyping/evd.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index fc4f5e040e..6326112912 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1385,7 +1385,7 @@ let set_metas evd metas = { evar_names = evd.evar_names; future_goals = evd.future_goals; principal_future_goal = evd.principal_future_goal; - extras = Store.empty; + extras = evd.extras; } let meta_list evd = metamap_to_list evd.metas -- cgit v1.2.3 From 9cadb903b7c3a3be8014152b293cd5ade3a7c8b7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Sep 2015 16:36:10 +0200 Subject: Removing subst_defined_metas_evars from Evd. --- engine/evd.ml | 12 ------------ engine/evd.mli | 1 - pretyping/unification.ml | 13 +++++++++++++ 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index ae382cab45..9c53006c13 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1504,18 +1504,6 @@ let retract_coercible_metas evd = let metas = Metamap.smartmapi map evd.metas in !mc, set_metas evd metas -let subst_defined_metas_evars (bl,el) c = - let rec substrec c = match kind_of_term c with - | Meta i -> - let select (j,_,_) = Int.equal i j in - substrec (pi2 (List.find select bl)) - | Evar (evk,args) -> - let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in - (try substrec (pi3 (List.find select el)) - with Not_found -> map_constr substrec c) - | _ -> map_constr substrec c - in try Some (substrec c) with Not_found -> None - let evar_source_of_meta mv evd = match meta_name evd mv with | Anonymous -> (Loc.ghost,Evar_kinds.GoalEvar) diff --git a/engine/evd.mli b/engine/evd.mli index 0902191818..cfe4adc09d 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -457,7 +457,6 @@ val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map type metabinding = metavariable * constr * instance_status val retract_coercible_metas : evar_map -> metabinding list * evar_map -val subst_defined_metas_evars : metabinding list * ('a * existential * constr) list -> constr -> constr option (** {5 FIXME: Nothing to do here} *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 24e06007e9..123f9b8cd3 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -554,6 +554,19 @@ let isAllowedEvar flags c = match kind_of_term c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) | _ -> false + +let subst_defined_metas_evars (bl,el) c = + let rec substrec c = match kind_of_term c with + | Meta i -> + let select (j,_,_) = Int.equal i j in + substrec (pi2 (List.find select bl)) + | Evar (evk,args) -> + let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in + (try substrec (pi3 (List.find select el)) + with Not_found -> map_constr substrec c) + | _ -> map_constr substrec c + in try Some (substrec c) with Not_found -> None + let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN = match subst_defined_metas_evars (metasubst,[]) tyM with | None -> sigma -- cgit v1.2.3 From a3d7630d74b720b771e880dcf0fcad05de553a6e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Sep 2015 16:39:36 +0200 Subject: Removing meta_with_name from Evd. --- engine/evd.ml | 33 --------------------------------- engine/evd.mli | 1 - proofs/clenv.ml | 38 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 38 insertions(+), 34 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index 9c53006c13..12a04fcc22 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1451,39 +1451,6 @@ let meta_reassign mv (v, pb) evd = let meta_name evd mv = try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous -let explain_no_such_bound_variable evd id = - let mvl = - List.rev (Metamap.fold (fun n clb l -> - let na = fst (clb_name clb) in - if na != Anonymous then out_name na :: l else l) - evd.metas []) in - errorlabstrm "Evd.meta_with_name" - (str"No such bound variable " ++ pr_id id ++ - (if mvl == [] then str " (no bound variables at all in the expression)." - else - (str" (possible name" ++ - str (if List.length mvl == 1 then " is: " else "s are: ") ++ - pr_enum pr_id mvl ++ str")."))) - -let meta_with_name evd id = - let na = Name id in - let (mvl,mvnodef) = - Metamap.fold - (fun n clb (l1,l2 as l) -> - let (na',def) = clb_name clb in - if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2) - else l) - evd.metas ([],[]) in - match mvnodef, mvl with - | _,[] -> - explain_no_such_bound_variable evd id - | ([n],_|_,[n]) -> - n - | _ -> - errorlabstrm "Evd.meta_with_name" - (str "Binder name \"" ++ pr_id id ++ - strbrk "\" occurs more than once in clause.") - let clear_metas evd = {evd with metas = Metamap.empty} let meta_merge evd1 evd2 = diff --git a/engine/evd.mli b/engine/evd.mli index cfe4adc09d..bc81bd8189 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -440,7 +440,6 @@ val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_ val meta_type : evar_map -> metavariable -> types val meta_ftype : evar_map -> metavariable -> types freelisted val meta_name : evar_map -> metavariable -> Name.t -val meta_with_name : evar_map -> Id.t -> metavariable val meta_declare : metavariable -> types -> ?name:Name.t -> evar_map -> evar_map val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 16146f4846..0697c94d74 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -432,6 +432,44 @@ let check_bindings bl = str " occurs more than once in binding list.") | [] -> () +let explain_no_such_bound_variable evd id = + let fold l (n, clb) = + let na = match clb with + | Cltyp (na, _) -> na + | Clval (na, _, _) -> na + in + if na != Anonymous then out_name na :: l else l + in + let mvl = List.fold_left fold [] (Evd.meta_list evd) in + errorlabstrm "Evd.meta_with_name" + (str"No such bound variable " ++ pr_id id ++ + (if mvl == [] then str " (no bound variables at all in the expression)." + else + (str" (possible name" ++ + str (if List.length mvl == 1 then " is: " else "s are: ") ++ + pr_enum pr_id mvl ++ str")."))) + +let meta_with_name evd id = + let na = Name id in + let fold (l1, l2 as l) (n, clb) = + let (na',def) = match clb with + | Cltyp (na, _) -> (na, false) + | Clval (na, _, _) -> (na, true) + in + if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2) + else l + in + let (mvl, mvnodef) = List.fold_left fold ([], []) (Evd.meta_list evd) in + match mvnodef, mvl with + | _,[] -> + explain_no_such_bound_variable evd id + | ([n],_|_,[n]) -> + n + | _ -> + errorlabstrm "Evd.meta_with_name" + (str "Binder name \"" ++ pr_id id ++ + strbrk "\" occurs more than once in clause.") + let meta_of_binder clause loc mvs = function | NamedHyp s -> meta_with_name clause.evd s | AnonHyp n -> -- cgit v1.2.3 From 2cf609c41f7af83d9eaf43308a368fcb7307e6fa Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 28 Sep 2015 11:04:59 +0200 Subject: Make -load-vernac-object respect the loadpath. This command-line option was behaving like the old -require, except that it did not do Import. In other words, it was loading files without respecting the loadpath. Now it behaves exactly like Require, while -require now behaves like Require Import. This patch also removes Library.require_library_from_file and all its dependencies, since they are no longer used inside Coq. --- CHANGES | 5 +++-- doc/refman/RefMan-com.tex | 4 ++-- library/library.ml | 34 ---------------------------------- library/library.mli | 1 - man/coqide.1 | 8 +++++--- man/coqtop.1 | 7 ++++--- toplevel/coqtop.ml | 4 ++-- 7 files changed, 16 insertions(+), 47 deletions(-) diff --git a/CHANGES b/CHANGES index 950f2fab18..16d86c8ff1 100644 --- a/CHANGES +++ b/CHANGES @@ -54,8 +54,9 @@ Tools - The -compile command-line option now takes the full path of the considered file, including the ".v" extension, and outputs a warning if such an extension is lacking. -- The -require command-line option now takes a logical path of a given library - rather than a physical path. +- The -require and -load-vernac-object command-line options now take a logical + path of a given library rather than a physical path, thus they behave like + Require [Import] path. Changes from V8.5beta1 to V8.5beta2 =================================== diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 0f1823a021..9862abb533 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -153,9 +153,9 @@ Add physical path {\em directory} to the {\ocaml} loadpath. Load \Coq~file {\em file}{\tt .v} optionally with copy it contents on the standard input. -\item[{\tt -load-vernac-object} {\em file}]\ +\item[{\tt -load-vernac-object} {\em path}]\ - Load \Coq~compiled file {\em file}{\tt .vo} + Load \Coq~compiled library {\em path} (equivalent to {\tt Require} {\em path}). \item[{\tt -require} {\em path}]\ diff --git a/library/library.ml b/library/library.ml index a09f91b15a..6d7b0f603a 100644 --- a/library/library.ml +++ b/library/library.ml @@ -488,33 +488,11 @@ let rec_intern_library libs mref = let _, libs = intern_library libs mref None in libs -let rec_intern_by_filename_only f = - let m = try intern_from_file f with Sys_error s -> error s in - (* We check no other file containing same library is loaded *) - if library_is_loaded m.library_name then - begin - msg_warning - (pr_dirpath m.library_name ++ str " is already loaded from file " ++ - str (library_full_filename m.library_name)); - m.library_name, [] - end - else - let needed, contents = intern_library_deps ([], DPMap.empty) m.library_name m (Some f) in - let needed = List.map (fun dir -> dir, DPMap.find dir contents) needed in - m.library_name, needed - let native_name_from_filename f = let ch = System.with_magic_number_check raw_intern_library f in let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in Nativecode.mod_uid_of_dirpath lmd.md_name -let rec_intern_library_from_file f = - (* A name is specified, we have to check it contains library id *) - let paths = Loadpath.get_paths () in - let _, f = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in - rec_intern_by_filename_only f - (**********************************************************************) (*s [require_library] loads and possibly opens a library. This is a synchronized operation. It is performed as follows: @@ -590,18 +568,6 @@ let require_library_from_dirpath modrefl export = add_anonymous_leaf (in_require (needed,modrefl,export)); add_frozen_state () -let require_library_from_file file export = - let modref,needed = rec_intern_library_from_file file in - let needed = List.rev_map snd needed in - if Lib.is_module_or_modtype () then begin - add_anonymous_leaf (in_require (needed,[modref],None)); - Option.iter (fun exp -> add_anonymous_leaf (in_import_library ([modref],exp))) - export - end - else - add_anonymous_leaf (in_require (needed,[modref],export)); - add_frozen_state () - (* the function called by Vernacentries.vernac_import *) let safe_locate_module (loc,qid) = diff --git a/library/library.mli b/library/library.mli index 3d96f9a751..d5e610dd67 100644 --- a/library/library.mli +++ b/library/library.mli @@ -22,7 +22,6 @@ open Libnames (** Require = load in the environment + open (if the optional boolean is not [None]); mark also for export if the boolean is [Some true] *) val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit -val require_library_from_file : CUnix.physical_path -> bool option -> unit (** {6 Start the compilation of a library } *) diff --git a/man/coqide.1 b/man/coqide.1 index cfd9c3b4a2..6a3e67ad53 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -63,9 +63,11 @@ Load Coq file (Load Verbose .IR f .). .TP -.BI \-load\-vernac\-object\ f -Load Coq object file -.IR f .vo. +.BI \-load\-vernac\-object\ path +Load Coq library +.IR path +(Require +.IR path .). .TP .BI \-require\ path Load Coq library diff --git a/man/coqtop.1 b/man/coqtop.1 index e079bee39b..62d17aa674 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -73,9 +73,10 @@ load verbosely Coq file (Load Verbose filename.) .TP -.BI \-load\-vernac\-object \ filename -load Coq object file -.I filename.vo +.BI \-load\-vernac\-object \ path +load Coq library +.I path +(Require path.) .TP .BI \-require \ path diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 32ac9a496d..b7f1e4a197 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -171,8 +171,8 @@ let load_vernacular () = let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj let load_vernac_obj () = - List.iter (fun f -> Library.require_library_from_file f None) - (List.rev !load_vernacular_obj) + let map dir = Qualid (Loc.ghost, qualid_of_string dir) in + Vernacentries.vernac_require None None (List.rev_map map !load_vernacular_obj) let require_prelude () = let vo = Envars.coqlib () / "theories/Init/Prelude.vo" in -- cgit v1.2.3 From da4d0b0e3d82621fe8338dd313b788472fc31bb2 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 29 Sep 2015 10:26:08 +0200 Subject: Remove some uses of Loadpath.get_paths. The single remaining use is in library/states.ml. This use should be reviewed, as it is most certainly broken. The other uses of Loadpath.get_paths did not disappear by miracle though. They were replaced by a new function Loadpath.locate_file which factors all the uses of the function. This function should not be used as it is as broken as Loadpath.get_paths, by definition. Vernac.load_vernac now takes a complete path rather than looking up for the file. That is the way it was used most of the time, so the lookup was unnecessary. For instance, Vernac.compile was calling Library.start_library which already expected a complete path. Another consequence is that System.find_file_in_path is almost no longer used (except for Loadpath.locate_file, obviously). The two remaining uses are System.intern_state (used by States.intern_state, cf above) and Mltop.dir_ml_load for dynamically loading compiled .ml files. --- library/library.ml | 4 +--- library/loadpath.ml | 6 ++++++ library/loadpath.mli | 4 ++++ stm/vio_checking.ml | 4 +--- toplevel/coqtop.ml | 1 + toplevel/vernac.ml | 13 ++++--------- toplevel/vernacentries.ml | 7 ++----- 7 files changed, 19 insertions(+), 20 deletions(-) diff --git a/library/library.ml b/library/library.ml index 6d7b0f603a..f5c7f63358 100644 --- a/library/library.ml +++ b/library/library.ml @@ -652,9 +652,7 @@ let start_library f = ldir let load_library_todo f = - let paths = Loadpath.get_paths () in - let _, longf = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in + let longf = Loadpath.locate_file (f^".v") in let f = longf^"io" in let ch = System.with_magic_number_check raw_intern_library f in let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in diff --git a/library/loadpath.ml b/library/loadpath.ml index 26af809e78..d35dca2125 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -112,3 +112,9 @@ let expand_path dir = if DirPath.equal dir lg then (ph, lg) :: aux l else aux l in aux !load_paths + +let locate_file fname = + let paths = get_paths () in + let _,longfname = + System.find_file_in_path ~warn:(Flags.is_verbose()) paths fname in + longfname diff --git a/library/loadpath.mli b/library/loadpath.mli index 3251b8c60c..c2c689af70 100644 --- a/library/loadpath.mli +++ b/library/loadpath.mli @@ -52,3 +52,7 @@ val expand_path : DirPath.t -> (CUnix.physical_path * DirPath.t) list val filter_path : (DirPath.t -> bool) -> (CUnix.physical_path * DirPath.t) list (** As {!expand_path} but uses a filter function instead, and ignores the implicit status of loadpaths. *) + +val locate_file : string -> string +(** Locate a file among the registered paths. Do not use this function, as + it does not respect the visibility of paths. *) diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 4df9603dca..06bf955c82 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -104,9 +104,7 @@ let schedule_vio_compilation j fs = let f = if Filename.check_suffix f ".vio" then Filename.chop_extension f else f in - let paths = Loadpath.get_paths () in - let _, long_f_dot_v = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in + let long_f_dot_v = Loadpath.locate_file (f^".v") in let aux = Aux_file.load_aux_file_for long_f_dot_v in let eta = try float_of_string (Aux_file.get aux Loc.ghost "vo_compile_time") diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index b7f1e4a197..4031a161b8 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -162,6 +162,7 @@ let add_load_vernacular verb s = let load_vernacular () = List.iter (fun (s,b) -> + let s = Loadpath.locate_file s in if Flags.do_beautify () then with_option beautify_file (Vernac.load_vernac b) s else diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 14d2bcea41..a0cd618e99 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -97,10 +97,7 @@ let user_error loc s = Errors.user_err_loc (loc,"_",str s) Note: we could use only one thanks to seek_in, but seeking on and on in the file we parse seems a bit risky to me. B.B. *) -let open_file_twice_if verbosely fname = - let paths = Loadpath.get_paths () in - let _,longfname = - find_file_in_path ~warn:(Flags.is_verbose()) paths fname in +let open_file_twice_if verbosely longfname = let in_chan = open_utf8_file_in longfname in let verb_ch = if verbosely then Some (open_utf8_file_in longfname) else None in @@ -206,19 +203,17 @@ let rec vernac_com verbose checknav (loc,com) = let interp = function | VernacLoad (verbosely, fname) -> let fname = Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in + let fname = CUnix.make_suffix fname ".v" in + let f = Loadpath.locate_file fname in let st = save_translator_coqdoc () in if !Flags.beautify_file then begin - let paths = Loadpath.get_paths () in - let _,f = find_file_in_path ~warn:(Flags.is_verbose()) - paths - (CUnix.make_suffix fname ".v") in chan_beautify := open_out (f^beautify_suffix); Pp.comments := [] end; begin try - read_vernac_file verbosely (CUnix.make_suffix fname ".v"); + read_vernac_file verbosely f; restore_translator_coqdoc st; with reraise -> let reraise = Errors.push reraise in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 8efcccaaae..ec81a3f1ae 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -365,8 +365,7 @@ let dump_universes sorted s = (* "Locate" commands *) let locate_file f = - let paths = Loadpath.get_paths () in - let _, file = System.find_file_in_path ~warn:false paths f in + let file = Flags.silently Loadpath.locate_file f in str file let msg_found_library = function @@ -1845,9 +1844,7 @@ let vernac_load interp fname = Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in let input = - let paths = Loadpath.get_paths () in - let _,longfname = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths fname in + let longfname = Loadpath.locate_file fname in let in_chan = open_utf8_file_in longfname in Pcoq.Gram.parsable (Stream.of_channel in_chan) in try while true do interp (snd (parse_sentence input)) done -- cgit v1.2.3 From 82a618e8a4945752698a7900c8af7a51091f7b1b Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 29 Sep 2015 17:05:45 +0200 Subject: Prevent States.intern_state and System.extern_intern from looking up files in the loadpath. This patch causes a bit of code duplication (because of the .coq suffix added to state files) but it makes it clear which part of the code is looking up files in the loadpath and for what purpose. Also it makes the interface of System.extern_intern and System.raw_extern_intern much saner. --- lib/system.ml | 11 +++++------ lib/system.mli | 6 +++--- library/library.ml | 6 ++++-- library/states.ml | 6 +----- toplevel/coqtop.ml | 10 ++++++++-- toplevel/vernacentries.ml | 2 ++ 6 files changed, 23 insertions(+), 18 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index d1cdd8efc9..139effd9fa 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -178,7 +178,7 @@ let raw_extern_intern magic = let extern_state filename = let channel = open_trapping_failure filename in output_binary_int channel magic; - filename, channel + channel and intern_state filename = try let channel = open_in_bin filename in @@ -191,11 +191,11 @@ let raw_extern_intern magic = in (extern_state,intern_state) -let extern_intern ?(warn=true) magic = +let extern_intern magic = let (raw_extern,raw_intern) = raw_extern_intern magic in - let extern_state name val_0 = + let extern_state filename val_0 = try - let (filename,channel) = raw_extern name in + let channel = raw_extern filename in try marshal_out channel val_0; close_out channel @@ -205,9 +205,8 @@ let extern_intern ?(warn=true) magic = iraise reraise with Sys_error s -> errorlabstrm "System.extern_state" (str "System error: " ++ str s) - and intern_state paths name = + and intern_state filename = try - let _,filename = find_file_in_path ~warn paths name in let channel = raw_intern filename in let v = marshal_in filename channel in close_in channel; diff --git a/lib/system.mli b/lib/system.mli index a3d66d577a..5797502e9f 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -37,10 +37,10 @@ val find_file_in_path : exception Bad_magic_number of string val raw_extern_intern : int -> - (string -> string * out_channel) * (string -> in_channel) + (string -> out_channel) * (string -> in_channel) -val extern_intern : ?warn:bool -> int -> - (string -> 'a -> unit) * (CUnix.load_path -> string -> 'a) +val extern_intern : int -> + (string -> 'a -> unit) * (string -> 'a) val with_magic_number_check : ('a -> 'b) -> 'a -> 'b diff --git a/library/library.ml b/library/library.ml index f5c7f63358..0fb938e9b6 100644 --- a/library/library.ml +++ b/library/library.ml @@ -742,7 +742,8 @@ let save_library_to ?todo dir f otab = if Array.exists (fun (d,_) -> DirPath.equal d dir) sd.md_deps then error_recursively_dependent_library dir; (* Open the vo file and write the magic number *) - let (f',ch) = raw_extern_library f in + let f' = f in + let ch = raw_extern_library f' in try (* Writing vo payload *) System.marshal_out_segment f' ch (sd : seg_sum); @@ -765,7 +766,8 @@ let save_library_to ?todo dir f otab = iraise reraise let save_library_raw f sum lib univs proofs = - let (f',ch) = raw_extern_library (f^"o") in + let f' = f^".o" in + let ch = raw_extern_library f' in System.marshal_out_segment f' ch (sum : seg_sum); System.marshal_out_segment f' ch (lib : seg_lib); System.marshal_out_segment f' ch (Some univs : seg_univ option); diff --git a/library/states.ml b/library/states.ml index 96a487b160..4e55f0cdc6 100644 --- a/library/states.ml +++ b/library/states.ml @@ -22,16 +22,12 @@ let unfreeze (fl,fs) = Summary.unfreeze_summaries fs let (extern_state,intern_state) = - let ensure_suffix f = CUnix.make_suffix f ".coq" in let (raw_extern, raw_intern) = extern_intern Coq_config.state_magic_number in (fun s -> - let s = ensure_suffix s in raw_extern s (freeze ~marshallable:`Yes)), (fun s -> - let s = ensure_suffix s in - let paths = Loadpath.get_paths () in - unfreeze (with_magic_number_check (raw_intern paths) s); + unfreeze (with_magic_number_check raw_intern s); Library.overwrite_library_filenames s) (* Rollback. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 4031a161b8..7562c29f70 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -144,13 +144,19 @@ let inputstate = ref "" let set_inputstate s = let () = msg_warning (str "The inputstate option is deprecated and discouraged.") in inputstate:=s -let inputstate () = if not (String.is_empty !inputstate) then intern_state !inputstate +let inputstate () = + if not (String.is_empty !inputstate) then + let fname = Loadpath.locate_file (CUnix.make_suffix !inputstate ".coq") in + intern_state fname let outputstate = ref "" let set_outputstate s = let () = msg_warning (str "The outputstate option is deprecated and discouraged.") in outputstate:=s -let outputstate () = if not (String.is_empty !outputstate) then extern_state !outputstate +let outputstate () = + if not (String.is_empty !outputstate) then + let fname = CUnix.make_suffix !outputstate ".coq" in + extern_state fname let set_include d p implicit = let p = dirpath_of_string p in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index ec81a3f1ae..8ae6ac2bc3 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -929,10 +929,12 @@ let vernac_chdir = function let vernac_write_state file = Pfedit.delete_all_proofs (); + let file = CUnix.make_suffix file ".coq" in States.extern_state file let vernac_restore_state file = Pfedit.delete_all_proofs (); + let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in States.intern_state file (************) -- cgit v1.2.3 From 05ab666a1283de5500dbc0520d18bdb05d95f286 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 29 Sep 2015 17:45:27 +0200 Subject: Make the interface of System.raw_extern_intern much saner. There is no reason (any longer?) to create simultaneous closures for interning and externing files. This patch makes the code more readable by separating both functions and their signatures. --- checker/check.ml | 18 +++----------- lib/system.ml | 71 +++++++++++++++++++++++++----------------------------- lib/system.mli | 10 +++++--- library/library.ml | 16 ++++++------ library/states.ml | 14 +++++------ 5 files changed, 58 insertions(+), 71 deletions(-) diff --git a/checker/check.ml b/checker/check.ml index c835cec824..2bc470aead 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -271,20 +271,10 @@ let try_locate_qualified_library qid = | LibNotFound -> error_lib_not_found qid (************************************************************************) -(*s Low-level interning/externing of libraries to files *) +(*s Low-level interning of libraries from files *) -(*s Loading from disk to cache (preparation phase) *) - -let raw_intern_library = - snd (System.raw_extern_intern Coq_config.vo_magic_number) - -let with_magic_number_check f a = - try f a - with System.Bad_magic_number fname -> - errorlabstrm "with_magic_number_check" - (str"file " ++ str fname ++ spc () ++ str"has bad magic number." ++ - spc () ++ str"It is corrupted" ++ spc () ++ - str"or was compiled with another version of Coq.") +let raw_intern_library f = + System.raw_intern_state Coq_config.vo_magic_number f (************************************************************************) (* Internalise libraries *) @@ -312,7 +302,7 @@ let intern_from_file (dir, f) = Flags.if_verbose pp (str"[intern "++str f++str" ..."); pp_flush (); let (sd,md,table,opaque_csts,digest) = try - let ch = with_magic_number_check raw_intern_library f in + let ch = System.with_magic_number_check raw_intern_library f in let (sd:Cic.summary_disk), _, digest = System.marshal_in_segment f ch in let (md:Cic.library_disk), _, _ = System.marshal_in_segment f ch in let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in diff --git a/lib/system.ml b/lib/system.ml index 139effd9fa..ddc56956c5 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -174,47 +174,42 @@ let skip_in_segment f ch = exception Bad_magic_number of string -let raw_extern_intern magic = - let extern_state filename = - let channel = open_trapping_failure filename in - output_binary_int channel magic; +let raw_extern_state magic filename = + let channel = open_trapping_failure filename in + output_binary_int channel magic; + channel + +let raw_intern_state magic filename = + try + let channel = open_in_bin filename in + if not (Int.equal (input_binary_int filename channel) magic) then + raise (Bad_magic_number filename); channel - and intern_state filename = - try - let channel = open_in_bin filename in - if not (Int.equal (input_binary_int filename channel) magic) then - raise (Bad_magic_number filename); - channel - with - | End_of_file -> error_corrupted filename "premature end of file" - | Failure s | Sys_error s -> error_corrupted filename s - in - (extern_state,intern_state) + with + | End_of_file -> error_corrupted filename "premature end of file" + | Failure s | Sys_error s -> error_corrupted filename s -let extern_intern magic = - let (raw_extern,raw_intern) = raw_extern_intern magic in - let extern_state filename val_0 = - try - let channel = raw_extern filename in - try - marshal_out channel val_0; - close_out channel - with reraise -> - let reraise = Errors.push reraise in - let () = try_remove filename in - iraise reraise - with Sys_error s -> - errorlabstrm "System.extern_state" (str "System error: " ++ str s) - and intern_state filename = +let extern_state magic filename val_0 = + try + let channel = raw_extern_state magic filename in try - let channel = raw_intern filename in - let v = marshal_in filename channel in - close_in channel; - v - with Sys_error s -> - errorlabstrm "System.intern_state" (str "System error: " ++ str s) - in - (extern_state,intern_state) + marshal_out channel val_0; + close_out channel + with reraise -> + let reraise = Errors.push reraise in + let () = try_remove filename in + iraise reraise + with Sys_error s -> + errorlabstrm "System.extern_state" (str "System error: " ++ str s) + +let intern_state magic filename = + try + let channel = raw_intern_state magic filename in + let v = marshal_in filename channel in + close_in channel; + v + with Sys_error s -> + errorlabstrm "System.intern_state" (str "System error: " ++ str s) let with_magic_number_check f a = try f a diff --git a/lib/system.mli b/lib/system.mli index 5797502e9f..247d528b97 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -36,11 +36,13 @@ val find_file_in_path : exception Bad_magic_number of string -val raw_extern_intern : int -> - (string -> out_channel) * (string -> in_channel) +val raw_extern_state : int -> string -> out_channel -val extern_intern : int -> - (string -> 'a -> unit) * (string -> 'a) +val raw_intern_state : int -> string -> in_channel + +val extern_state : int -> string -> 'a -> unit + +val intern_state : int -> string -> 'a val with_magic_number_check : ('a -> 'b) -> 'a -> 'b diff --git a/library/library.ml b/library/library.ml index 0fb938e9b6..6da9ccf68b 100644 --- a/library/library.ml +++ b/library/library.ml @@ -19,10 +19,12 @@ open Lib (************************************************************************) (*s Low-level interning/externing of libraries to files *) -(*s Loading from disk to cache (preparation phase) *) +let raw_extern_library f = + System.raw_extern_state Coq_config.vo_magic_number f -let (raw_extern_library, raw_intern_library) = - System.raw_extern_intern Coq_config.vo_magic_number +let raw_intern_library f = + System.with_magic_number_check + (System.raw_intern_state Coq_config.vo_magic_number) f (************************************************************************) (** Serialized objects loaded on-the-fly *) @@ -56,7 +58,7 @@ let in_delayed f ch = let fetch_delayed del = let { del_digest = digest; del_file = f; del_off = pos; } = del in try - let ch = System.with_magic_number_check raw_intern_library f in + let ch = raw_intern_library f in let () = seek_in ch pos in let obj, _, digest' = System.marshal_in_segment f ch in let () = close_in ch in @@ -434,7 +436,7 @@ let mk_summary m = { } let intern_from_file f = - let ch = System.with_magic_number_check raw_intern_library f in + let ch = raw_intern_library f in let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in let (lmd : seg_lib delayed) = in_delayed f ch in let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in @@ -489,7 +491,7 @@ let rec_intern_library libs mref = libs let native_name_from_filename f = - let ch = System.with_magic_number_check raw_intern_library f in + let ch = raw_intern_library f in let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in Nativecode.mod_uid_of_dirpath lmd.md_name @@ -654,7 +656,7 @@ let start_library f = let load_library_todo f = let longf = Loadpath.locate_file (f^".v") in let f = longf^"io" in - let ch = System.with_magic_number_check raw_intern_library f in + let ch = raw_intern_library f in let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in diff --git a/library/states.ml b/library/states.ml index 4e55f0cdc6..3cb6da12ec 100644 --- a/library/states.ml +++ b/library/states.ml @@ -21,14 +21,12 @@ let unfreeze (fl,fs) = Lib.unfreeze fl; Summary.unfreeze_summaries fs -let (extern_state,intern_state) = - let (raw_extern, raw_intern) = - extern_intern Coq_config.state_magic_number in - (fun s -> - raw_extern s (freeze ~marshallable:`Yes)), - (fun s -> - unfreeze (with_magic_number_check raw_intern s); - Library.overwrite_library_filenames s) +let extern_state s = + System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:`Yes) + +let intern_state s = + unfreeze (with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); + Library.overwrite_library_filenames s (* Rollback. *) -- cgit v1.2.3 From 99918c8a8cfb4285798a70351673be2679a6e819 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 29 Sep 2015 21:27:26 +0200 Subject: Fix dumb typo. --- library/library.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/library.ml b/library/library.ml index 6da9ccf68b..024ac9e6fa 100644 --- a/library/library.ml +++ b/library/library.ml @@ -768,7 +768,7 @@ let save_library_to ?todo dir f otab = iraise reraise let save_library_raw f sum lib univs proofs = - let f' = f^".o" in + let f' = f^"o" in let ch = raw_extern_library f' in System.marshal_out_segment f' ch (sum : seg_sum); System.marshal_out_segment f' ch (lib : seg_lib); -- cgit v1.2.3 From b248c23b84a96ef692e4a3ded6668733820e1a77 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 30 Sep 2015 06:52:01 +0200 Subject: Unexport Loadpath.get_paths. --- library/loadpath.ml | 4 +--- library/loadpath.mli | 3 --- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/library/loadpath.ml b/library/loadpath.ml index d35dca2125..622d390a2c 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -28,8 +28,6 @@ let physical p = p.path_physical let get_load_paths () = !load_paths -let get_paths () = List.map physical !load_paths - let anomaly_too_many_paths path = anomaly (str "Several logical paths are associated to" ++ spc () ++ str path) @@ -114,7 +112,7 @@ let expand_path dir = aux !load_paths let locate_file fname = - let paths = get_paths () in + let paths = List.map physical !load_paths in let _,longfname = System.find_file_in_path ~warn:(Flags.is_verbose()) paths fname in longfname diff --git a/library/loadpath.mli b/library/loadpath.mli index c2c689af70..269e28e0b5 100644 --- a/library/loadpath.mli +++ b/library/loadpath.mli @@ -27,9 +27,6 @@ val logical : t -> DirPath.t val get_load_paths : unit -> t list (** Get the current loadpath association. *) -val get_paths : unit -> CUnix.physical_path list -(** Same as [get_load_paths] but only get the physical part. *) - val add_load_path : CUnix.physical_path -> DirPath.t -> implicit:bool -> unit (** [add_load_path phys log type] adds the binding [phys := log] to the current loadpaths. *) -- cgit v1.2.3 From a478947e33bcca34291ec36487876443a694c6bf Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Mon, 14 Sep 2015 17:46:52 -0400 Subject: Add compatibility files (feature 4319) --- theories/Compat/Coq84.v | 56 ++++++++++++++++++++++++++++++++++++++++++++++ theories/Compat/Coq85.v | 9 ++++++++ theories/Compat/vo.itarget | 2 ++ theories/theories.itarget | 1 + 4 files changed, 68 insertions(+) create mode 100644 theories/Compat/Coq84.v create mode 100644 theories/Compat/Coq85.v create mode 100644 theories/Compat/vo.itarget diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v new file mode 100644 index 0000000000..83016976e8 --- /dev/null +++ b/theories/Compat/Coq84.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* \textbackslash"). You can now execute CoqIDE with the following commands (assuming +Control-\textbackslash). You can now execute CoqIDE with the following commands (assuming you use a Bourne-style shell): \begin{verbatim} @@ -268,7 +271,7 @@ $ export GTK_IM_MODULE=uim $ coqide \end{verbatim} -Activate the ELatin Input Method with Ctrl-\textbackslash, then type the +Activate the ELatin Input Method with Control-\textbackslash, then type the sequence "\verb=\Gamma=". You will see the sequence being replaced by $\Gamma$ as soon as you type the second "a". @@ -286,7 +289,7 @@ detect its character encoding.) If you choose something else than UTF-8, then missing characters will be written encoded by \verb|\x{....}| or \verb|\x{........}| where each dot is an hexadecimal digit: the number between braces is the -hexadecimal UNICODE index for the missing character. +hexadecimal Unicode index for the missing character. %%% Local Variables: -- cgit v1.2.3 From 832ef36c5b066f5cb50a85b9a1450eaf7dcb9e44 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 2 Oct 2015 14:41:29 +0200 Subject: emacs output mode: Added tag to debug messages. So that they display in response buffer. --- lib/pp.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/pp.ml b/lib/pp.ml index 30bc30a9ad..1711008ead 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -424,7 +424,7 @@ type logger = message_level -> std_ppcmds -> unit let make_body info s = emacs_quote (hov 0 (info ++ spc () ++ s)) -let debugbody strm = hov 0 (str "Debug:" ++ spc () ++ strm) +let debugbody strm = emacs_quote_info (hov 0 (str "Debug:" ++ spc () ++ strm)) let warnbody strm = make_body (str "Warning:") strm let errorbody strm = make_body (str "Error:") strm let infobody strm = emacs_quote_info strm -- cgit v1.2.3 From 88abc50ece70405d71777d5350ca2fa70c1ff437 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 2 Oct 2015 14:41:57 +0200 Subject: Changed status of Info messages from notice to info. This fixes a bug in proofgeneral. PG will now diplay this message eagerly. Otherwise since they appear before the goal, they are considered outdated and not displayed. --- proofs/pfedit.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index ceb4facc1e..05a2975458 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -108,7 +108,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let () = match info_lvl with | None -> () - | Some i -> Pp.msg_notice (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) + | Some i -> Pp.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) in (p,status) with -- cgit v1.2.3 From e759333a8b5c11247c4cc134fdde8c1bd85a6e17 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 11 Sep 2015 18:07:39 +0200 Subject: Universes: enforce Set <= i for all Type occurrences. --- Makefile.build | 2 +- kernel/indtypes.ml | 5 ++- kernel/univ.ml | 71 +++++++++++++++++++++++++++---------------- kernel/univ.mli | 10 ++++-- library/universes.ml | 41 +++++++++++++++++-------- pretyping/evd.ml | 41 ++++++++++++++++--------- pretyping/evd.mli | 6 ++-- theories/Classes/CMorphisms.v | 3 +- theories/Init/Logic.v | 2 +- toplevel/command.ml | 21 +++++++------ 10 files changed, 128 insertions(+), 74 deletions(-) diff --git a/Makefile.build b/Makefile.build index 30b93a0e83..0455a247bd 100644 --- a/Makefile.build +++ b/Makefile.build @@ -69,7 +69,7 @@ TIMED= # non-empty will activate a default time command TIMECMD= # if you prefer a specific time command instead of $(STDTIME) # e.g. "'time -p'" - +CAMLFLAGS:=${CAMLFLAGS} -w -3 # NB: if you want to collect compilation timings of .v and import them # in a spreadsheet, I suggest something like: # make TIMED=1 2> timings.csv diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 8c89abe940..9c065101a3 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -286,7 +286,10 @@ let typecheck_inductive env mie = let defu = Term.univ_of_sort def_level in let is_natural = type_in_type env || (check_leq (universes env') infu defu && - not (is_type0m_univ defu && not is_unit)) + not (is_type0m_univ defu && not is_unit) + (* (~ is_type0m_univ defu \/ is_unit) (\* infu <= defu && not prop or unital *\) *) + + ) in let _ = (** Impredicative sort, always allow *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 336cdb653e..040e9bc270 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -270,8 +270,10 @@ module Level = struct let is_small x = match data x with | Level _ -> false - | _ -> true - + | Var _ -> false + | Prop -> true + | Set -> true + let is_prop x = match data x with | Prop -> true @@ -670,7 +672,7 @@ let arc_is_lt arc = match arc.status with | Unset | SetLe -> false | SetLt -> true -let terminal u = {univ=u; lt=[]; le=[]; rank=0; predicative=false; status = Unset} +let terminal ?(predicative=false) u = {univ=u; lt=[]; le=[]; rank=0; predicative; status = Unset} module UMap : sig @@ -720,6 +722,16 @@ let enter_arc ca g = (* Every Level.t has a unique canonical arc representative *) +(** The graph always contains nodes for Prop and Set. *) + +let terminal_lt u v = + {(terminal u) with lt=[v]} + +let empty_universes = + let g = enter_arc (terminal ~predicative:true Level.set) UMap.empty in + let g = enter_arc (terminal_lt Level.prop Level.set) g in + g + (* repr : universes -> Level.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) @@ -733,6 +745,22 @@ let rec repr g u = | Equiv v -> repr g v | Canonical arc -> arc +let get_prop_arc g = repr g Level.prop +let get_set_arc g = repr g Level.set +let is_set_arc u = Level.is_set u.univ +let is_prop_arc u = Level.is_prop u.univ + +let add_universe vlev ~predicative g = + let v = terminal ~predicative vlev in + let arc = + let arc = + if predicative then get_set_arc g else get_prop_arc g + in + { arc with le=vlev::arc.le} + in + let g = enter_arc arc g in + enter_arc v g + (* [safe_repr] also search for the canonical representative, but if the graph doesn't contain the searched universe, we add it. *) @@ -745,6 +773,8 @@ let safe_repr g u = try g, safe_repr_rec g u with Not_found -> let can = terminal u in + let setarc = get_set_arc g in + let g = enter_arc {setarc with le=u::setarc.le} g in enter_arc can g, can (* reprleq : canonical_arc -> canonical_arc list *) @@ -789,7 +819,6 @@ let between g arcu arcv = in let good,_,_ = explore ([arcv],[],false) arcu in good - (* We assume compare(u,v) = LE with v canonical (see compare below). In this case List.hd(between g u v) = repr u Otherwise, between g u v = [] @@ -900,8 +929,9 @@ let get_explanation strict g arcu arcv = in find [] arc.lt in + let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in try - let (to_revert, c) = cmp [] [] [] [(arcu, [])] in + let (to_revert, c) = cmp start [] [] [(arcu, [])] in (** Reset all the touched arcs. *) let () = List.iter (fun arc -> arc.status <- Unset) to_revert in List.rev c @@ -972,7 +1002,6 @@ let fast_compare_neq strict g arcu arcv = else process_le c to_revert (arc :: lt_todo) le_todo lt le in - try let (to_revert, c) = cmp FastNLE [] [] [arcu] in (** Reset all the touched arcs. *) @@ -1021,10 +1050,6 @@ let check_equal g u v = let check_eq_level g u v = u == v || check_equal g u v -let is_set_arc u = Level.is_set u.univ -let is_prop_arc u = Level.is_prop u.univ -let get_prop_arc g = snd (safe_repr g Level.prop) - let check_smaller g strict u v = let g, arcu = safe_repr g u in let g, arcv = safe_repr g v in @@ -1120,7 +1145,7 @@ let merge g arcu arcv = (* we find the arc with the biggest rank, and we redirect all others to it *) let arcu, g, v = let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = - if Level.is_small arc.univ || arc.rank >= max_rank + if arc.rank >= max_rank && not (Level.is_small best_arc.univ) then (arc.rank, max_rank, arc, best_arc::rest) else (max_rank, old_max_rank, best_arc, arc::rest) in @@ -1150,7 +1175,7 @@ let merge g arcu arcv = (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g arc1 arc2 = - let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in + let arcu, arcv = if Level.is_small arc2.univ || arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in let arcu, g = if not (Int.equal arc1.rank arc2.rank) then arcu, g else @@ -1173,8 +1198,8 @@ exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v (p:explanation option) = raise (UniverseInconsistency (o,make u,make v,p)) -(* enforc_univ_eq : Level.t -> Level.t -> unit *) -(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) +(* enforce_univ_eq : Level.t -> Level.t -> unit *) +(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = let g,arcu = safe_repr g u in @@ -1225,18 +1250,10 @@ let enforce_univ_lt u v g = let p = get_explanation false g arcv arcu in error_inconsistency Lt u v p -let empty_universes = UMap.empty - (* Prop = Set is forbidden here. *) -let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty +let initial_universes = empty_universes let is_initial_universes g = UMap.equal (==) g initial_universes - -let add_universe vlev g = - let v = terminal vlev in - let proparc = get_prop_arc g in - enter_arc {proparc with le=vlev::proparc.le} - (enter_arc v g) (* Constraints and sets of constraints. *) @@ -1370,10 +1387,12 @@ let check_univ_leq u v = let enforce_leq u v c = let open Universe.Huniv in + let rec aux acc v = match v with - | Cons (v, _, Nil) -> - fold (fun u -> constraint_add_leq u v) u c - | _ -> anomaly (Pp.str"A universe bound can only be a variable") + | Cons (v, _, l) -> + aux (fold (fun u -> constraint_add_leq u v) u c) l + | Nil -> acc + in aux c v let enforce_leq u v c = if check_univ_leq u v then c diff --git a/kernel/univ.mli b/kernel/univ.mli index 7aaf2ffe61..76453cbb08 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -20,7 +20,11 @@ sig val is_small : t -> bool (** Is the universe set or prop? *) - + + val is_prop : t -> bool + val is_set : t -> bool + (** Is it specifically Prop or Set *) + val compare : t -> t -> int (** Comparison function *) @@ -159,8 +163,8 @@ val is_initial_universes : universes -> bool val sort_universes : universes -> universes -(** Adds a universe to the graph, ensuring it is >= Prop. *) -val add_universe : universe_level -> universes -> universes +(** Adds a universe to the graph, ensuring it is >= Prop or Set. *) +val add_universe : universe_level -> predicative:bool -> universes -> universes (** {6 Constraints. } *) diff --git a/library/universes.ml b/library/universes.ml index 1c8a5ad77d..c67371e3be 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -182,10 +182,13 @@ let leq_constr_univs_infer univs m n = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_leq univs u1 u2 then true - else - (cstrs := Constraints.add (u1, ULe, u2) !cstrs; - true) + if Univ.check_leq univs u1 u2 then + ((if Univ.is_small_univ u1 then + cstrs := Constraints.add (u1, ULe, u2) !cstrs); + true) + else + (cstrs := Constraints.add (u1, ULe, u2) !cstrs; + true) in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n @@ -820,10 +823,18 @@ let minimize_univ_variables ctx us algs left right cstrs = if v == None then fst (aux acc u) else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs) us (ctx, us, algs, lbounds, cstrs) - + let normalize_context_set ctx us algs = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in let uf = UF.create () in + (** Keep the Prop/Set <= i constraints separate for minimization *) + let smallles, csts = + Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> + if d == Le && Univ.Level.is_small l then + (Constraint.add cstr smallles, noneqs) + else (smallles, Constraint.add cstr noneqs)) + csts (Constraint.empty, Constraint.empty) + in let csts = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) @@ -831,11 +842,15 @@ let normalize_context_set ctx us algs = Univ.constraints_of_universes g in let noneqs = - Constraint.fold (fun (l,d,r) noneqs -> - if d == Eq then (UF.union l r uf; noneqs) - else Constraint.add (l,d,r) noneqs) - csts Constraint.empty + Constraint.fold (fun (l,d,r as cstr) noneqs -> + if d == Eq then (UF.union l r uf; noneqs) + else (* We ignore the trivial Prop/Set <= i constraints. *) + if d == Le && Univ.Level.is_small l then + noneqs + else Constraint.add cstr noneqs) + csts Constraint.empty in + let noneqs = Constraint.union noneqs smallles in let partition = UF.partition uf in let flex x = LMap.mem x us in let ctx, subst, eqs = List.fold_left (fun (ctx, subst, cstrs) s -> @@ -941,12 +956,12 @@ let simplify_universe_context (univs,csts) = let csts' = subst_univs_level_constraints subst csts' in (univs', csts'), subst -let is_small_leq (l,d,r) = - Level.is_small l && d == Univ.Le +let is_trivial_leq (l,d,r) = + Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) (* Prop < i <-> Set+1 <= i <-> Set < i *) let translate_cstr (l,d,r as cstr) = - if Level.equal Level.prop l && d == Univ.Lt then + if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then (Level.set, d, r) else cstr @@ -954,7 +969,7 @@ let refresh_constraints univs (ctx, cstrs) = let cstrs', univs' = Univ.Constraint.fold (fun c (cstrs', univs as acc) -> let c = translate_cstr c in - if Univ.check_constraint univs c && not (is_small_leq c) then acc + if is_trivial_leq c then acc else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs)) cstrs (Univ.Constraint.empty, univs) in ((ctx, cstrs'), univs') diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 6326112912..fe5f12dd8a 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -453,7 +453,7 @@ let add_constraints_context ctx cstrs = in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; - uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes } + uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } (* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) (* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) @@ -1058,36 +1058,49 @@ let with_context_set rigid d (a, ctx) = let add_uctx_names s l (names, names_rev) = (UNameMap.add s l names, Univ.LMap.add l s names_rev) -let uctx_new_univ_variable rigid name +let uctx_new_univ_variable rigid name predicative ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = Universes.new_univ_level (Global.current_dirpath ()) in let ctx' = Univ.ContextSet.add_universe u ctx in - let uctx' = + let uctx', pred = match rigid with - | UnivRigid -> uctx + | UnivRigid -> uctx, true | UnivFlexible b -> let uvars' = Univ.LMap.add u None uvars in if b then {uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = Univ.LSet.add u avars} - else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in + uctx_univ_algebraic = Univ.LSet.add u avars}, false + else {uctx with uctx_univ_variables = uvars'}, false + in + (* let ctx' = *) + (* if pred then *) + (* Univ.ContextSet.add_constraints *) + (* (Univ.Constraint.singleton (Univ.Level.set, Univ.Le, u)) ctx' *) + (* else ctx' *) + (* in *) let names = match name with | Some n -> add_uctx_names n u uctx.uctx_names | None -> uctx.uctx_names in + let initial = + Univ.add_universe u pred uctx.uctx_initial_universes + in + let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = Univ.add_universe u uctx.uctx_universes}, u - -let new_univ_level_variable ?name rigid evd = - let uctx', u = uctx_new_univ_variable rigid name evd.universes in + uctx_universes = Univ.add_universe u pred uctx.uctx_universes; + uctx_initial_universes = initial} + in uctx', u + +let new_univ_level_variable ?name ?(predicative=true) rigid evd = + let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in ({evd with universes = uctx'}, u) -let new_univ_variable ?name rigid evd = - let uctx', u = uctx_new_univ_variable rigid name evd.universes in +let new_univ_variable ?name ?(predicative=true) rigid evd = + let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in ({evd with universes = uctx'}, Univ.Universe.make u) -let new_sort_variable ?name rigid d = - let (d', u) = new_univ_variable rigid ?name d in +let new_sort_variable ?name ?(predicative=true) rigid d = + let (d', u) = new_univ_variable rigid ?name ~predicative d in (d', Type u) let make_flexible_variable evd b u = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 94d9d5f662..c2ccc6d21a 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -505,9 +505,9 @@ val normalize_evar_universe_context_variables : evar_universe_context -> val normalize_evar_universe_context : evar_universe_context -> evar_universe_context -val new_univ_level_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe_level -val new_univ_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe -val new_sort_variable : ?name:string -> rigid -> evar_map -> evar_map * sorts +val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level +val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map val is_sort_variable : evar_map -> sorts -> Univ.universe_level option (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 048faa9166..9d3952e64a 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -267,10 +267,9 @@ Section GenericInstances. Qed. (** The complement of a crelation conserves its proper elements. *) - Program Definition complement_proper `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement R) := _. + Proper (RA ==> RA ==> iff) (complement@{i j Prop} R) := _. Next Obligation. Proof. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 50f853f0e0..375495c888 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -370,7 +370,7 @@ Module EqNotations. End EqNotations. Import EqNotations. - +Set Printing Universes. Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. Proof. intros. diff --git a/toplevel/command.ml b/toplevel/command.ml index e2e5d8704e..d397eed610 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -467,16 +467,17 @@ let inductive_levels env evdref poly arities inds = Evd.set_leq_sort env evd (Prop Pos) du else evd in - (* let arity = it_mkProd_or_LetIn (mkType cu) ctx in *\) *) - let duu = Sorts.univ_of_sort du in - let evd = - if not (Univ.is_small_univ duu) && Evd.check_eq evd cu duu then - if is_flexible_sort evd duu then - Evd.set_eq_sort env evd (Prop Null) du - else evd - else Evd.set_eq_sort env evd (Type cu) du - in - (evd, arity :: arities)) + let duu = Sorts.univ_of_sort du in + let evd = + if not (Univ.is_small_univ duu) && Evd.check_eq evd cu duu then + if is_flexible_sort evd duu then + if Evd.check_leq evd Univ.type0_univ duu then + evd + else Evd.set_eq_sort env evd (Prop Null) du + else evd + else Evd.set_eq_sort env evd (Type cu) du + in + (evd, arity :: arities)) (!evdref,[]) (Array.to_list levels') destarities sizes in evdref := evd; List.rev arities -- cgit v1.2.3 From 79163d582abc2e22512f0924675b6b0f0928f0ef Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 15 Sep 2015 18:31:44 +0200 Subject: Univs: Fix part of bug #4161 Rechecking applications built by evarconv's imitation. --- pretyping/evarsolve.ml | 43 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 37 insertions(+), 6 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index ac1692f451..a2189d5e4f 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -107,6 +107,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in refresh_universes (Some false) env sigma ty + (************************) (* Unification results *) @@ -127,6 +128,32 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = | Some false -> add_conv_pb ~tail (Reduction.CUMUL,env,t2,t1) evd | None -> add_conv_pb ~tail (Reduction.CONV,env,t1,t2) evd +(* We retype applications to ensure the universe constraints are collected *) + +let recheck_applications conv_algo env evdref t = + let rec aux env t = + match kind_of_term t with + | App (f, args) -> + let () = aux env f in + let fty = Retyping.get_type_of env !evdref f in + let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in + let rec aux i ty = + if i < Array.length argsty then + match kind_of_term (whd_betadeltaiota env !evdref ty) with + | Prod (na, dom, codom) -> + (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with + | Success evd -> evdref := evd; + aux (succ i) (subst1 args.(i) codom) + | UnifFailure (evd, reason) -> + Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) + | _ -> assert false + else () + in aux 0 fty + | _ -> + iter_constr_with_full_binders (fun d env -> push_rel d env) aux env t + in aux env t + + (*------------------------------------* * Restricting existing evars * *------------------------------------*) @@ -1404,10 +1431,10 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = evdref := restrict_evar evd (fst ev'') None (UpdateWith candidates); evar'') | None -> - (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) - imitate envk t in - + (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) + map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) + imitate envk t + in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in @@ -1426,8 +1453,12 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = in let body = if fast rhs then nf_evar evd rhs - else imitate (env,0) rhs - in (!evdref,body) + else + let t' = imitate (env,0) rhs in + if !progress then + (recheck_applications conv_algo (evar_env evi) evdref t'; t') + else t' + in (!evdref,body) (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said, -- cgit v1.2.3 From 1cd87577ab85a402fb0482678dfcdbe85b45ce38 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 15 Sep 2015 18:33:04 +0200 Subject: Univs: force all universes to be >= Set. --- pretyping/evd.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index fe5f12dd8a..9f2d284387 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -385,7 +385,7 @@ let process_universe_constraints univs vars alg cstrs = let levels = Univ.Universe.levels l in Univ.LSet.fold (fun l local -> if Univ.Level.is_small l || Univ.LMap.mem l !vars then - Univ.enforce_eq (Univ.Universe.make l) r local + unify_universes fo (Univ.Universe.make l) Universes.UEq r local else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None))) levels local else @@ -1083,11 +1083,11 @@ let uctx_new_univ_variable rigid name predicative | None -> uctx.uctx_names in let initial = - Univ.add_universe u pred uctx.uctx_initial_universes + Univ.add_universe u true uctx.uctx_initial_universes in let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = Univ.add_universe u pred uctx.uctx_universes; + uctx_universes = Univ.add_universe u true uctx.uctx_universes; uctx_initial_universes = initial} in uctx', u -- cgit v1.2.3 From 4838a3a3c25cc9f7583dd62e4585460aca8ee961 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 21 Sep 2015 11:55:32 +0200 Subject: Forcing i > Set for global universes (incomplete) --- kernel/environ.ml | 39 +++++++++++++++++++++++++++------------ kernel/environ.mli | 4 ++-- kernel/term_typing.ml | 8 ++++---- kernel/univ.ml | 26 ++++++++++++++------------ kernel/univ.mli | 4 ++-- library/universes.ml | 9 +++++++-- pretyping/evd.ml | 4 ++-- test-suite/bugs/closed/3309.v | 6 +++--- 8 files changed, 61 insertions(+), 39 deletions(-) diff --git a/kernel/environ.ml b/kernel/environ.ml index 109e3830c2..c433c07898 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -181,26 +181,41 @@ let fold_named_context_reverse f ~init env = (* Universe constraints *) -let add_constraints c env = - if Univ.Constraint.is_empty c then - env - else - let s = env.env_stratification in +let map_universes f env = + let s = env.env_stratification in { env with env_stratification = - { s with env_universes = Univ.merge_constraints c s.env_universes } } + { s with env_universes = f s.env_universes } } + +let add_constraints c env = + if Univ.Constraint.is_empty c then env + else map_universes (Univ.merge_constraints c) env let check_constraints c env = Univ.check_constraints c env.env_stratification.env_universes -let set_engagement c env = (* Unsafe *) - { env with env_stratification = - { env.env_stratification with env_engagement = c } } - let push_constraints_to_env (_,univs) env = add_constraints univs env -let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env -let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env +let add_universes strict ctx g = + let g = Array.fold_left (fun g v -> Univ.add_universe v strict g) + g (Univ.Instance.to_array (Univ.UContext.instance ctx)) + in + Univ.merge_constraints (Univ.UContext.constraints ctx) g + +let push_context ?(strict=false) ctx env = + map_universes (add_universes strict ctx) env + +let add_universes_set strict ctx g = + let g = Univ.LSet.fold (fun v g -> Univ.add_universe v strict g) + (Univ.ContextSet.levels ctx) g + in Univ.merge_constraints (Univ.ContextSet.constraints ctx) g + +let push_context_set ?(strict=false) ctx env = + map_universes (add_universes_set strict ctx) env + +let set_engagement c env = (* Unsafe *) + { env with env_stratification = + { env.env_stratification with env_engagement = c } } (* Global constants *) diff --git a/kernel/environ.mli b/kernel/environ.mli index 4ad0327fc7..9f6ea522a7 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -208,8 +208,8 @@ val add_constraints : Univ.constraints -> env -> env (** Check constraints are satifiable in the environment. *) val check_constraints : Univ.constraints -> env -> bool -val push_context : Univ.universe_context -> env -> env -val push_context_set : Univ.universe_context_set -> env -> env +val push_context : ?strict:bool -> Univ.universe_context -> env -> env +val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env val set_engagement : engagement -> env -> env diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 83e566041f..e89b6ef8f7 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -100,11 +100,11 @@ let hcons_j j = let feedback_completion_typecheck = Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete) - + let infer_declaration env kn dcl = match dcl with | ParameterEntry (ctx,poly,(t,uctx),nl) -> - let env = push_context uctx env in + let env = push_context ~strict:(not poly) uctx env in let j = infer env t in let abstract = poly && not (Option.is_empty kn) in let usubst, univs = Univ.abstract_universes abstract uctx in @@ -115,7 +115,7 @@ let infer_declaration env kn dcl = | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; const_entry_polymorphic = false} as c) -> - let env = push_context c.const_entry_universes env in + let env = push_context ~strict:true c.const_entry_universes env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = @@ -135,7 +135,7 @@ let infer_declaration env kn dcl = c.const_entry_inline_code, c.const_entry_secctx | DefinitionEntry c -> - let env = push_context c.const_entry_universes env in + let env = push_context ~strict:(not c.const_entry_polymorphic) c.const_entry_universes env in let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in diff --git a/kernel/univ.ml b/kernel/univ.ml index 040e9bc270..b61b441d2e 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -750,17 +750,6 @@ let get_set_arc g = repr g Level.set let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ -let add_universe vlev ~predicative g = - let v = terminal ~predicative vlev in - let arc = - let arc = - if predicative then get_set_arc g else get_prop_arc g - in - { arc with le=vlev::arc.le} - in - let g = enter_arc arc g in - enter_arc v g - (* [safe_repr] also search for the canonical representative, but if the graph doesn't contain the searched universe, we add it. *) @@ -777,6 +766,18 @@ let safe_repr g u = let g = enter_arc {setarc with le=u::setarc.le} g in enter_arc can g, can +let add_universe vlev strict g = + let v = terminal ~predicative:true vlev in + let arc = + let arc = get_set_arc g in + if strict then + { arc with lt=vlev::arc.lt} + else + { arc with le=vlev::arc.le} + in + let g = enter_arc arc g in + enter_arc v g + (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) let reprleq g arcu = @@ -1145,7 +1146,8 @@ let merge g arcu arcv = (* we find the arc with the biggest rank, and we redirect all others to it *) let arcu, g, v = let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = - if arc.rank >= max_rank && not (Level.is_small best_arc.univ) + if Level.is_small arc.univ || + (arc.rank >= max_rank && not (Level.is_small best_arc.univ)) then (arc.rank, max_rank, arc, best_arc::rest) else (max_rank, old_max_rank, best_arc, arc::rest) in diff --git a/kernel/univ.mli b/kernel/univ.mli index 76453cbb08..fe7fc1ab9f 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -163,8 +163,8 @@ val is_initial_universes : universes -> bool val sort_universes : universes -> universes -(** Adds a universe to the graph, ensuring it is >= Prop or Set. *) -val add_universe : universe_level -> predicative:bool -> universes -> universes +(** Adds a universe to the graph, ensuring it is >= or > Set. *) +val add_universe : universe_level -> bool -> universes -> universes (** {6 Constraints. } *) diff --git a/library/universes.ml b/library/universes.ml index c67371e3be..0544585dce 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -830,8 +830,13 @@ let normalize_context_set ctx us algs = (** Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> - if d == Le && Univ.Level.is_small l then - (Constraint.add cstr smallles, noneqs) + if d == Le then + if Univ.Level.is_small l then + (Constraint.add cstr smallles, noneqs) + else if Level.is_small r then + raise (Univ.UniverseInconsistency + (Le,Universe.make l,Universe.make r,None)) + else (smallles, Constraint.add cstr noneqs) else (smallles, Constraint.add cstr noneqs)) csts (Constraint.empty, Constraint.empty) in diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 9f2d284387..a25479d483 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1083,11 +1083,11 @@ let uctx_new_univ_variable rigid name predicative | None -> uctx.uctx_names in let initial = - Univ.add_universe u true uctx.uctx_initial_universes + Univ.add_universe u false uctx.uctx_initial_universes in let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = Univ.add_universe u true uctx.uctx_universes; + uctx_universes = Univ.add_universe u false uctx.uctx_universes; uctx_initial_universes = initial} in uctx', u diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v index 980431576c..6e97ed2afe 100644 --- a/test-suite/bugs/closed/3309.v +++ b/test-suite/bugs/closed/3309.v @@ -117,7 +117,7 @@ intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact a Defined. Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) . -intros X R A; exact ( fun is : iseqclass R A => projT1' _ is ). +intros X R A. exact (fun is : iseqclass R A => projT1' _ is ). Defined. Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . @@ -141,7 +141,7 @@ Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. admit. Defined. -Definition setquot { X : UU } ( R : hrel X ) : Type. +Definition setquot { X : UU } ( R : hrel X ) : Set. intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ). Defined. Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R. @@ -157,7 +157,7 @@ Definition setquotinset { X : UU } ( R : hrel X ) : hSet. intros; exact ( hSetpair (setquot R) admit) . Defined. -Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). +Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot@{i j k l m n p Set q r} RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _ ( projT2' _ cd ) ) ) ). Defined. -- cgit v1.2.3 From 0d923ee82bfed8d33d677dafb4b8defa18e4fdd1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 22 Sep 2015 20:14:59 +0200 Subject: Univs: More info for developers. --- dev/doc/univpoly.txt | 48 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 36 insertions(+), 12 deletions(-) diff --git a/dev/doc/univpoly.txt b/dev/doc/univpoly.txt index 4c89af01db..bad2ae36eb 100644 --- a/dev/doc/univpoly.txt +++ b/dev/doc/univpoly.txt @@ -1,5 +1,5 @@ -Notes on universe polymorphism and primitive projections, M. Sozeau - WIP -========================================================================= +Notes on universe polymorphism and primitive projections, M. Sozeau +=================================================================== The new implementation of universe polymorphism and primitive projections introduces a few changes to the API of Coq. First and @@ -46,15 +46,16 @@ universes and constraints to the global universe context when it is put in the environment. No other universes than the global ones and the declared local ones are needed to check a declaration, hence the kernel does not produce any constraints anymore, apart from module -subtyping.... There are hance two conversion functions now: check_conv -and infer_conv: the former just checks the definition in the current env +subtyping.... There are hence two conversion functions now: [check_conv] +and [infer_conv]: the former just checks the definition in the current env (in which we usually push_universe_context of the associated context), -and infer_conv which produces constraints that were not implied by the +and [infer_conv] which produces constraints that were not implied by the ambient constraints. Ideally, that one could be put out of the kernel, -but again, module subtyping needs it. +but currently module subtyping needs it. Inference of universes is now done during refinement, and the evar_map -carries the incrementally built universe context. [Evd.conversion] is a +carries the incrementally built universe context, starting from the +global universe constraints (see [Evd.from_env]). [Evd.conversion] is a wrapper around [infer_conv] that will do the bookkeeping for you, it uses [evar_conv_x]. There is a universe substitution being built incrementally according to the constraints, so one should normalize at @@ -72,7 +73,7 @@ val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> ta Is the way to make a constr out of a global reference in the new API. If they constr is polymorphic, it will add the necessary constraints to the evar_map. Even if a constr is not polymorphic, we have to take care -of keeping track of it's universes. Typically, using: +of keeping track of its universes. Typically, using: mkApp (coq_id_function, [| A; a |]) @@ -84,8 +85,8 @@ produce the right constraints and put them in the evar_map. Of course in some cases you might now from an invariant that no new constraint would be produced and get rid of it. Anyway the kernel will tell you if you forgot some. As a temporary way out, [Universes.constr_of_global] allows -you to make a constr from any non-polymorphic constant, but it might -forget constraints. +you to make a constr from any non-polymorphic constant, but it will fail +on polymorphic ones. Other than that, unification (w_unify and evarconv) now take account of universes and produce only well-typed evar_maps. @@ -157,6 +158,30 @@ this is the only solution I found. In the case of global_references only, it's just a matter of using [Evd.fresh_global] / [pf_constr_of_global] to let the system take care of universes. + +The universe graph +================== + +To accomodate universe polymorphic definitions, the graph structure in +kernel/univ.ml was modified. The new API forces every universe to be +declared before it is mentionned in any constraint. This forces to +declare every universe to be >= Set or > Set. Every universe variable +introduced during elaboration is >= Set. Every _global_ universe is now +declared explicitely > Set, _after_ typechecking the definition. In +polymorphic definitions Type@{i} ranges over Set and any other universe +j. However, at instantiation time for polymorphic references, one can +try to instantiate a universe parameter with Prop as well, if the +instantiated constraints allow it. The graph invariants ensure that +no universe i can be set lower than Set, so the chain of universes +always bottoms down at Prop < Set. + +Modules +======= + +One has to think of universes in modules as being globally declared, so +when including a module (type) which declares a type i (e.g. through a +parameter), we get back a copy of i and not some fresh universe. + Projections =========== @@ -208,8 +233,7 @@ constants left (the most common case). E.g. Ring with Set Universe Polymorphism and Set Primitive Projections work (at least it did at some point, I didn't recheck yet). -- [native_compute] is untested: it should deal with primitive -projections right but not universes. +- [native_compute] works with universes and projections. Incompatibilities -- cgit v1.2.3 From ff4d0d98ab0e0e81bd1acf9a7bf4b64913834911 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 14:10:03 +0200 Subject: Remove Print Universe directive. --- theories/Init/Logic.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 375495c888..50f853f0e0 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -370,7 +370,7 @@ Module EqNotations. End EqNotations. Import EqNotations. -Set Printing Universes. + Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. Proof. intros. -- cgit v1.2.3 From cc69a4697633e14fc00c9bd0858b38120645464b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:00:49 +0200 Subject: Univs: module constraints move to universe contexts as they might declare new universes (e.g. with). --- kernel/declarations.mli | 4 ++-- kernel/environ.ml | 11 ++++++---- kernel/mod_typing.ml | 35 +++++++++++++++---------------- kernel/mod_typing.mli | 2 +- kernel/safe_typing.ml | 55 ++++++++++++++++++++++++++----------------------- 5 files changed, 56 insertions(+), 51 deletions(-) diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 561c66b422..7def963e73 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -246,8 +246,8 @@ and module_body = mod_type : module_signature; (** expanded type *) (** algebraic type, kept if it's relevant for extraction *) mod_type_alg : module_expression option; - (** set of all constraints in the module *) - mod_constraints : Univ.constraints; + (** set of all universes constraints in the module *) + mod_constraints : Univ.ContextSet.t; (** quotiented set of equivalent constants and inductive names *) mod_delta : Mod_subst.delta_resolver; mod_retroknowledge : Retroknowledge.action list } diff --git a/kernel/environ.ml b/kernel/environ.ml index c433c07898..429aba4f75 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -197,8 +197,10 @@ let push_constraints_to_env (_,univs) env = add_constraints univs env let add_universes strict ctx g = - let g = Array.fold_left (fun g v -> Univ.add_universe v strict g) - g (Univ.Instance.to_array (Univ.UContext.instance ctx)) + let g = Array.fold_left + (* Be lenient, module typing reintroduces universes and constraints due to includes *) + (fun g v -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + g (Univ.Instance.to_array (Univ.UContext.instance ctx)) in Univ.merge_constraints (Univ.UContext.constraints ctx) g @@ -206,8 +208,9 @@ let push_context ?(strict=false) ctx env = map_universes (add_universes strict ctx) env let add_universes_set strict ctx g = - let g = Univ.LSet.fold (fun v g -> Univ.add_universe v strict g) - (Univ.ContextSet.levels ctx) g + let g = Univ.LSet.fold + (fun v g -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + (Univ.ContextSet.levels ctx) g in Univ.merge_constraints (Univ.ContextSet.constraints ctx) g let push_context_set ?(strict=false) ctx env = diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 4f20e5f62a..7da0958eaf 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -21,7 +21,7 @@ open Modops open Mod_subst type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.constraints + module_signature * 'alg option * delta_resolver * Univ.ContextSet.t let rec mp_from_mexpr = function | MEident mp -> mp @@ -52,7 +52,7 @@ let rec rebuild_mp mp l = | []-> mp | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r -let (+++) = Univ.Constraint.union +let (+++) = Univ.ContextSet.union let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let lab,idl = match idl with @@ -75,30 +75,30 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let ccst = Declareops.constraints_of_constant (opaque_tables env) cb in let env' = Environ.add_constraints ccst env' in let newus, cst = Univ.UContext.dest ctx in + let ctxs = Univ.ContextSet.of_context ctx in let env' = Environ.add_constraints cst env' in - let c',cst = match cb.const_body with + let c',ctx' = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in - j.uj_val,cst' +++ cst + j.uj_val, Univ.ContextSet.add_constraints cst' ctxs | Def cs -> let cst' = Reduction.infer_conv env' (Environ.universes env') c (Mod_subst.force_constr cs) in let cst = (*FIXME MS: what to check here? subtyping of polymorphic constants... *) - if cb.const_polymorphic then cst' +++ cst - else cst' +++ cst + (* if cb.const_polymorphic then *)Univ.ContextSet.add_constraints cst' ctxs + (* else cst' +++ cst *) in c, cst in let def = Def (Mod_subst.from_val c') in - let ctx' = Univ.UContext.make (newus, cst) in let cb' = { cb with const_body = def; const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' def); - const_universes = ctx' } + const_universes = Univ.ContextSet.to_context ctx' } in before@(lab,SFBconst(cb'))::after, c', ctx' else @@ -145,8 +145,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = begin try let mtb_old = module_type_of_module old in - Subtyping.check_subtypes env' mtb_mp1 mtb_old - +++ old.mod_constraints + Univ.ContextSet.add_constraints (Subtyping.check_subtypes env' mtb_mp1 mtb_old) old.mod_constraints with Failure _ -> error_incorrect_with_constraint lab end | Algebraic (NoFunctor (MEident(mp'))) -> @@ -194,7 +193,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Algebraic (NoFunctor (MEident mp0)) -> let mpnew = rebuild_mp mp0 idl in check_modpath_equiv env' mpnew mp; - before@(lab,spec)::after, equiv, Univ.Constraint.empty + before@(lab,spec)::after, equiv, Univ.ContextSet.empty | _ -> error_generative_module_expected lab end with @@ -207,8 +206,8 @@ let check_with env mp (sign,alg,reso,cst) = function |WithDef(idl,c) -> let struc = destr_nofunctor sign in let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let alg' = mk_alg_with alg (WithDef (idl,(c',cst'))) in - (NoFunctor struc'),alg',reso, cst+++(Univ.UContext.constraints cst') + let alg' = mk_alg_with alg (WithDef (idl,(c',Univ.ContextSet.to_context cst'))) in + (NoFunctor struc'),alg',reso, cst+++cst' |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in @@ -238,7 +237,7 @@ let rec translate_mse env mpo inl = function let mtb = lookup_modtype mp1 env in mtb.mod_type, mtb.mod_delta in - sign,Some (MEident mp1),reso,Univ.Constraint.empty + sign,Some (MEident mp1),reso,Univ.ContextSet.empty |MEapply (fe,mp1) -> translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) |MEwith(me, with_decl) -> @@ -256,7 +255,7 @@ and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = let body = subst_signature subst fbody_b in let alg' = mkalg alg mp1 in let reso' = subst_codom_delta_resolver subst reso in - body,alg',reso', cst1 +++ cst2 + body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 let mk_alg_funct mpo mbid mtb alg = match mpo, alg with | Some _, Some alg -> Some (MoreFunctor (mbid,mtb,alg)) @@ -301,7 +300,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with mk_mod mp impl sign None cst reso |Some (params_mte,inl) -> let res_mtb = translate_modtype env mp inl params_mte in - let auto_mtb = mk_modtype mp sign Univ.Constraint.empty reso in + let auto_mtb = mk_modtype mp sign Univ.ContextSet.empty reso in let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in let impl = match alg with Some e -> Algebraic e | None -> Struct sign in { res_mtb with @@ -309,7 +308,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with mod_expr = impl; (** cst from module body typing, cst' from subtyping, and constraints from module type. *) - mod_constraints = cst +++ cst' +++ res_mtb.mod_constraints } + mod_constraints = Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } let translate_module env mp inl = function |MType (params,ty) -> @@ -324,7 +323,7 @@ let rec translate_mse_incl env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.Constraint.empty + sign,None,mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> let ftrans = translate_mse_incl env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> None) diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index b39e821254..80db12b0d3 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -30,7 +30,7 @@ val translate_modtype : *) type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.constraints + module_signature * 'alg option * delta_resolver * Univ.ContextSet.t val translate_mse : env -> module_path option -> inline -> module_struct_entry -> diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 55e767321b..9417aa0801 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -118,8 +118,8 @@ type safe_environment = revstruct : structure_body; modlabels : Label.Set.t; objlabels : Label.Set.t; - univ : Univ.constraints; - future_cst : Univ.constraints Future.computation list; + univ : Univ.ContextSet.t; + future_cst : Univ.ContextSet.t Future.computation list; engagement : engagement option; required : vodigest DPMap.t; loads : (module_path * module_body) list; @@ -148,7 +148,7 @@ let empty_environment = modlabels = Label.Set.empty; objlabels = Label.Set.empty; future_cst = []; - univ = Univ.Constraint.empty; + univ = Univ.ContextSet.empty; engagement = None; required = DPMap.empty; loads = []; @@ -221,7 +221,7 @@ let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env type constraints_addition = - Now of Univ.constraints | Later of Univ.constraints Future.computation + Now of Univ.ContextSet.t | Later of Univ.ContextSet.t Future.computation let add_constraints cst senv = match cst with @@ -229,14 +229,14 @@ let add_constraints cst senv = {senv with future_cst = fc :: senv.future_cst} | Now cst -> { senv with - env = Environ.add_constraints cst senv.env; - univ = Univ.Constraint.union cst senv.univ } + env = Environ.push_context_set ~strict:true cst senv.env; + univ = Univ.ContextSet.union cst senv.univ } let add_constraints_list cst senv = List.fold_right add_constraints cst senv -let push_context_set ctx = add_constraints (Now (Univ.ContextSet.constraints ctx)) -let push_context ctx = add_constraints (Now (Univ.UContext.constraints ctx)) +let push_context_set ctx = add_constraints (Now ctx) +let push_context ctx = add_constraints (Now (Univ.ContextSet.of_context ctx)) let is_curmod_library senv = match senv.modvariant with LIBRARY -> true | _ -> false @@ -373,9 +373,9 @@ let labels_of_mib mib = let globalize_constant_universes env cb = if cb.const_polymorphic then - [Now Univ.Constraint.empty] + [Now Univ.ContextSet.empty] else - let cstrs = Univ.UContext.constraints cb.const_universes in + let cstrs = Univ.ContextSet.of_context cb.const_universes in Now cstrs :: (match cb.const_body with | (Undef _ | Def _) -> [] @@ -384,16 +384,14 @@ let globalize_constant_universes env cb = | None -> [] | Some fc -> match Future.peek_val fc with - | None -> [Later (Future.chain - ~greedy:(not (Future.is_exn fc)) - ~pure:true fc Univ.ContextSet.constraints)] - | Some c -> [Now (Univ.ContextSet.constraints c)]) + | None -> [Later fc] + | Some c -> [Now c]) let globalize_mind_universes mb = if mb.mind_polymorphic then - [Now Univ.Constraint.empty] + [Now Univ.ContextSet.empty] else - [Now (Univ.UContext.constraints mb.mind_universes)] + [Now (Univ.ContextSet.of_context mb.mind_universes)] let constraints_of_sfb env sfb = match sfb with @@ -617,8 +615,8 @@ let propagate_senv newdef newenv newresolver senv oldsenv = modlabels = Label.Set.add (fst newdef) oldsenv.modlabels; univ = List.fold_left (fun acc cst -> - Univ.Constraint.union acc (Future.force cst)) - (Univ.Constraint.union senv.univ oldsenv.univ) + Univ.ContextSet.union acc (Future.force cst)) + (Univ.ContextSet.union senv.univ oldsenv.univ) now_cst; future_cst = later_cst @ oldsenv.future_cst; (* engagement is propagated to the upper level *) @@ -641,8 +639,8 @@ let end_module l restype senv = let senv'= propagate_loads { senv with env = newenv; - univ = Univ.Constraint.union senv.univ mb.mod_constraints} in - let newenv = Environ.add_constraints mb.mod_constraints senv'.env in + univ = Univ.ContextSet.union senv.univ mb.mod_constraints} in + let newenv = Environ.push_context_set ~strict:true mb.mod_constraints senv'.env in let newenv = Modops.add_module mb newenv in let newresolver = if Modops.is_functor mb.mod_type then oldsenv.modresolver @@ -667,7 +665,7 @@ let end_modtype l senv = let () = check_empty_context senv in let mbids = List.rev_map fst params in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in - let newenv = Environ.add_constraints senv.univ newenv in + let newenv = Environ.push_context_set ~strict:true senv.univ newenv in let newenv = set_engagement_opt newenv senv.engagement in let senv' = propagate_loads {senv with env=newenv} in let auto_tb = functorize params (NoFunctor (List.rev senv.revstruct)) in @@ -696,7 +694,8 @@ let add_include me is_module inl senv = match sign with | MoreFunctor(mbid,mtb,str) -> let cst_sub = Subtyping.check_subtypes senv.env mb mtb in - let senv = add_constraints (Now cst_sub) senv in + let senv = add_constraints + (Now (Univ.ContextSet.add_constraints cst_sub Univ.ContextSet.empty)) senv in let mpsup_delta = Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta in @@ -707,7 +706,7 @@ let add_include me is_module inl senv = in let resolver,sign,senv = let struc = NoFunctor (List.rev senv.revstruct) in - let mtb = build_mtb mp_sup struc Univ.Constraint.empty senv.modresolver in + let mtb = build_mtb mp_sup struc Univ.ContextSet.empty senv.modresolver in compute_sign sign mtb resolver senv in let str = match sign with @@ -801,8 +800,10 @@ let import lib cst vodigest senv = check_engagement senv.env lib.comp_enga; let mp = MPfile lib.comp_name in let mb = lib.comp_mod in - let env = Environ.add_constraints mb.mod_constraints senv.env in - let env = Environ.push_context_set cst env in + let env = Environ.push_context_set ~strict:true + (Univ.ContextSet.union mb.mod_constraints cst) + senv.env + in mp, { senv with env = @@ -855,7 +856,9 @@ let register_inline kn senv = let env = { env with env_globals = new_globals } in { senv with env = env_of_pre_env env } -let add_constraints c = add_constraints (Now c) +let add_constraints c = + add_constraints + (Now (Univ.ContextSet.add_constraints c Univ.ContextSet.empty)) (* NB: The next old comment probably refers to [propagate_loads] above. -- cgit v1.2.3 From e841deb4750d43ab19f91907476d75fc73860c5a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:09:14 +0200 Subject: Univs (kernel) adapt to new invariants Remove predicative flag and adapt to new invariant where every universe must be declared, ensuring it is >= Set, safe_repr is not necessary anymore. --- kernel/univ.ml | 84 +++++++++++++++++++-------------------------------------- kernel/univ.mli | 6 ++++- 2 files changed, 32 insertions(+), 58 deletions(-) diff --git a/kernel/univ.ml b/kernel/univ.ml index b61b441d2e..782778d09f 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -657,7 +657,6 @@ type canonical_arc = lt: Level.t list; le: Level.t list; rank : int; - predicative : bool; mutable status : status; (** Guaranteed to be unset out of the [compare_neq] functions. It is used to do an imperative traversal of the graph, ensuring a O(1) check that @@ -672,7 +671,7 @@ let arc_is_lt arc = match arc.status with | Unset | SetLe -> false | SetLt -> true -let terminal ?(predicative=false) u = {univ=u; lt=[]; le=[]; rank=0; predicative; status = Unset} +let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset} module UMap : sig @@ -728,7 +727,7 @@ let terminal_lt u v = {(terminal u) with lt=[v]} let empty_universes = - let g = enter_arc (terminal ~predicative:true Level.set) UMap.empty in + let g = enter_arc (terminal Level.set) UMap.empty in let g = enter_arc (terminal_lt Level.prop Level.set) g in g @@ -750,33 +749,23 @@ let get_set_arc g = repr g Level.set let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ -(* [safe_repr] also search for the canonical representative, but - if the graph doesn't contain the searched universe, we add it. *) - -let safe_repr g u = - let rec safe_repr_rec g u = - match UMap.find u g with - | Equiv v -> safe_repr_rec g v - | Canonical arc -> arc - in - try g, safe_repr_rec g u - with Not_found -> - let can = terminal u in - let setarc = get_set_arc g in - let g = enter_arc {setarc with le=u::setarc.le} g in - enter_arc can g, can - -let add_universe vlev strict g = - let v = terminal ~predicative:true vlev in - let arc = - let arc = get_set_arc g in - if strict then - { arc with lt=vlev::arc.lt} - else - { arc with le=vlev::arc.le} - in - let g = enter_arc arc g in - enter_arc v g +exception AlreadyDeclared + +let add_universe vlev strict g = + try + let _arcv = UMap.find vlev g in + raise AlreadyDeclared + with Not_found -> + let v = terminal vlev in + let arc = + let arc = get_set_arc g in + if strict then + { arc with lt=vlev::arc.lt} + else + { arc with le=vlev::arc.le} + in + let g = enter_arc arc g in + enter_arc v g (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) @@ -1045,20 +1034,18 @@ let is_lt g arcu arcv = (** First, checks on universe levels *) let check_equal g u v = - let g, arcu = safe_repr g u in - let _, arcv = safe_repr g v in - arcu == arcv + let arcu = repr g u and arcv = repr g v in + arcu == arcv let check_eq_level g u v = u == v || check_equal g u v let check_smaller g strict u v = - let g, arcu = safe_repr g u in - let g, arcv = safe_repr g v in + let arcu = repr g u and arcv = repr g v in if strict then is_lt g arcu arcv else is_prop_arc arcu - || (is_set_arc arcu && arcv.predicative) + || (is_set_arc arcu && not (is_prop_arc arcv)) || is_leq g arcu arcv (** Then, checks on universes *) @@ -1100,19 +1087,11 @@ let check_leq g u v = (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) -(** To speed up tests of Set Level.t -> reason -> unit *) (* forces u > v *) (* this is normally an update of u in g rather than a creation. *) let setlt g arcu arcv = let arcu' = {arcu with lt=arcv.univ::arcu.lt} in - let g = - if is_set_arc arcu then set_predicative g arcv - else g - in enter_arc arcu' g, arcu' (* checks that non-redundant *) @@ -1126,11 +1105,6 @@ let setlt_if (g,arcu) v = (* this is normally an update of u in g rather than a creation. *) let setleq g arcu arcv = let arcu' = {arcu with le=arcv.univ::arcu.le} in - let g = - if is_set_arc arcu' then - set_predicative g arcv - else g - in enter_arc arcu' g, arcu' (* checks that non-redundant *) @@ -1204,8 +1178,7 @@ let error_inconsistency o u v (p:explanation option) = (* enforce_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u and arcv = repr g v in match fast_compare g arcu arcv with | FastEQ -> g | FastLT -> @@ -1224,8 +1197,7 @@ let enforce_univ_eq u v g = (* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u and arcv = repr g v in if is_leq g arcu arcv then g else match fast_compare g arcv arcu with @@ -1238,8 +1210,7 @@ let enforce_univ_leq u v g = (* enforce_univ_lt u v will force u g | FastLE -> fst (setlt g arcu arcv) @@ -1465,7 +1436,6 @@ let normalize_universes g = lt = LSet.elements lt; le = LSet.elements le; rank = rank; - predicative = false; status = Unset; } in @@ -1610,7 +1580,7 @@ let sort_universes orig = let fold i accu u = if 0 < i then let pred = types.(i - 1) in - let arc = {univ = u; lt = [pred]; le = []; rank = 0; predicative = false; status = Unset; } in + let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in UMap.add u (Canonical arc) accu else accu in diff --git a/kernel/univ.mli b/kernel/univ.mli index fe7fc1ab9f..ad33d597ea 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -163,7 +163,11 @@ val is_initial_universes : universes -> bool val sort_universes : universes -> universes -(** Adds a universe to the graph, ensuring it is >= or > Set. *) +(** Adds a universe to the graph, ensuring it is >= or > Set. + @raises AlreadyDeclared if the level is already declared in the graph. *) + +exception AlreadyDeclared + val add_universe : universe_level -> bool -> universes -> universes (** {6 Constraints. } *) -- cgit v1.2.3 From 26628315688e07c43b9881872a737454e93fe4c9 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:11:56 +0200 Subject: Univs: minimization, adapt to graph invariants. We are forced to declare universes that are global and appear in the local constraints as we start from an empty universe graph. --- library/universes.ml | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/library/universes.ml b/library/universes.ml index 0544585dce..0133f5deb6 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -843,7 +843,25 @@ let normalize_context_set ctx us algs = let csts = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) - let g = Univ.merge_constraints csts Univ.empty_universes in + let g = Univ.LSet.fold (fun v g -> Univ.add_universe v false g) + ctx Univ.empty_universes + in + let g = + Univ.Constraint.fold (fun (l, d, r) g -> + let g = + if not (Level.is_small l || LSet.mem l ctx) then + try Univ.add_universe l true g + with Univ.AlreadyDeclared -> g + else g + in + let g = + if not (Level.is_small r || LSet.mem r ctx) then + try Univ.add_universe r true g + with Univ.AlreadyDeclared -> g + else g + in g) csts g + in + let g = Univ.Constraint.fold Univ.enforce_constraint csts g in Univ.constraints_of_universes g in let noneqs = @@ -852,6 +870,8 @@ let normalize_context_set ctx us algs = else (* We ignore the trivial Prop/Set <= i constraints. *) if d == Le && Univ.Level.is_small l then noneqs + else if Level.is_small l && d == Lt && not (LSet.mem r ctx) then + noneqs else Constraint.add cstr noneqs) csts Constraint.empty in -- cgit v1.2.3 From 72c6588923dca52be7bc7d750d969ff1baa76c45 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:14:28 +0200 Subject: Univs: fix an evar leak in congruence --- plugins/cc/ccalgo.ml | 16 ++++++++-------- plugins/cc/ccalgo.mli | 2 +- plugins/cc/cctac.ml | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index d5d6bdf749..97ea5fdc59 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -129,14 +129,14 @@ type cinfo= ci_nhyps: int} (* # projectable args *) let family_eq f1 f2 = match f1, f2 with -| InProp, InProp -| InSet, InSet -| InType, InType -> true -| _ -> false + | Prop Pos, Prop Pos + | Prop Null, Prop Null + | Type _, Type _ -> true + | _ -> false type term= Symb of constr - | Product of sorts_family * sorts_family + | Product of sorts * sorts | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) @@ -161,7 +161,7 @@ let hash_sorts_family = function let rec hash_term = function | Symb c -> combine 1 (hash_constr c) - | Product (s1, s2) -> combine3 2 (hash_sorts_family s1) (hash_sorts_family s2) + | Product (s1, s2) -> combine3 2 (Sorts.hash s1) (Sorts.hash s2) | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j @@ -425,8 +425,8 @@ let _B_ = Name (Id.of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) let cc_product s1 s2 = - mkLambda(_A_,mkSort(Universes.new_sort_in_family s1), - mkLambda(_B_,mkSort(Universes.new_sort_in_family s2),_body_)) + mkLambda(_A_,mkSort(s1), + mkLambda(_B_,mkSort(s2),_body_)) let rec constr_of_term = function Symb s-> applist_projection s [] diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index c72843d55f..0dcf3a870f 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -30,7 +30,7 @@ type cinfo = type term = Symb of constr - | Product of sorts_family * sorts_family + | Product of sorts * sorts | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 9c3a0f7299..6439f58d24 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -46,7 +46,7 @@ let whd_delta env= (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = family_of_sort (sort_of env (ref sigma) c) +let sf_of env sigma c = sort_of env (ref sigma) c let rec decompose_term env sigma t= match kind_of_term (whd env t) with -- cgit v1.2.3 From 836b9faa8797a2802c189e782469f8d2e467d894 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:15:05 +0200 Subject: Univs: fix evar_map leaks bugs in Function The evar_map's that are used to typecheck terms must now always be initialized with the global universe graphs using Evd.from_env, so any failure to initialize and thread evar_map's correctly results in errors. --- plugins/funind/functional_principles_types.ml | 20 +++--- plugins/funind/g_indfun.ml4 | 2 +- plugins/funind/glob_term_to_relation.ml | 95 +++++++++++++++------------ plugins/funind/indfun.ml | 34 +++++----- plugins/funind/indfun_common.ml | 7 +- plugins/funind/invfun.ml | 6 +- plugins/funind/recdef.ml | 7 +- 7 files changed, 94 insertions(+), 77 deletions(-) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 3edc590ccc..64284c6fe7 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -303,7 +303,8 @@ let generate_functional_principle (evd: Evd.evar_map ref) try let f = funs.(i) in - let type_sort = Universes.new_sort_in_family InType in + let env = Global.env () in + let type_sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -317,14 +318,14 @@ let generate_functional_principle (evd: Evd.evar_map ref) id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) in let names = ref [new_princ_name] in - let evd' = !evd in let hook = fun new_principle_type _ _ -> if Option.is_empty sorts then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let s = Universes.new_sort_in_family fam_sort in + let evd' = Evd.from_env (Global.env ()) in + let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let evd',value = change_property_sort evd' s new_principle_type new_princ_name in let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in @@ -394,7 +395,7 @@ let get_funs_constant mp dp = let body = Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) - (Evd.empty) + (Evd.from_env (Global.env ())) body in body @@ -483,11 +484,10 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) + Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd (Pretyping.interp_elimination_sort x) ) fas in - evd:=sigma; (* We create the first priciple by tactic *) let first_type,other_princ_types = match l_schemes with @@ -597,7 +597,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr let build_scheme fas = Dumpglob.pause (); - let evd = (ref Evd.empty) in + let evd = (ref (Evd.from_env (Global.env ()))) in let pconstants = (List.map (fun (_,f,sort) -> let f_as_constant = @@ -633,7 +633,7 @@ let build_scheme fas = let build_case_scheme fa = let env = Global.env () - and sigma = Evd.empty in + and sigma = (Evd.from_env (Global.env ())) in (* let id_to_constr id = *) (* Constrintern.global_reference id *) (* in *) @@ -673,14 +673,14 @@ let build_case_scheme fa = ); *) generate_functional_principle - (ref Evd.empty) + (ref (Evd.from_env (Global.env ()))) false scheme_type (Some ([|sorts|])) (Some princ_name) this_block_funs 0 - (prove_princ_for_struct (ref Evd.empty) false 0 [|fst (destConst funs)|]) + (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|fst (destConst funs)|]) in () diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 61f03d6f22..bc7e6f8b09 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -388,7 +388,7 @@ let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) | Some id -> let idref = const_of_id id in (* JF : FIXME : we probably need to keep trace of evd in presence of universe polymorphism *) - let idconstr = snd (Evd.fresh_global (Global.env ()) Evd.empty idref) in + let idconstr = snd (Evd.fresh_global (Global.env ()) (Evd.from_env (Global.env ())) idref) in (fun u -> constr_head_match u idconstr) (* select only id *) | None -> (fun u -> isApp u) in (* select calls to any function *) let info_list = find_fapp test g in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 07efaae27b..9d3c0b4b46 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -333,20 +333,20 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (fun x-> fst (Pretyping.understand env Evd.empty x)) raw_value in - let typ,ctx = Pretyping.understand env Evd.empty ~expected_type:Pretyping.IsType raw_typ in + let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in + let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in Environ.push_named (id,value,typ) env let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env Evd.empty); + observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match pat with | PatVar(_,na) -> Environ.push_rel (na,None,typ) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ + try Inductiveops.find_rectype env (Evd.from_env env) typ with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -376,7 +376,7 @@ let add_pat_variables pat typ env : Environ.env = ~init:(env,[]) ) in - observe (str "new var env := " ++ Printer.pr_named_context_of res Evd.empty); + observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); res @@ -393,7 +393,7 @@ let rec pattern_to_term_and_type env typ = function constr in let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ + try Inductiveops.find_rectype env (Evd.from_env env) typ with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -405,7 +405,7 @@ let rec pattern_to_term_and_type env typ = function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] env Evd.empty csta.(i)) + (fun i -> Detyping.detype false [] env (Evd.from_env env) csta.(i)) ) in let patl_as_term = @@ -486,9 +486,9 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) - let rt_as_constr,ctx = Pretyping.understand env Evd.empty rt in - let rt_typ = Typing.unsafe_type_of env Evd.empty rt_as_constr in - let res_raw_type = Detyping.detype false [] env Evd.empty rt_typ in + let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in + let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in + let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in @@ -594,8 +594,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = and combine the two result *) let v_res = build_entry_lc env funnames avoid v in - let v_as_constr,ctx = Pretyping.understand env Evd.empty v in - let v_type = Typing.unsafe_type_of env Evd.empty v_as_constr in + let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in + let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let new_env = match n with Anonymous -> env @@ -610,10 +610,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr,ctx = Pretyping.understand env Evd.empty b in - let b_typ = Typing.unsafe_type_of env Evd.empty b_as_constr in + let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ + try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ @@ -642,10 +642,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = ) nal in - let b_as_constr,ctx = Pretyping.understand env Evd.empty b in - let b_typ = Typing.unsafe_type_of env Evd.empty b_as_constr in + let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ + try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ @@ -689,8 +689,8 @@ and build_entry_lc_from_case env funname make_discr in let types = List.map (fun (case_arg,_) -> - let case_arg_as_constr,ctx = Pretyping.understand env Evd.empty case_arg in - Typing.unsafe_type_of env Evd.empty case_arg_as_constr + let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in + Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr ) el in (****** The next works only if the match is not dependent ****) @@ -737,11 +737,11 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.fold_right (fun id acc -> let typ_of_id = - Typing.unsafe_type_of env_with_pat_ids Evd.empty (mkVar id) + Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (mkVar id) in let raw_typ_of_id = Detyping.detype false [] - env_with_pat_ids Evd.empty typ_of_id + env_with_pat_ids (Evd.from_env env) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) pat_ids @@ -785,15 +785,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in - let typ = Detyping.detype false [] new_env Evd.empty typ_as_constr in + let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.unsafe_type_of new_env Evd.empty (mkVar id) in + let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (mkVar id) in let raw_typ_of_id = - Detyping.detype false [] new_env Evd.empty typ_of_id + Detyping.detype false [] new_env (Evd.from_env env) typ_of_id in raw_typ_of_id )::acc @@ -894,7 +894,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in - let t',ctx = Pretyping.understand env Evd.empty new_t in + let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -914,7 +914,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try fst (Pretyping.understand env Evd.empty t)(*FIXME*) + try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in @@ -937,7 +937,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGProd(n,t,new_b),id_to_exclude with Continue -> let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in - let ty',ctx = Pretyping.understand env Evd.empty ty in + let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in let ind,args' = Inductive.find_inductive env ty' in let mib,_ = Global.lookup_inductive (fst ind) in let nparam = mib.Declarations.mind_nparams in @@ -949,7 +949,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = GRef (Loc.ghost,Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] - env Evd.empty + env (Evd.from_env env) p) params)@(Array.to_list (Array.make (List.length args' - nparam) @@ -959,7 +959,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); - let eq'_as_constr,ctx = Pretyping.understand env Evd.empty eq' in + let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in observe (str " computing new type for jmeq : done") ; let new_args = match kind_of_term eq'_as_constr with @@ -978,12 +978,12 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | Name id' -> (id',Detyping.detype false [] env - Evd.empty + (Evd.from_env env) arg)::acc else if isVar var_as_constr then (destVar var_as_constr,Detyping.detype false [] env - Evd.empty + (Evd.from_env env) arg)::acc else acc ) @@ -1009,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = if is_in_b then b else replace_var_by_term id rt b in let new_env = - let t',ctx = Pretyping.understand env Evd.empty eq' in + let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1047,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t',ctx = Pretyping.understand env Evd.empty t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1063,7 +1063,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t',ctx = Pretyping.understand env Evd.empty t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1082,7 +1082,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_glob_constr rt); - let t',ctx = Pretyping.understand env Evd.empty t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> let new_env = Environ.push_rel (n,None,t') env in @@ -1104,8 +1104,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in - let t',ctx = Pretyping.understand env Evd.empty t in - let type_t' = Typing.unsafe_type_of env Evd.empty t' in + let evd = (Evd.from_env env) in + let t',ctx = Pretyping.understand env evd t in + let evd = Evd.from_env ~ctx env in + let type_t' = Typing.unsafe_type_of env evd t' in let new_env = Environ.push_rel (n,Some t',type_t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1129,7 +1131,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (crossed_types) depth t in - let t',ctx = Pretyping.understand env Evd.empty new_t in + let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (na,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1297,7 +1299,7 @@ let do_build_inductive let rel_arities = Array.mapi rel_arity funsargs in Util.Array.fold_left2 (fun env rel_name rel_ar -> Environ.push_named (rel_name,None, - fst (with_full_print (Constrintern.interp_constr env Evd.empty) rel_ar)) env) env relnames rel_arities + fst (with_full_print (Constrintern.interp_constr env evd) rel_ar)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = @@ -1460,8 +1462,17 @@ let do_build_inductive let build_inductive evd funconstants funsargs returned_types rtl = + let pu = !Detyping.print_universes in + let cu = !Constrextern.print_universes in try - do_build_inductive evd funconstants funsargs returned_types rtl - with e when Errors.noncritical e -> raise (Building_graph e) + Detyping.print_universes := true; + Constrextern.print_universes := true; + do_build_inductive evd funconstants funsargs returned_types rtl; + Detyping.print_universes := pu; + Constrextern.print_universes := cu + with e when Errors.noncritical e -> + Detyping.print_universes := pu; + Constrextern.print_universes := cu; + raise (Building_graph e) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d9d059f8fa..65dc51a84f 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -145,15 +145,14 @@ let interp_casted_constr_with_implicits env sigma impls c = let build_newrecursive lnameargsardef = - let env0 = Global.env() - and sigma = Evd.empty - in + let env0 = Global.env() in + let sigma = Evd.from_env env0 in let (rec_sign,rec_impls) = List.fold_left (fun (env,impls) (((_,recname),_),bl,arityc,_) -> let arityc = Constrexpr_ops.prod_constr_expr arityc bl in let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evdref = ref (Evd.from_env env0) in + let evdref = ref (Evd.from_env env0) in let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) @@ -228,7 +227,7 @@ let process_vernac_interp_error e = let derive_inversion fix_names = try - let evd' = Evd.empty in + let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) let evd',fix_names_as_constant = List.fold_right @@ -355,9 +354,11 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error List.map_i (fun i x -> let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in - let evd',uprinc = Evd.fresh_global (Global.env ()) !evd princ in + let env = Global.env () in + let evd = ref (Evd.from_env env) in + let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in - let princ_type = Typing.e_type_of ~refresh:true (Global.env ()) evd uprinc in + let princ_type = Typing.e_type_of ~refresh:true env evd uprinc in Functional_principles_types.generate_functional_principle evd interactive_proof @@ -394,7 +395,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in evd,((destConst c)::l) ) - (Evd.empty,[]) + (Evd.from_env (Global.env ()),[]) fixpoint_exprl in evd,List.rev rev_pconstants @@ -408,7 +409,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in evd,((destConst c)::l) ) - (Evd.empty,[]) + (Evd.from_env (Global.env ()),[]) fixpoint_exprl in evd,List.rev rev_pconstants @@ -594,9 +595,9 @@ let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in + let ((_,_,typel),ctx,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = - with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) Evd.empty)) typel in + with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_env ~ctx (Global.env ())))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> @@ -625,7 +626,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let using_lemmas = [] in let pre_hook pconstants = generate_principle - (ref (Evd.empty)) + (ref (Evd.from_env (Global.env ()))) pconstants on_error true @@ -649,7 +650,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in let pre_hook pconstants = generate_principle - (ref Evd.empty) + (ref (Evd.from_env (Global.env ()))) pconstants on_error true @@ -680,7 +681,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let evd,pconstants = if register_built then register_struct is_rec fixpoint_exprl - else (Evd.empty,pconstants) + else (Evd.from_env (Global.env ()),pconstants) in let evd = ref evd in generate_principle @@ -835,10 +836,11 @@ let make_graph (f_ref:global_reference) = | None -> error "Cannot build a graph over an axiom !" | Some body -> let env = Global.env () in + let sigma = Evd.from_env env in let extern_body,extern_type = with_full_print (fun () -> - (Constrextern.extern_constr false env Evd.empty body, - Constrextern.extern_type false env Evd.empty + (Constrextern.extern_constr false env sigma body, + Constrextern.extern_type false env sigma ((*FIXME*) Typeops.type_of_constant_type env c_body.const_type) ) ) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 1c409500ef..35bd1c36da 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -180,9 +180,10 @@ let get_proof_clean do_reduce = let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () - in + and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in + let old_printuniverses = !Constrextern.print_universes in + Constrextern.print_universes := true; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; @@ -195,6 +196,7 @@ let with_full_print f a = Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; Dumpglob.continue (); res with @@ -203,6 +205,7 @@ let with_full_print f a = Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; Dumpglob.continue (); raise reraise diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 89ceb751a4..d979401424 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -760,7 +760,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let funs_constr = Array.map mkConstU funs in States.with_state_protection_on_exception (fun () -> - let evd = ref Evd.empty in + let env = Global.env () in + let evd = ref (Evd.from_env env) in let graphs_constr = Array.map mkInd graphs in let lemmas_types_infos = Util.Array.map2_i @@ -829,7 +830,6 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( ) funs; - (* let evd = ref Evd.empty in *) let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> @@ -875,7 +875,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) !evd + (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) sigma (fst lemmas_types_infos.(i)) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 9de15e4071..ca0b9c5feb 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -194,7 +194,7 @@ let (value_f:constr list -> global_reference -> constr) = Anonymous)], GVar(d0,v_id)]) in - let body = fst (understand env Evd.empty glob_body)(*FIXME*) in + let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = @@ -1293,8 +1293,9 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ref_ := Some lemma ; let lid = ref [] in let h_num = ref (-1) in + let env = Global.env () in Proof_global.discard_all (); - build_proof Evd.empty + build_proof (Evd.from_env env) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in observe_tclTHENLIST (str "") @@ -1513,7 +1514,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let relation = fst (*FIXME*)(interp_constr env_with_pre_rec_args - Evd.empty + (Evd.from_env env_with_pre_rec_args) r) in let tcc_lemma_name = add_suffix function_name "_tcc" in -- cgit v1.2.3 From 5c8876da5e25512842f2acd7cfa8c62200b9a623 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:18:11 +0200 Subject: Univs: fix evar_map initialization in newring. --- plugins/setoid_ring/newring.ml4 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index e590958ccf..1c4ba88237 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -155,14 +155,19 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" (****************************************************************************) let ic c = - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in Constrintern.interp_open_constr env sigma c let ic_unsafe c = (*FIXME remove *) - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in fst (Constrintern.interp_constr env sigma c) -let ty c = Typing.unsafe_type_of (Global.env()) Evd.empty c +let ty c = + let env = Global.env() in + let sigma = Evd.from_env env in + Typing.unsafe_type_of env sigma c let decl_constant na ctx c = let vars = Universes.universes_of_constr c in -- cgit v1.2.3 From 91f5467917266a85496fb718dfc30eff3565d4dc Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:20:42 +0200 Subject: Univs (evd): deal with global universes and sideff - Fix union of universe contexts to keep declarations - Fix side-effect handling to register new global universes in the graph. --- pretyping/evd.ml | 137 ++++++++++++++++++++++++++++++++++++------------------ pretyping/evd.mli | 2 + 2 files changed, 95 insertions(+), 44 deletions(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index a25479d483..8243f96c16 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -310,6 +310,9 @@ let union_evar_universe_context ctx ctx' = else let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in + let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) + (Univ.ContextSet.levels ctx.uctx_local) in + let declarenew g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g in let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; @@ -317,12 +320,12 @@ let union_evar_universe_context ctx ctx' = Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; - uctx_initial_universes = ctx.uctx_initial_universes; + uctx_initial_universes = declarenew ctx.uctx_initial_universes; uctx_universes = if local == ctx.uctx_local then ctx.uctx_universes else let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in - Univ.merge_constraints cstrsr ctx.uctx_universes } + Univ.merge_constraints cstrsr (declarenew ctx.uctx_universes) } (* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) (* let union_evar_universe_context = *) @@ -935,38 +938,6 @@ let evars_of_filtered_evar_info evi = | Evar_defined b -> evars_of_term b) (evars_of_named_context (evar_filtered_context evi))) -(**********************************************************) -(* Side effects *) - -let emit_side_effects eff evd = - { evd with effects = Declareops.union_side_effects eff evd.effects; } - -let drop_side_effects evd = - { evd with effects = Declareops.no_seff; } - -let eval_side_effects evd = evd.effects - -(* Future goals *) -let declare_future_goal evk evd = - { evd with future_goals = evk::evd.future_goals } - -let declare_principal_goal evk evd = - match evd.principal_future_goal with - | None -> { evd with - future_goals = evk::evd.future_goals; - principal_future_goal=Some evk; } - | Some _ -> Errors.error "Only one main subgoal per instantiation." - -let future_goals evd = evd.future_goals - -let principal_future_goal evd = evd.principal_future_goal - -let reset_future_goals evd = - { evd with future_goals = [] ; principal_future_goal=None } - -let restore_future_goals evd gls pgl = - { evd with future_goals = gls ; principal_future_goal = pgl } - (**********************************************************) (* Sort variables *) @@ -1022,13 +993,13 @@ let restrict_universe_context evd vars = let universe_subst evd = evd.universes.uctx_univ_variables -let merge_uctx rigid uctx ctx' = +let merge_uctx sideff rigid uctx ctx' = let open Univ in - let uctx = + let levels = ContextSet.levels ctx' in + let uctx = if sideff then uctx else match rigid with | UnivRigid -> uctx | UnivFlexible b -> - let levels = ContextSet.levels ctx' in let fold u accu = if LMap.mem u accu then accu else LMap.add u None accu @@ -1039,12 +1010,23 @@ let merge_uctx rigid uctx ctx' = uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels } else { uctx with uctx_univ_variables = uvars' } in - let uctx_local = ContextSet.append ctx' uctx.uctx_local in - let uctx_universes = merge_constraints (ContextSet.constraints ctx') uctx.uctx_universes in - { uctx with uctx_local; uctx_universes } + let uctx_local = + if sideff then uctx.uctx_local + else ContextSet.append ctx' uctx.uctx_local + in + let declare g = + LSet.fold (fun u g -> + try Univ.add_universe u false g + with Univ.AlreadyDeclared when sideff -> g) + levels g + in + let initial = declare uctx.uctx_initial_universes in + let univs = declare uctx.uctx_universes in + let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in + { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } let merge_context_set rigid evd ctx' = - {evd with universes = merge_uctx rigid evd.universes ctx'} + {evd with universes = merge_uctx false rigid evd.universes ctx'} let merge_uctx_subst uctx s = { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } @@ -1055,6 +1037,24 @@ let merge_universe_subst evd subst = let with_context_set rigid d (a, ctx) = (merge_context_set rigid d ctx, a) +let emit_universe_side_effects eff u = + Declareops.fold_side_effects + (fun acc eff -> + match eff with + | Declarations.SEscheme (l,s) -> + List.fold_left + (fun acc (_,_,cb,c) -> + let acc = match c with + | `Nothing -> acc + | `Opaque (s, ctx) -> merge_uctx true univ_rigid acc ctx + in if cb.Declarations.const_polymorphic then acc + else + merge_uctx true univ_rigid acc + (Univ.ContextSet.of_context cb.Declarations.const_universes)) + acc l + | Declarations.SEsubproof _ -> acc) + u eff + let add_uctx_names s l (names, names_rev) = (UNameMap.add s l names, Univ.LMap.add l s names_rev) @@ -1103,6 +1103,18 @@ let new_sort_variable ?name ?(predicative=true) rigid d = let (d', u) = new_univ_variable rigid ?name ~predicative d in (d', Type u) +let add_global_univ d u = + let uctx = d.universes in + let initial = + Univ.add_universe u true uctx.uctx_initial_universes + in + let univs = + Univ.add_universe u true uctx.uctx_universes + in + { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; + uctx_initial_universes = initial; + uctx_universes = univs } } + let make_flexible_variable evd b u = let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in let uvars' = Univ.LMap.add u None uvars in @@ -1291,12 +1303,16 @@ let refresh_undefined_univ_variables uctx = Univ.LMap.add (Univ.subst_univs_level_level subst u) (Option.map (Univ.subst_univs_level_universe subst) v) acc) uctx.uctx_univ_variables Univ.LMap.empty - in + in + let declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g) + (Univ.ContextSet.levels ctx') g in + let initial = declare uctx.uctx_initial_universes in + let univs = declare Univ.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; uctx_local = ctx'; uctx_univ_variables = vars; uctx_univ_algebraic = alg; - uctx_universes = Univ.initial_universes; - uctx_initial_universes = uctx.uctx_initial_universes } in + uctx_universes = univs; + uctx_initial_universes = initial } in uctx', subst let refresh_undefined_universes evd = @@ -1382,6 +1398,39 @@ let e_eq_constr_univs evdref t u = let evd, b = eq_constr_univs !evdref t u in evdref := evd; b +(**********************************************************) +(* Side effects *) + +let emit_side_effects eff evd = + { evd with effects = Declareops.union_side_effects eff evd.effects; + universes = emit_universe_side_effects eff evd.universes } + +let drop_side_effects evd = + { evd with effects = Declareops.no_seff; } + +let eval_side_effects evd = evd.effects + +(* Future goals *) +let declare_future_goal evk evd = + { evd with future_goals = evk::evd.future_goals } + +let declare_principal_goal evk evd = + match evd.principal_future_goal with + | None -> { evd with + future_goals = evk::evd.future_goals; + principal_future_goal=Some evk; } + | Some _ -> Errors.error "Only one main subgoal per instantiation." + +let future_goals evd = evd.future_goals + +let principal_future_goal evd = evd.principal_future_goal + +let reset_future_goals evd = + { evd with future_goals = [] ; principal_future_goal=None } + +let restore_future_goals evd gls pgl = + { evd with future_goals = gls ; principal_future_goal = pgl } + (**********************************************************) (* Accessing metas *) diff --git a/pretyping/evd.mli b/pretyping/evd.mli index c2ccc6d21a..5a59c1776c 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -508,6 +508,8 @@ val normalize_evar_universe_context : evar_universe_context -> val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts +val add_global_univ : evar_map -> Univ.Level.t -> evar_map + val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map val is_sort_variable : evar_map -> sorts -> Univ.universe_level option (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is -- cgit v1.2.3 From 02aace9f038d579e9cf32dc2f5b21d415e977c03 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:23:43 +0200 Subject: Univs (pretyping): allow parsing and decl of Top.n This allows pretyping and detyping to be inverses regarding universes, and makes Function's detyping/pretyping manipulations bearable in presence of global universes that must be declared (otherwise an evd would need to be threaded there in many places as well). --- pretyping/pretyping.ml | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 2858a5c1fe..edb76e52f4 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -102,14 +102,27 @@ let ((constr_in : constr -> Dyn.t), (** Miscellaneous interpretation functions *) let interp_universe_level_name evd s = let names, _ = Universes.global_universe_names () in - try - let id = try Id.of_string s with _ -> raise Not_found in - evd, Idmap.find id names - with Not_found -> - try let level = Evd.universe_of_name evd s in - evd, level - with Not_found -> - new_univ_level_variable ~name:s univ_rigid evd + if CString.string_contains s "." then + match List.rev (CString.split '.' s) with + | [] -> anomaly (str"Invalid universe name " ++ str s) + | n :: dp -> + let num = int_of_string n in + let dp = DirPath.make (List.map Id.of_string dp) in + let level = Univ.Level.make dp num in + let evd = + try Evd.add_global_univ evd level + with Univ.AlreadyDeclared -> evd + in evd, level + else + try + let id = + try Id.of_string s with _ -> raise Not_found in + evd, Idmap.find id names + with Not_found -> + try let level = Evd.universe_of_name evd s in + evd, level + with Not_found -> + new_univ_level_variable ~name:s univ_rigid evd let interp_universe evd = function | [] -> let evd, l = new_univ_level_variable univ_rigid evd in -- cgit v1.2.3 From 91b1808056602f3e26d1eb1bdf7be1e791cb742d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 16:35:07 +0200 Subject: Univs: fix many evar_map initializations and leaks. --- pretyping/typeclasses.ml | 2 +- stm/lemmas.ml | 3 +- tactics/autorewrite.ml | 5 ++- tactics/equality.ml | 4 ++- tactics/extratactics.ml4 | 7 +++-- tactics/hints.ml | 3 +- tactics/rewrite.ml | 24 ++++++++------ tactics/tacticals.ml | 10 +++--- toplevel/classes.ml | 15 +++++---- toplevel/command.ml | 13 +++++--- toplevel/obligations.ml | 19 +++++++----- toplevel/record.ml | 79 ++++++++++++++++++++++++++--------------------- toplevel/vernacentries.ml | 5 +-- 13 files changed, 112 insertions(+), 77 deletions(-) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 18e83056bd..2ef2896506 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -370,7 +370,7 @@ let add_instance check inst = List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path (is_local inst) pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) - (Global.env ()) Evd.empty inst.is_impl inst.is_pri) + (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_pri) let rebuild_instance (action, inst) = let () = match action with diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 7679b1a662..2bd1c54519 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -503,4 +503,5 @@ let save_proof ?proof = function let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> - (Evd.empty, Global.env()) + let env = Global.env () in + (Evd.from_env env, env) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 2b3fadf7fa..3a9d40de03 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -292,10 +292,13 @@ let find_applied_relation metas loc env sigma c left2right = (* To add rewriting rules to a base *) let add_rew_rules base lrul = let counter = ref 0 in + let env = Global.env () in + let sigma = Evd.from_env env in let lrul = List.fold_left (fun dn (loc,(c,ctx),b,t) -> - let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let info = find_applied_relation false loc env sigma c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; rew_pat = pat; rew_ctx = ctx; rew_l2r = b; diff --git a/tactics/equality.ml b/tactics/equality.ml index d012427a08..53678aa848 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -335,7 +335,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) - let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + let sigma, elim = + Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) + in sigma, elim, eff | _ -> assert false diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index af0870bc92..ead26e964f 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -262,7 +262,8 @@ TACTIC EXTEND rewrite_star (* Hint Rewrite *) let add_rewrite_hint bases ort t lcsr = - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in let poly = Flags.is_universe_polymorphism () in let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in @@ -490,7 +491,9 @@ let inTransitivity : bool * constr -> obj = (* Main entry points *) let add_transitivity_lemma left lem = - let lem',ctx (*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty lem in + let env = Global.env () in + let sigma = Evd.from_env env in + let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) diff --git a/tactics/hints.ml b/tactics/hints.ml index 0df1a35c62..48b4505327 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1135,7 +1135,8 @@ let add_hints local dbnames0 h = if String.List.mem "nocore" dbnames0 then error "The hint database \"nocore\" is meant to stay empty."; let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in match h with | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index c64a1226ab..937ad2b9d4 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1797,11 +1797,13 @@ let proper_projection r ty = it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = - let c,uctx = Universes.fresh_global_instance (Global.env()) r in let poly = Global.is_polymorphic r in - let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in + let env = Global.env () in + let sigma = Evd.from_env env in + let evd,c = Evd.fresh_global env sigma r in + let ty = Retyping.get_type_of env sigma c in let term = proper_projection c ty in - let typ = Typing.unsafe_type_of (Global.env ()) Evd.empty term in + let typ = Typing.unsafe_type_of env sigma term in let ctx, typ = decompose_prod_assum typ in let typ = let n = @@ -1824,15 +1826,16 @@ let declare_projection n instance_id r = in let typ = it_mkProd_or_LetIn typ ctx in let cst = - Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) - term + Declare.definition_entry ~types:typ ~poly + ~univs:(Evd.universe_context sigma) term in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) let build_morphism_signature m = let env = Global.env () in - let m,ctx = Constrintern.interp_constr env (Evd.from_env env) m in + let sigma = Evd.from_env env in + let m,ctx = Constrintern.interp_constr env sigma m in let sigma = Evd.from_ctx ctx in let t = Typing.unsafe_type_of env sigma m in let cstrs = @@ -1844,7 +1847,7 @@ let build_morphism_signature m = in aux t in let evars, t', sig_, cstrs = - PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in + PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in let evd = ref evars in let _ = List.iter (fun (ty, rel) -> @@ -1861,9 +1864,10 @@ let build_morphism_signature m = let default_morphism sign m = let env = Global.env () in - let t = Typing.unsafe_type_of env Evd.empty m in + let sigma = Evd.from_env env in + let t = Typing.unsafe_type_of env sigma m in let evars, _, sign, cstrs = - PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) + PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in let evars, mor = resolve_one_typeclass env (goalevars evars) morph in @@ -1894,7 +1898,7 @@ let add_morphism_infer glob m n = let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in - let evd = Evd.empty (*FIXME *) in + let evd = Evd.from_env (Global.env ()) in if Lib.is_modtype () then let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 7d1cc3341c..bc82e9ef46 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -593,10 +593,12 @@ module New = struct (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - Proofview.Goal.nf_enter begin fun gl -> - let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in - (** FIXME: evar leak. *) + Proofview.Goal.nf_enter + begin fun gl -> let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Proofview.Goal.nf_enter begin fun gl -> + let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in (* applying elimination_scheme just a little modified *) let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in let indmv = @@ -647,7 +649,7 @@ module New = struct Proofview.tclTHEN (Clenvtac.clenv_refine false clenv') (Proofview.tclEXTEND [] tclIDTAC branchtacs) - end + end) end let elimination_then tac c = Proofview.Goal.nf_enter begin fun gl -> diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 7fe79d948b..805a29e396 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -347,7 +347,7 @@ let named_of_rel_context l = let context poly l = let env = Global.env() in - let evars = ref Evd.empty in + let evars = ref (Evd.from_env env) in let _, ((env', fullctx), impls) = interp_context_evars env evars l in let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in let fullctx = Context.map_rel_context subst fullctx in @@ -358,11 +358,13 @@ let context poly l = with e when Errors.noncritical e -> error "Anonymous variables not allowed in contexts." in - let uctx = Evd.universe_context_set !evars in + let uctx = ref (Evd.universe_context_set !evars) in let fn status (id, b, t) = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - let uctx = Univ.ContextSet.to_context uctx in - let decl = (ParameterEntry (None,poly,(t,uctx),None), IsAssumption Logical) in + let ctx = Univ.ContextSet.to_context !uctx in + (* Declare the universe context once *) + let () = uctx := Univ.ContextSet.empty in + let decl = (ParameterEntry (None,poly,(t,ctx),None), IsAssumption Logical) in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in match class_of_constr t with | Some (rels, ((tc,_), args) as _cl) -> @@ -379,8 +381,9 @@ let context poly l = let impl = List.exists test impls in let decl = (Discharge, poly, Definitional) in let nstatus = - pi3 (Command.declare_assumption false decl (t, uctx) [] impl + pi3 (Command.declare_assumption false decl (t, !uctx) [] impl Vernacexpr.NoInline (Loc.ghost, id)) in - status && nstatus + let () = uctx := Univ.ContextSet.empty in + status && nstatus in List.fold_left fn true (List.rev ctx) diff --git a/toplevel/command.ml b/toplevel/command.ml index d397eed610..b65ff73feb 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -241,11 +241,14 @@ let interp_assumption evdref env impls bl c = let ctx = Evd.universe_context_set evd in ((nf ty, ctx), impls) -let declare_assumptions idl is_coe k c imps impl_is_on nl = - let refs, status = - List.fold_left (fun (refs,status) id -> - let ref',u',status' = declare_assumption is_coe k c imps impl_is_on nl id in - (ref',u')::refs, status' && status) ([],true) idl in +let declare_assumptions idl is_coe k (c,ctx) imps impl_is_on nl = + let refs, status, _ = + List.fold_left (fun (refs,status,ctx) id -> + let ref',u',status' = + declare_assumption is_coe k (c,ctx) imps impl_is_on nl id in + (ref',u')::refs, status' && status, Univ.ContextSet.empty) + ([],true,ctx) idl + in List.rev refs, status let do_assumptions (_, poly, _ as kind) nl l = diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 3c0977784d..e8682c1b58 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -623,7 +623,7 @@ let declare_obligation prg obl body ty uctx = let body = prg.prg_reduce body in let ty = Option.map prg.prg_reduce ty in match obl.obl_status with - | Evar_kinds.Expand -> { obl with obl_body = Some (TermObl body) } + | Evar_kinds.Expand -> false, { obl with obl_body = Some (TermObl body) } | Evar_kinds.Define opaque -> let opaque = if get_proofs_transparency () then false else opaque in let poly = pi2 prg.prg_kind in @@ -647,7 +647,7 @@ let declare_obligation prg obl body ty uctx = in if not opaque then add_hint false prg constant; definition_message obl.obl_name; - { obl with obl_body = + true, { obl with obl_body = if poly then Some (DefinedObl constant) else @@ -815,9 +815,9 @@ let obligation_hook prg obl num auto ctx' _ gr = let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in let ctx' = if not (pi2 prg.prg_kind) (* Not polymorphic *) then - (* This context is already declared globally, we cannot - instantiate the rigid variables anymore *) - Evd.abstract_undefined_variables ctx' + (* The universe context was declared globally, we continue + from the new global environment. *) + Evd.evar_universe_context (Evd.from_env (Global.env ())) else ctx' in let prg = { prg with prg_ctx = ctx' } in @@ -889,8 +889,13 @@ and solve_obligation_by_tac prg obls i tac = (pi2 !prg.prg_kind) !prg.prg_ctx in let uctx = Evd.evar_context_universe_context ctx in - prg := {!prg with prg_ctx = ctx}; - obls.(i) <- declare_obligation !prg obl t ty uctx; + let () = prg := {!prg with prg_ctx = ctx} in + let def, obl' = declare_obligation !prg obl t ty uctx in + obls.(i) <- obl'; + if def && not (pi2 !prg.prg_kind) then ( + (* Declare the term constraints with the first obligation only *) + let ctx' = Evd.evar_universe_context (Evd.from_env (Global.env ())) in + prg := {!prg with prg_ctx = ctx'}); true else false with e when Errors.noncritical e -> diff --git a/toplevel/record.ml b/toplevel/record.ml index e214f9ca71..ee80101f3d 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -233,7 +233,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let (mib,mip) = Global.lookup_inductive indsp in let u = Declareops.inductive_instance mib in let paramdecls = Inductive.inductive_paramdecls (mib, u) in - let poly = mib.mind_polymorphic and ctx = Univ.instantiate_univ_context mib.mind_universes in + let poly = mib.mind_polymorphic in + let ctx = Univ.instantiate_univ_context mib.mind_universes in let indu = indsp, u in let r = mkIndU (indsp,u) in let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in @@ -293,7 +294,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field const_entry_secctx = None; const_entry_type = Some projtyp; const_entry_polymorphic = poly; - const_entry_universes = ctx; + const_entry_universes = + if poly then ctx else Univ.UContext.empty; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None } in @@ -397,44 +399,49 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity let impl, projs = match fields with | [(Name proj_name, _, field)] when def -> - let class_body = it_mkLambda_or_LetIn field params in - let _class_type = it_mkProd_or_LetIn arity params in - let class_entry = - Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in - let cst = Declare.declare_constant (snd id) - (DefinitionEntry class_entry, IsDefinition Definition) - in - let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in - let inst_type = appvectc (mkConstU cstu) (Termops.rel_vect 0 (List.length params)) in - let proj_type = - it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in - let proj_body = - it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in - let proj_entry = Declare.definition_entry ~types:proj_type ~poly ~univs:ctx proj_body in - let proj_cst = Declare.declare_constant proj_name - (DefinitionEntry proj_entry, IsDefinition Definition) - in - let cref = ConstRef cst in - Impargs.declare_manual_implicits false cref [paramimpls]; - Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; - Classes.set_typeclass_transparency (EvalConstRef cst) false false; - let sub = match List.hd coers with - | Some b -> Some ((if b then Backward else Forward), List.hd priorities) - | None -> None - in - cref, [Name proj_name, sub, Some proj_cst] + let class_body = it_mkLambda_or_LetIn field params in + let _class_type = it_mkProd_or_LetIn arity params in + let class_entry = + Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in + let cst = Declare.declare_constant (snd id) + (DefinitionEntry class_entry, IsDefinition Definition) + in + let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in + let inst_type = appvectc (mkConstU cstu) + (Termops.rel_vect 0 (List.length params)) in + let proj_type = + it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in + let proj_body = + it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in + let proj_entry = + Declare.definition_entry ~types:proj_type ~poly + ~univs:(if poly then ctx else Univ.UContext.empty) proj_body + in + let proj_cst = Declare.declare_constant proj_name + (DefinitionEntry proj_entry, IsDefinition Definition) + in + let cref = ConstRef cst in + Impargs.declare_manual_implicits false cref [paramimpls]; + Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; + Classes.set_typeclass_transparency (EvalConstRef cst) false false; + let sub = match List.hd coers with + | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | None -> None + in + cref, [Name proj_name, sub, Some proj_cst] | _ -> - let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls + let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls params arity template fieldimpls fields ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign - in - let coers = List.map2 (fun coe pri -> - Option.map (fun b -> - if b then Backward, pri else Forward, pri) coe) + in + let coers = List.map2 (fun coe pri -> + Option.map (fun b -> + if b then Backward, pri else Forward, pri) coe) coers priorities - in - IndRef ind, (List.map3 (fun (id, _, _) b y -> (id, b, y)) - (List.rev fields) coers (Recordops.lookup_projections ind)) + in + let l = List.map3 (fun (id, _, _) b y -> (id, b, y)) + (List.rev fields) coers (Recordops.lookup_projections ind) + in IndRef ind, l in let ctx_context = List.map (fun (na, b, t) -> diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 8ae6ac2bc3..2946766cb1 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1185,8 +1185,9 @@ let default_env () = { let vernac_reserve bl = let sb_decl = (fun (idl,c) -> let env = Global.env() in - let t,ctx = Constrintern.interp_type env Evd.empty c in - let t = Detyping.detype false [] env Evd.empty t in + let sigma = Evd.from_env env in + let t,ctx = Constrintern.interp_type env sigma c in + let t = Detyping.detype false [] env (Evd.from_env ~ctx env) t in let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl -- cgit v1.2.3 From 91e01278de2420a64f1c8de03c0bc6e614577042 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 18:53:35 +0200 Subject: Univs: fixed bug #4328. --- test-suite/bugs/closed/4328.v | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 test-suite/bugs/closed/4328.v diff --git a/test-suite/bugs/closed/4328.v b/test-suite/bugs/closed/4328.v new file mode 100644 index 0000000000..8e1bb31007 --- /dev/null +++ b/test-suite/bugs/closed/4328.v @@ -0,0 +1,6 @@ +Inductive M (A:Type) : Type := M'. +Axiom pi : forall (P : Prop) (p : P), Prop. +Definition test1 A (x : _) := pi A x. (* success *) +Fail Definition test2 A (x : A) := pi A x. (* failure ??? *) +Fail Definition test3 A (x : A) (_ : M A) := pi A x. (* failure *) +Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *) \ No newline at end of file -- cgit v1.2.3 From c92946243ccb0b11cd138f040a5297979229c3f5 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 19:01:31 +0200 Subject: Univs: fix after rebase (from_ctx/from_env) --- plugins/funind/glob_term_to_relation.ml | 2 +- plugins/funind/indfun.ml | 2 +- pretyping/evd.ml | 7 ++++--- toplevel/vernacentries.ml | 2 +- 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 9d3c0b4b46..1b12cd42ce 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1106,7 +1106,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let not_free_in_t id = not (is_free_in id t) in let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in - let evd = Evd.from_env ~ctx env in + let evd = Evd.from_ctx ctx in let type_t' = Typing.unsafe_type_of env evd t' in let new_env = Environ.push_rel (n,Some t',type_t') env in let new_b,id_to_exclude = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 65dc51a84f..eadeebd38e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -597,7 +597,7 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in let ((_,_,typel),ctx,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = - with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_env ~ctx (Global.env ())))) typel in + with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 8243f96c16..842b87c57e 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1136,9 +1136,10 @@ let make_evar_universe_context e l = match l with | None -> uctx | Some us -> - List.fold_left (fun uctx (loc,id) -> - fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) uctx)) - uctx us + List.fold_left + (fun uctx (loc,id) -> + fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx)) + uctx us (****************************************) (* Operations on constants *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 2946766cb1..e51dfbaaec 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1187,7 +1187,7 @@ let vernac_reserve bl = let env = Global.env() in let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in - let t = Detyping.detype false [] env (Evd.from_env ~ctx env) t in + let t = Detyping.detype false [] env (Evd.from_ctx ctx) t in let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl -- cgit v1.2.3 From 43858a207437fa08f066bdd3cae7bcd3034808f1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 19:14:05 +0200 Subject: Univs: fix Universe vernacular, fix bug #4287. No universe can be set lower than Prop anymore (or Set). --- library/declare.ml | 10 ++- test-suite/bugs/closed/4287.v | 172 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 178 insertions(+), 4 deletions(-) create mode 100644 test-suite/bugs/closed/4287.v diff --git a/library/declare.ml b/library/declare.ml index 8438380c9c..8908a2c919 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -455,12 +455,14 @@ let input_universes : universe_names -> Libobject.obj = let do_universe l = let glob = Universes.global_universe_names () in - let glob' = - List.fold_left (fun (idl,lid) (l, id) -> + let glob', ctx = + List.fold_left (fun ((idl,lid),ctx) (l, id) -> let lev = Universes.new_univ_level (Global.current_dirpath ()) in - (Idmap.add id lev idl, Univ.LMap.add lev id lid)) - glob l + ((Idmap.add id lev idl, Univ.LMap.add lev id lid), + Univ.ContextSet.add_universe lev ctx)) + (glob, Univ.ContextSet.empty) l in + Global.push_context_set ctx; Lib.add_anonymous_leaf (input_universes glob') diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v new file mode 100644 index 0000000000..732f19f33c --- /dev/null +++ b/test-suite/bugs/closed/4287.v @@ -0,0 +1,172 @@ + +Universe b. + +Universe c. + +Definition U : Type@{b} := Type@{c}. + +Module Type MT. + +Definition T := Prop. +End MT. + +Module M : MT. + Definition T := Type@{b}. + +Print Universes. +Fail End M. + +Set Universe Polymorphism. + +(* This is a modified version of Hurkens with all universes floating *) +Section Hurkens. + +Variable down : Type -> Type. +Variable up : Type -> Type. + +Hypothesis back : forall A, up (down A) -> A. + +Hypothesis forth : forall A, A -> up (down A). + +Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A), + P (back A (forth A a)) -> P a. + +Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A), + P a -> P (back A (forth A a)). + +(** Proof *) +Definition V : Type := forall A:Type, ((up A -> Type) -> up A -> Type) -> up A -> Type. +Definition U : Type := V -> Type. + +Definition sb (z:V) : V := fun A r a => r (z A r) a. +Definition le (i:U -> Type) (x:U) : Type := x (fun A r a => i (fun v => sb v A r a)). +Definition le' (i:up (down U) -> Type) (x:up (down U)) : Type := le (fun a:U => i (forth _ a)) (back _ x). +Definition induct (i:U -> Type) : Type := forall x:U, up (le i x) -> up (i x). +Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))). +Definition I (x:U) : Type := + (forall i:U -> Type, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False. + +Lemma Omega : forall i:U -> Type, induct i -> up (i WF). +Proof. +intros i y. +apply y. +unfold le, WF, induct. +apply forth. +intros x H0. +apply y. +unfold sb, le', le. +compute. +apply backforth_r. +exact H0. +Qed. + +Lemma lemma1 : induct (fun u => down (I u)). +Proof. +unfold induct. +intros x p. +apply forth. +intro q. +generalize (q (fun u => down (I u)) p). +intro r. +apply back in r. +apply r. +intros i j. +unfold le, sb, le', le in j |-. +apply backforth in j. +specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))). +apply q. +exact j. +Qed. + +Lemma lemma2 : (forall i:U -> Type, induct i -> up (i WF)) -> False. +Proof. +intro x. +generalize (x (fun u => down (I u)) lemma1). +intro r; apply back in r. +apply r. +intros i H0. +apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))). +unfold le, WF in H0. +apply back in H0. +exact H0. +Qed. + +Theorem paradox : False. +Proof. +exact (lemma2 Omega). +Qed. + +End Hurkens. + +Polymorphic Record box (T : Type) := wrap {unwrap : T}. + +(* Here we instantiate to Prop *) +(* Here we instantiate to Prop *) + +Fail Definition down (x : Type) : Set := box x. +Definition down (x : Set) : Set := box x. +Definition up (x : Prop) : Type := x. + +Fail Definition back A : up (down A) -> A := unwrap A. + +Fail Definition forth A : A -> up (down A) := wrap A. + +(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) +(* P (back A (forth A a)) -> P a. *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) +(* P a -> P (back A (forth A a)). *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Theorem bad : False. *) +(* apply (paradox down up back forth backforth backforth_r). *) +(* Qed. *) + +(* Print Assumptions bad. *) + +Definition id {A : Type} (a : A) := a. +Definition setlt (A : Type@{i}) := + let foo := Type@{i} : Type@{j} in True. + +Definition setle (B : Type@{i}) := + let foo (A : Type@{j}) := A in foo B. + +Fail Check @setlt@{j Prop}. +Check @setlt@{Prop j}. +Check @setle@{Prop j}. + +Fail Definition foo := @setle@{j Prop}. +Definition foo := @setle@{Prop j}. + +(* Definition up (x : Prop) : Type := x. *) + +(* Definition back A : up (down A) -> A := unwrap A. *) + +(* Definition forth A : A -> up (down A) := wrap A. *) + +(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) +(* P (back A (forth A a)) -> P a. *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) +(* P a -> P (back A (forth A a)). *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Theorem bad : False. *) +(* apply (paradox down up back forth backforth backforth_r). *) +(* Qed. *) + +(* Print Assumptions bad. *) + +(* Polymorphic Record box (T : Type) := wrap {unwrap : T}. *) + +(* Definition down (x : Type) : Prop := box x. *) -- cgit v1.2.3 From b969b459021fe70272baa85e83c12268baf13836 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 19:31:18 +0200 Subject: Univs: fixed bug 2584, correct universe found for mutual inductive. --- test-suite/bugs/closed/2584.v | 89 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 test-suite/bugs/closed/2584.v diff --git a/test-suite/bugs/closed/2584.v b/test-suite/bugs/closed/2584.v new file mode 100644 index 0000000000..a5f4ae64a0 --- /dev/null +++ b/test-suite/bugs/closed/2584.v @@ -0,0 +1,89 @@ +Require Import List. + +Set Implicit Arguments. + +Definition err : Type := unit. + +Inductive res (A: Type) : Type := +| OK: A -> res A +| Error: err -> res A. + +Implicit Arguments Error [A]. + +Set Printing Universes. + +Section FOO. + +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. + +Print ftyp. +(* yields: +Inductive ftyp : Type (* Top.27429 *) := + Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp + with area : Type (* Set *) := Stored : ftyp -> area +*) + +Fixpoint tc_wf_type (ftype: ftyp) {struct ftype}: res unit := + match ftype with + | Funit => OK tt + | Ffun args => + ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit := + match ftypes with + | nil => OK tt + | t::ts => + match tc_wf_type t with + | OK tt => tc_wf_types ts + | Error m => Error m + end + end) args) + | Fref a => tc_wf_area a + end +with tc_wf_area (ar:area): res unit := + match ar with + | Stored c => tc_wf_type c + end. + +End FOO. + +Print ftyp. +(* yields: +Inductive ftyp : Type (* Top.27465 *) := + Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp + with area : Set := Stored : ftyp -> area +*) + +Fixpoint tc_wf_type' (ftype: ftyp) {struct ftype}: res unit := + match ftype with + | Funit => OK tt + | Ffun args => + ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit := + match ftypes with + | nil => OK tt + | t::ts => + match tc_wf_type' t with + | OK tt => tc_wf_types ts + | Error m => Error m + end + end) args) + | Fref a => tc_wf_area' a + end +with tc_wf_area' (ar:area): res unit := + match ar with + | Stored c => tc_wf_type' c + end. + +(* yields: +Error: +Incorrect elimination of "ar" in the inductive type "area": +the return type has sort "Type (* max(Set, Top.27424) *)" while it +should be "Prop" or "Set". +Elimination of an inductive object of sort Set +is not allowed on a predicate in sort Type +because strong elimination on non-small inductive types leads to paradoxes. +*) \ No newline at end of file -- cgit v1.2.3 From 89cf845e1653c2f9b274d413561f10b7019d4858 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 10:51:56 +0200 Subject: discriminate: Do fresh_global in the right env in presence of side-effects. --- tactics/equality.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index 53678aa848..c442178c10 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -901,7 +901,7 @@ let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim, eff = ind_scheme_of_eq lbeq in - let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in + let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), eff -- cgit v1.2.3 From 210453feca389e84dc01ab388657f27327b2df32 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 11:14:11 +0200 Subject: Univs: fix environment handling in scheme building. --- toplevel/auto_ind_decl.ml | 14 ++++++++++---- toplevel/indschemes.ml | 2 +- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 4122487e23..009e423e4f 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -304,7 +304,7 @@ let build_beq_scheme mode kn = raise (NonSingletonProp (kn,i)); let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in create_input fix), - Evd.empty_evar_universe_context (* FIXME *)), + Evd.make_evar_universe_context (Global.env ()) None), !eff let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme @@ -641,7 +641,7 @@ let make_bl_scheme mode mind = let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in - let ctx = Evd.empty_evar_universe_context (*FIXME univs *) in + let ctx = Evd.make_evar_universe_context (Global.env ()) None in let side_eff = side_effect_of_mode mode in let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx bl_goal (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) @@ -764,12 +764,18 @@ let make_lb_scheme mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in +<<<<<<< HEAD let ctx = Evd.empty_evar_universe_context in let side_eff = side_effect_of_mode mode in let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) +======= + let ctx = Evd.make_evar_universe_context (Global.env ()) None in + let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx lb_goal + (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) +>>>>>>> Univs: fix environment handling in scheme building. in - ([|ans|], ctx (* FIXME *)), eff + ([|ans|], ctx), eff let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme @@ -934,7 +940,7 @@ let make_eq_decidability mode mind = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let u = Univ.Instance.empty in - let ctx = Evd.empty_evar_universe_context (* FIXME *)in + let ctx = Evd.make_evar_universe_context (Global.env ()) None in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index 452d5fbe50..ae8ee7670a 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -423,7 +423,7 @@ let fold_left' f = function let build_combined_scheme env schemes = let defs = List.map (fun cst -> (* FIXME *) - let evd, c = Evd.fresh_constant_instance env Evd.empty cst in + let evd, c = Evd.fresh_constant_instance env (Evd.from_env env) cst in (c, Typeops.type_of_constant_in env c)) schemes in (* let nschemes = List.length schemes in *) let find_inductive ty = -- cgit v1.2.3 From 0bc47a571c050979921bffd0b790a24a75ad990e Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:14:58 +0200 Subject: Univs: handle side-effects of futures correctly in kernel. --- kernel/safe_typing.ml | 2 +- kernel/term_typing.ml | 40 +++++++++++++++++++++++++--------------- 2 files changed, 26 insertions(+), 16 deletions(-) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 9417aa0801..43358d604d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -233,7 +233,7 @@ let add_constraints cst senv = univ = Univ.ContextSet.union cst senv.univ } let add_constraints_list cst senv = - List.fold_right add_constraints cst senv + List.fold_left (fun acc c -> add_constraints c acc) senv cst let push_context_set ctx = add_constraints (Now ctx) let push_context ctx = add_constraints (Now (Univ.ContextSet.of_context ctx)) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index e89b6ef8f7..926b387942 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -45,8 +45,8 @@ let map_option_typ = function None -> `None | Some x -> `Some x let mk_pure_proof c = (c, Univ.ContextSet.empty), Declareops.no_seff -let handle_side_effects env body side_eff = - let handle_sideff t se = +let handle_side_effects env body ctx side_eff = + let handle_sideff (t,ctx) se = let cbl = match se with | SEsubproof (c,cb,b) -> [c,cb,b] | SEscheme (cl,_) -> List.map (fun (_,c,cb,b) -> c,cb,b) cl in @@ -66,7 +66,7 @@ let handle_side_effects env body side_eff = | Const (c',u') when eq_constant c c' -> Vars.subst_instance_constr u' b | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub_body c u b i x) i x in - let fix_body (c,cb,b) t = + let fix_body (c,cb,b) (t,ctx) = match cb.const_body, b with | Def b, _ -> let b = Mod_subst.force_constr b in @@ -74,25 +74,29 @@ let handle_side_effects env body side_eff = if not poly then let b_ty = Typeops.type_of_constant_type env cb.const_type in let t = sub c 1 (Vars.lift 1 t) in - mkLetIn (cname c, b, b_ty, t) + mkLetIn (cname c, b, b_ty, t), + Univ.ContextSet.union ctx + (Univ.ContextSet.of_context cb.const_universes) else let univs = cb.const_universes in - sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t) + sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t), ctx | OpaqueDef _, `Opaque (b,_) -> let poly = cb.const_polymorphic in if not poly then let b_ty = Typeops.type_of_constant_type env cb.const_type in let t = sub c 1 (Vars.lift 1 t) in - mkApp (mkLambda (cname c, b_ty, t), [|b|]) + mkApp (mkLambda (cname c, b_ty, t), [|b|]), + Univ.ContextSet.union ctx + (Univ.ContextSet.of_context cb.const_universes) else let univs = cb.const_universes in - sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t) + sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t), ctx | _ -> assert false in - List.fold_right fix_body cbl t + List.fold_right fix_body cbl (t,ctx) in (* CAVEAT: we assure a proper order *) - Declareops.fold_side_effects handle_sideff body + Declareops.fold_side_effects handle_sideff (body,ctx) (Declareops.uniquize_side_effects side_eff) let hcons_j j = @@ -120,7 +124,7 @@ let infer_declaration env kn dcl = let tyj = infer_type env typ in let proofterm = Future.chain ~greedy:true ~pure:true body (fun ((body, ctx),side_eff) -> - let body = handle_side_effects env body side_eff in + let body,ctx = handle_side_effects env body ctx side_eff in let env' = push_context_set ctx env in let j = infer env' body in let j = hcons_j j in @@ -135,14 +139,16 @@ let infer_declaration env kn dcl = c.const_entry_inline_code, c.const_entry_secctx | DefinitionEntry c -> - let env = push_context ~strict:(not c.const_entry_polymorphic) c.const_entry_universes env in let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in - assert(Univ.ContextSet.is_empty ctx); - let body = handle_side_effects env body side_eff in + let univsctx = Univ.ContextSet.of_context c.const_entry_universes in + let body, ctx = handle_side_effects env body + (Univ.ContextSet.union univsctx ctx) side_eff in + let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in - let usubst, univs = Univ.abstract_universes abstract c.const_entry_universes in + let usubst, univs = + Univ.abstract_universes abstract (Univ.ContextSet.to_context ctx) in let j = infer env body in let typ = constrain_type env j c.const_entry_polymorphic usubst (map_option_typ typ) in let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in @@ -306,5 +312,9 @@ let translate_mind env kn mie = Indtypes.check_inductive env kn mie let handle_entry_side_effects env ce = { ce with const_entry_body = Future.chain ~greedy:true ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> - (handle_side_effects env body side_eff, ctx), Declareops.no_seff); + let body, ctx' = handle_side_effects env body ctx side_eff in + (body, ctx'), Declareops.no_seff); } + +let handle_side_effects env body side_eff = + fst (handle_side_effects env body Univ.ContextSet.empty side_eff) -- cgit v1.2.3 From 11cdf7c2ca0017f6bae906f9c9d9eef41972affe Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:16:06 +0200 Subject: Univs: fix handling of side effects/delayed proofs - When there are side effects which might enrich the initial universes of a proof, keep the initial and refined universe contexts apart like for delayed proofs, ensuring universes are declared before they are used in the right order. - Fix undefined levels in proof statements so that they can't be lowered to Set by a subsequent, delayed proof. --- proofs/proof_global.ml | 6 ++---- stm/lemmas.ml | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 6c963bf705..254aa8f783 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -290,16 +290,14 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let body = c and typ = nf t in let used_univs_body = Universes.universes_of_constr body in let used_univs_typ = Universes.universes_of_constr typ in - if keep_body_ucst_separate then + if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in let ctx = Evd.evar_universe_context_set initunivs universes in (* For vi2vo compilation proofs are computed now but we need to * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) let ctx_body = restrict_universe_context ctx used_univs_body in - let ctx_typ = restrict_universe_context ctx used_univs_typ in - let univs_typ = Univ.ContextSet.to_context ctx_typ in - (univs_typ, typ), ((body, ctx_body), eff) + (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in let ctx = Evd.evar_universe_context_set initunivs universes in diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 2bd1c54519..16444fda05 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -449,7 +449,7 @@ let start_proof_com kind thms hook = let recguard,thms,snl = look_for_possibly_mutual_statements thms in let evd, nf = Evarutil.nf_evars_and_universes !evdref in let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in - start_proof_with_initialization kind evd + start_proof_with_initialization kind (Evd.fix_undefined_variables evd) recguard thms snl hook -- cgit v1.2.3 From e86b5cf5beab9a67c65afa7456feb417df9d465c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:19:36 +0200 Subject: Univs: fix Show Universes. --- toplevel/vernacentries.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index e51dfbaaec..c07c756c01 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -76,9 +76,8 @@ let show_universes () = let gls = Proof.V82.subgoals pfts in let sigma = gls.Evd.sigma in let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in - let cstrs = Univ.merge_constraints (Univ.ContextSet.constraints ctx) Univ.empty_universes in msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma)); - msg_notice (str"Normalized constraints: " ++ Univ.pr_universes (Evd.pr_evd_level sigma) cstrs) + msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx) let show_prooftree () = (* Spiwack: proof tree is currently not working *) -- cgit v1.2.3 From 6902d2bcb2840619d4c6f41a0d30948daa877b0c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:19:46 +0200 Subject: Univs/program: handle side effects in obligations. --- toplevel/obligations.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index e8682c1b58..b942034df7 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -796,9 +796,9 @@ let solve_by_tac name evi t poly ctx = let entry = Term_typing.handle_entry_side_effects env entry in let body, eff = Future.force entry.Entries.const_entry_body in assert(Declareops.side_effects_is_empty eff); - assert(Univ.ContextSet.is_empty (snd body)); + let ctx' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard (Global.env ()) (fst body); - (fst body), entry.Entries.const_entry_type, ctx' + (fst body), entry.Entries.const_entry_type, Evd.evar_universe_context ctx' let obligation_hook prg obl num auto ctx' _ gr = let obls, rem = prg.prg_obligations in -- cgit v1.2.3 From 8abdf84ad8cd82b7ea0e0b2adb97255b2f70fbb8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:20:15 +0200 Subject: Univs: correcly compute the levels of records when they fall in Prop. --- toplevel/record.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/toplevel/record.ml b/toplevel/record.ml index ee80101f3d..4a2bfaa8b0 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -131,14 +131,18 @@ let typecheck_params_and_fields def id pl t ps nots fs = Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars (Evd.empty,!evars) in let evars, nf = Evarutil.nf_evars_and_universes sigma in let arity = nf t' in - let evars = + let arity, evars = let _, univ = compute_constructor_level evars env_ar newfs in let ctx, aritysort = Reduction.dest_arity env0 arity in assert(List.is_empty ctx); (* Ensured by above analysis *) if Sorts.is_prop aritysort || (Sorts.is_set aritysort && is_impredicative_set env0) then - evars - else Evd.set_leq_sort env_ar evars (Type univ) aritysort + arity, evars + else + let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in + if Univ.is_small_univ univ then + mkArity (ctx, Sorts.sort_of_univ univ), evars + else arity, evars in let evars, nf = Evarutil.nf_evars_and_universes evars in let newps = map_rel_context nf newps in -- cgit v1.2.3 From b3132ef7d45edae5b7902077aa72cc81d1d309b8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:22:31 +0200 Subject: Fix test-suite file --- test-suite/failure/guard-cofix.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v index 64faa0ce0b..eda4a18673 100644 --- a/test-suite/failure/guard-cofix.v +++ b/test-suite/failure/guard-cofix.v @@ -25,7 +25,7 @@ Fail Definition ff : False := match loop with CF _ t => t end. (* Second example *) -Inductive omega := Omega : omega -> omega. +Inductive omega : Prop := Omega : omega -> omega. Lemma H : omega = CoFalse. Proof. -- cgit v1.2.3 From e51f708ac911f376f09297cad7d7d27510fe8990 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:30:43 +0200 Subject: Fix test-suite file: failing earlier as expected. --- test-suite/bugs/closed/3314.v | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index e63c46da04..fb3791af55 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -122,12 +122,12 @@ Definition depsort (T : Type) (x : bool) : informative x := end. (** This definition should fail *) -Definition Box (T : Type1) : Prop := Lift T. +Fail Definition Box (T : Type1) : Prop := Lift T. -Definition prop {T : Type1} (t : Box T) : T := t. -Definition wrap {T : Type1} (t : T) : Box T := t. +Fail Definition prop {T : Type1} (t : Box T) : T := t. +Fail Definition wrap {T : Type1} (t : T) : Box T := t. -Definition down (x : Type1) : Prop := Box x. +Fail Definition down (x : Type1) : Prop := Box x. Definition up (x : Prop) : Type1 := x. Fail Definition back A : up (down A) -> A := @prop A. -- cgit v1.2.3 From 96760d8516398ecfa55e4e6f808dd6aa5305e483 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 17:57:37 +0200 Subject: Fix test-suite file for bug #3777 --- test-suite/bugs/closed/3777.v | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 test-suite/bugs/closed/3777.v diff --git a/test-suite/bugs/closed/3777.v b/test-suite/bugs/closed/3777.v new file mode 100644 index 0000000000..b9b2dd6b3e --- /dev/null +++ b/test-suite/bugs/closed/3777.v @@ -0,0 +1,16 @@ +Module WithoutPoly. + Unset Universe Polymorphism. + Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. + Set Printing Universes. + Definition bla := ((@foo : Set -> _ -> _) : _ -> Type -> _). + (* ((fun A : Set => foo A):Set -> Type@{Top.55} -> Type@{Top.55}) +:Set -> Type@{Top.55} -> Type@{Top.55} + : Set -> Type@{Top.55} -> Type@{Top.55} +(* |= Set <= Top.55 + *) *) +End WithoutPoly. +Module WithPoly. + Set Universe Polymorphism. + Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. + Set Printing Universes. + Fail Check ((@foo : Set -> _ -> _) : _ -> Type -> _). -- cgit v1.2.3 From 0adf0838a59a3fbca1ced05243ccc42c969fcf18 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 17:49:33 +0200 Subject: Univs: uncovered bug in strengthening of opaque polymorphic definitions. --- kernel/modops.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/kernel/modops.ml b/kernel/modops.ml index d52fe611c0..8733ca8c2f 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -331,8 +331,10 @@ let strengthen_const mp_from l cb resolver = let kn = KerName.make2 mp_from l in let con = constant_of_delta_kn resolver kn in let u = - if cb.const_polymorphic then - Univ.UContext.instance cb.const_universes + if cb.const_polymorphic then + let u = Univ.UContext.instance cb.const_universes in + let s = Univ.make_instance_subst u in + Univ.subst_univs_level_instance s u else Univ.Instance.empty in { cb with -- cgit v1.2.3 From 856a61c1b3c5ee2b4dec08809e5e916d8954d5f8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:13:28 +0200 Subject: Univs: test-suite file for #4301, subtyping of poly parameters --- test-suite/bugs/closed/4301.v | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 test-suite/bugs/closed/4301.v diff --git a/test-suite/bugs/closed/4301.v b/test-suite/bugs/closed/4301.v new file mode 100644 index 0000000000..1a8d3611bf --- /dev/null +++ b/test-suite/bugs/closed/4301.v @@ -0,0 +1,19 @@ +Set Universe Polymorphism. + +Module Type Foo. + Parameter U : Type. +End Foo. + +(* Module Lower (X : Foo). *) +(* Definition U' : Prop := X.U@{Prop}. *) +(* End Lower. *) +(* Module Lower (X : Foo with Definition U := Prop). *) +(* Definition U' := X.U@{Prop}. *) +(* End Lower. *) +Module Lower (X : Foo with Definition U := True). + (* Definition U' : Prop := X.U. *) +End Lower. + +Module M : Foo. + Definition U := nat : Type@{i}. +End M. -- cgit v1.2.3 From 816f03befa9264cd90e57c75be93f568b90ae180 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:16:19 +0200 Subject: Univs: test-suite file for bug #2016 --- test-suite/bugs/closed/2016.v | 62 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 test-suite/bugs/closed/2016.v diff --git a/test-suite/bugs/closed/2016.v b/test-suite/bugs/closed/2016.v new file mode 100644 index 0000000000..13ec5bea9b --- /dev/null +++ b/test-suite/bugs/closed/2016.v @@ -0,0 +1,62 @@ +(* Coq 8.2beta4 *) +Require Import Classical_Prop. + +Record coreSemantics : Type := CoreSemantics { + core: Type; + corestep: core -> core -> Prop; + corestep_fun: forall q q1 q2, corestep q q1 -> corestep q q2 -> q1 = q2 +}. + +Definition state : Type := {sem: coreSemantics & sem.(core)}. + +Inductive step: state -> state -> Prop := + | step_core: forall sem st st' + (Hcs: sem.(corestep) st st'), + step (existT _ sem st) (existT _ sem st'). + +Lemma step_fun: forall st1 st2 st2', step st1 st2 -> step st1 st2' -> st2 = st2'. +Proof. +intros. +inversion H; clear H; subst. inversion H0; clear H0; subst; auto. +generalize (inj_pairT2 _ _ _ _ _ H2); clear H2; intro; subst. +rewrite (corestep_fun _ _ _ _ Hcs Hcs0); auto. +Qed. + +Record oe_core := oe_Core { + in_core: Type; + in_corestep: in_core -> in_core -> Prop; + in_corestep_fun: forall q q1 q2, in_corestep q q1 -> in_corestep q q2 -> q1 = q2; + in_q: in_core +}. + +Definition oe2coreSem (oec : oe_core) : coreSemantics := + CoreSemantics oec.(in_core) oec.(in_corestep) oec.(in_corestep_fun). + +Definition oe_corestep (q q': oe_core) := + step (existT _ (oe2coreSem q) q.(in_q)) (existT _ (oe2coreSem q') q'.(in_q)). + +Lemma inj_pairT1: forall (U: Type) (P: U -> Type) (p1 p2: U) x y, + existT P p1 x = existT P p2 y -> p1=p2. +Proof. intros; injection H; auto. +Qed. + +Definition f := CoreSemantics oe_core. + +Lemma oe_corestep_fun: forall q q1 q2, + oe_corestep q q1 -> oe_corestep q q2 -> q1 = q2. +Proof. +unfold oe_corestep; intros. +assert (HH:= step_fun _ _ _ H H0); clear H H0. +destruct q1; destruct q2; unfold oe2coreSem; simpl in *. +generalize (inj_pairT1 _ _ _ _ _ _ HH); clear HH; intros. +injection H; clear H; intros. +revert in_q1 in_corestep1 in_corestep_fun1 + H. +pattern in_core1. +apply eq_ind_r with (x := in_core0). +admit. +apply sym_eq. +(** good to here **) +Show Universes. +Print Universes. +Fail apply H0. \ No newline at end of file -- cgit v1.2.3 From 4b51494ef6fee2301766fb4a44020dc2ad95799f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:20:33 +0200 Subject: Univs: fix test-suite file for HoTT/coq bug #120 --- test-suite/bugs/closed/HoTT_coq_120.v | 138 ++++++++++++++++++++++++++++++++++ test-suite/bugs/opened/HoTT_coq_120.v | 137 --------------------------------- 2 files changed, 138 insertions(+), 137 deletions(-) create mode 100644 test-suite/bugs/closed/HoTT_coq_120.v delete mode 100644 test-suite/bugs/opened/HoTT_coq_120.v diff --git a/test-suite/bugs/closed/HoTT_coq_120.v b/test-suite/bugs/closed/HoTT_coq_120.v new file mode 100644 index 0000000000..e46ea58bb3 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_120.v @@ -0,0 +1,138 @@ +Require Import TestSuite.admit. +(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *) +Set Universe Polymorphism. +Generalizable All Variables. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. + +Class IsEquiv {A B : Type} (f : A -> B) := {}. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Notation minus_one:=(trunc_S minus_two). + +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). + +Class Funext := {}. +Inductive Unit : Set := tt. + +Instance contr_unit : Contr Unit | 0 := let x := {| + center := tt; + contr := fun t : Unit => match t with tt => idpath end + |} in x. +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. +admit. +Defined. +Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. +Definition Unit_hp:hProp:=(hp Unit _). +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Definition ismono {X Y} (f : X -> Y) + := forall Z : hSet, + forall g h : Z -> X, (fun x => f (g x)) = (fun x => f (h x)) -> g = h. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + Build_PreCategory { + object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' + }. +Arguments compose [!C s d d'] m1 m2 : rename. + +Infix "o" := compose : morphism_scope. +Local Open Scope morphism_scope. + +Class IsEpimorphism {C} {x y} (m : morphism C x y) := + is_epimorphism : forall z (m1 m2 : morphism C y z), + m1 o m = m2 o m + -> m1 = m2. + +Class IsMonomorphism {C} {x y} (m : morphism C x y) := + is_monomorphism : forall z (m1 m2 : morphism C z x), + m o m1 = m o m2 + -> m1 = m2. +Class Univalence := {}. +Global Instance isset_hProp `{Funext} : IsHSet hProp | 0. Admitted. + +Definition set_cat : PreCategory + := @Build_PreCategory hSet + (fun x y => forall _ : x, y)%core + (fun _ _ _ f g x => f (g x))%core. +Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. +Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted. +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). +Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. +Definition issurj {X Y} (f:X->Y) := forall y:Y , hexists (fun x => (f x) = y). +Lemma isepi_issurj `{fs:Funext} `{ua:Univalence} `{fs' : Funext} {X Y} (f:X->Y): isepi f -> issurj f. +Proof. + intros epif y. + set (g :=fun _:Y => Unit_hp). + set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))). + clear fs'. + hnf in epif. + specialize (epif (BuildhSet hProp _) g h). + admit. +Defined. +Definition isequiv_isepi_ismono `{Univalence, fs0 : Funext} (X Y : hSet) (f : X -> Y) (epif : isepi f) (monof : ismono f) +: IsEquiv f. +Proof. + pose proof (@isepi_issurj _ _ _ _ _ f epif) as surjf. + admit. +Defined. +Section fully_faithful_helpers. + Context `{fs0 : Funext}. + Variables x y : hSet. + Variable m : x -> y. + + Fail Let isequiv_isepi_ismono_helper ua := + (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). + + Goal True. + Fail set (isequiv_isepimorphism_ismonomorphism + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)). + admit. + Undo. + Fail set (isequiv_isepimorphism_ismonomorphism + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => ((let _ := @isequiv_isepimorphism_ismonomorphism _ Hepi Hmono in @isequiv_isepi_ismono _ fs0 x y m Hepi Hmono) + : @IsEquiv _ _ m)). + Set Printing Universes. + admit. (* Error: Universe inconsistency (cannot enforce Top.235 <= Set because Set +< Top.235). *) diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v deleted file mode 100644 index 05ee6c7b60..0000000000 --- a/test-suite/bugs/opened/HoTT_coq_120.v +++ /dev/null @@ -1,137 +0,0 @@ -Require Import TestSuite.admit. -(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *) -Set Universe Polymorphism. -Generalizable All Variables. -Reserved Notation "g 'o' f" (at level 40, left associativity). -Inductive paths {A : Type} (a : A) : A -> Type := - idpath : paths a a. -Arguments idpath {A a} , [A] a. -Notation "x = y" := (@paths _ x y) : type_scope. - -Class IsEquiv {A B : Type} (f : A -> B) := {}. - -Class Contr_internal (A : Type) := BuildContr { - center : A ; - contr : (forall y : A, center = y) - }. - -Inductive trunc_index : Type := -| minus_two : trunc_index -| trunc_S : trunc_index -> trunc_index. - -Fixpoint nat_to_trunc_index (n : nat) : trunc_index - := match n with - | 0 => trunc_S (trunc_S minus_two) - | S n' => trunc_S (nat_to_trunc_index n') - end. - -Coercion nat_to_trunc_index : nat >-> trunc_index. - -Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := - match n with - | minus_two => Contr_internal A - | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) - end. - -Notation minus_one:=(trunc_S minus_two). - -Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. - -Notation Contr := (IsTrunc minus_two). -Notation IsHProp := (IsTrunc minus_one). -Notation IsHSet := (IsTrunc 0). - -Class Funext := {}. -Inductive Unit : Set := tt. - -Instance contr_unit : Contr Unit | 0 := let x := {| - center := tt; - contr := fun t : Unit => match t with tt => idpath end - |} in x. -Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. -admit. -Defined. -Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. -Definition Unit_hp:hProp:=(hp Unit _). -Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. -Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). -Definition ismono {X Y} (f : X -> Y) - := forall Z : hSet, - forall g h : Z -> X, (fun x => f (g x)) = (fun x => f (h x)) -> g = h. - -Delimit Scope morphism_scope with morphism. -Delimit Scope category_scope with category. -Delimit Scope object_scope with object. -Record PreCategory := - Build_PreCategory { - object :> Type; - morphism : object -> object -> Type; - compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' - }. -Arguments compose [!C s d d'] m1 m2 : rename. - -Infix "o" := compose : morphism_scope. -Local Open Scope morphism_scope. - -Class IsEpimorphism {C} {x y} (m : morphism C x y) := - is_epimorphism : forall z (m1 m2 : morphism C y z), - m1 o m = m2 o m - -> m1 = m2. - -Class IsMonomorphism {C} {x y} (m : morphism C x y) := - is_monomorphism : forall z (m1 m2 : morphism C z x), - m o m1 = m o m2 - -> m1 = m2. -Class Univalence := {}. -Global Instance isset_hProp `{Funext} : IsHSet hProp | 0. Admitted. - -Definition set_cat : PreCategory - := @Build_PreCategory hSet - (fun x y => forall _ : x, y)%core - (fun _ _ _ f g x => f (g x))%core. -Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. -Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted. -Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). -Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, - forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. -Definition issurj {X Y} (f:X->Y) := forall y:Y , hexists (fun x => (f x) = y). -Lemma isepi_issurj `{fs:Funext} `{ua:Univalence} `{fs' : Funext} {X Y} (f:X->Y): isepi f -> issurj f. -Proof. - intros epif y. - set (g :=fun _:Y => Unit_hp). - set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))). - clear fs'. - hnf in epif. - specialize (epif (BuildhSet hProp _) g h). - admit. -Defined. -Definition isequiv_isepi_ismono `{Univalence, fs0 : Funext} (X Y : hSet) (f : X -> Y) (epif : isepi f) (monof : ismono f) -: IsEquiv f. -Proof. - pose proof (@isepi_issurj _ _ _ _ _ f epif) as surjf. - admit. -Defined. -Section fully_faithful_helpers. - Context `{fs0 : Funext}. - Variables x y : hSet. - Variable m : x -> y. - - Let isequiv_isepi_ismono_helper ua := (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). - - Goal True. - Fail set (isequiv_isepimorphism_ismonomorphism - := fun `{Univalence} - (Hepi : IsEpimorphism (m : morphism set_cat x y)) - (Hmono : IsMonomorphism (m : morphism set_cat x y)) - => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)). - admit. - Undo. - Fail set (isequiv_isepimorphism_ismonomorphism' - := fun `{Univalence} - (Hepi : IsEpimorphism (m : morphism set_cat x y)) - (Hmono : IsMonomorphism (m : morphism set_cat x y)) - => ((let _ := @isequiv_isepimorphism_ismonomorphism _ Hepi Hmono in @isequiv_isepi_ismono _ fs0 x y m Hepi Hmono) - : @IsEquiv _ _ m)). - Set Printing Universes. - admit. (* Error: Universe inconsistency (cannot enforce Top.235 <= Set because Set -< Top.235). *) -- cgit v1.2.3 From 2dc998e153922fffa907342871917963ad421e45 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:30:03 +0200 Subject: Univs: fix evar_map handling in Hint processing. --- tactics/extratactics.ml4 | 8 +++----- tactics/hints.ml | 4 +++- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index ead26e964f..a72c6ab51e 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -268,11 +268,9 @@ let add_rewrite_hint bases ort t lcsr = let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in let ctx = - if poly then - Evd.evar_universe_context_set Univ.UContext.empty ctx - else - let cstrs = Evd.evar_universe_context_constraints ctx in - (Global.add_constraints cstrs; Univ.ContextSet.empty) + let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in + if poly then ctx + else (Global.push_context_set ctx; Univ.ContextSet.empty) in Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in let eqs = List.map f lcsr in diff --git a/tactics/hints.ml b/tactics/hints.ml index 48b4505327..a7eae667d0 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1085,8 +1085,10 @@ let prepare_hint check env init (sigma,c) = let interp_hints poly = fun h -> + let env = (Global.env()) in + let sigma = Evd.from_env env in let f c = - let evd,c = Constrintern.interp_open_constr (Global.env()) Evd.empty c in + let evd,c = Constrintern.interp_open_constr env sigma c in prepare_hint true (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in -- cgit v1.2.3 From e5cbf1ef44449f60eec3bb3c52d08b2943283279 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:30:44 +0200 Subject: Univs: fix subtyping of polymorphic parameters. --- kernel/subtyping.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index db155e6c86..463e28a1c6 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -311,9 +311,12 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = try (* The environment with the expected universes plus equality of the body instances with the expected instance *) - let env = Environ.add_constraints cstrs env in - (* Check that the given definition does not add any constraint over - the expected ones, so that it can be used in place of the original. *) + let ctxi = Univ.Instance.append inst1 inst2 in + let ctx = Univ.UContext.make (ctxi, cstrs) in + let env = Environ.push_context ctx env in + (* Check that the given definition does not add any constraint over + the expected ones, so that it can be used in place of + the original. *) if Univ.check_constraints ctx1 (Environ.universes env) then cstrs, env, inst2 else error (IncompatibleConstraints ctx1) -- cgit v1.2.3 From 42dd4e73346e29db2fe586234b00ca79bd207a5a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:31:17 +0200 Subject: Univs: fix inference of the lowest sort for records. --- toplevel/record.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/toplevel/record.ml b/toplevel/record.ml index 4a2bfaa8b0..60fe76bb82 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -141,7 +141,10 @@ let typecheck_params_and_fields def id pl t ps nots fs = else let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in if Univ.is_small_univ univ then - mkArity (ctx, Sorts.sort_of_univ univ), evars + (* We can assume that the level aritysort is not constrained + and clear it. *) + mkArity (ctx, Sorts.sort_of_univ univ), + Evd.set_eq_sort env_ar evars (Prop Pos) aritysort else arity, evars in let evars, nf = Evarutil.nf_evars_and_universes evars in -- cgit v1.2.3 From 62e6f7e37512e523eafe65e6a58369361e74d4d5 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:32:23 +0200 Subject: Univs: fix minimization to allow lowering a universe to Set, not Prop. --- library/universes.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/library/universes.ml b/library/universes.ml index 0133f5deb6..9bc21b0e55 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -834,8 +834,10 @@ let normalize_context_set ctx us algs = if Univ.Level.is_small l then (Constraint.add cstr smallles, noneqs) else if Level.is_small r then - raise (Univ.UniverseInconsistency - (Le,Universe.make l,Universe.make r,None)) + if Level.is_prop r then + raise (Univ.UniverseInconsistency + (Le,Universe.make l,Universe.make r,None)) + else (smallles, Constraint.add (l,Eq,r) noneqs) else (smallles, Constraint.add cstr noneqs) else (smallles, Constraint.add cstr noneqs)) csts (Constraint.empty, Constraint.empty) @@ -850,13 +852,13 @@ let normalize_context_set ctx us algs = Univ.Constraint.fold (fun (l, d, r) g -> let g = if not (Level.is_small l || LSet.mem l ctx) then - try Univ.add_universe l true g + try Univ.add_universe l false g with Univ.AlreadyDeclared -> g else g in let g = if not (Level.is_small r || LSet.mem r ctx) then - try Univ.add_universe r true g + try Univ.add_universe r false g with Univ.AlreadyDeclared -> g else g in g) csts g -- cgit v1.2.3 From b8a85b65432a974d6a6f1fe5165e05d7196c9321 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:33:27 +0200 Subject: Univs: fix semantics of Type in proof mode in universe-polymorphic mode Allowing universes to be instantiated if the body of the proof requires it (the levels stay flexible). Not allowed for non-polymorphic cases, to be compatible with the stm's invariant that the type should not change. --- stm/lemmas.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 16444fda05..5cbe152b55 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -449,8 +449,12 @@ let start_proof_com kind thms hook = let recguard,thms,snl = look_for_possibly_mutual_statements thms in let evd, nf = Evarutil.nf_evars_and_universes !evdref in let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in - start_proof_with_initialization kind (Evd.fix_undefined_variables evd) - recguard thms snl hook + let evd = + if pi2 kind then evd + else (* We fix the variables to ensure they won't be lowered to Set *) + Evd.fix_undefined_variables evd + in + start_proof_with_initialization kind evd recguard thms snl hook (* Saving a proof *) -- cgit v1.2.3 From 13337793ea7f709eaa50965797e4f79a3aa51a2b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:35:44 +0200 Subject: Univs: fix handling of evd's universes and side effects in build_by_tactic --- proofs/pfedit.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 05a2975458..00ef8ecafd 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -152,9 +152,9 @@ let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in let ce = if side_eff then Term_typing.handle_entry_side_effects env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun (pt, _) -> pt, Declareops.no_seff) } in let (cb, ctx), se = Future.force ce.const_entry_body in + let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in assert(Declareops.side_effects_is_empty se); - assert(Univ.ContextSet.is_empty ctx); - cb, status, univs + cb, status, Evd.evar_universe_context univs' let refine_by_tactic env sigma ty tac = (** Save the initial side-effects to restore them afterwards. We set the -- cgit v1.2.3 From 07e96102047f55be45bcb2e0a72ac3c764e398b1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:40:20 +0200 Subject: Univs: minor fixes to test-suite files 108 used an implicit lowering to Prop. --- test-suite/bugs/closed/HoTT_coq_053.v | 2 +- test-suite/bugs/closed/HoTT_coq_093.v | 2 +- test-suite/bugs/closed/HoTT_coq_108.v | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/test-suite/bugs/closed/HoTT_coq_053.v b/test-suite/bugs/closed/HoTT_coq_053.v index a14fb6aa57..e2bf1dbedb 100644 --- a/test-suite/bugs/closed/HoTT_coq_053.v +++ b/test-suite/bugs/closed/HoTT_coq_053.v @@ -39,7 +39,7 @@ Definition NatCategory (n : nat) := Definition NatCategory' (n : nat) := match n with | 0 => (fun X => @Build_PreCategory X - (fun _ _ => Unit : Prop)) Unit + (fun _ _ => Unit : Set)) Unit | _ => DiscreteCategory Bool end. diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v index 38943ab353..f382dac976 100644 --- a/test-suite/bugs/closed/HoTT_coq_093.v +++ b/test-suite/bugs/closed/HoTT_coq_093.v @@ -21,7 +21,7 @@ Section lift. Definition Lift (A : Type@{i}) : Type@{j} := A. End lift. -Goal forall (A : Type@{i}) (x y : A), @paths@{i} A x y -> @paths@{j} A x y. +Goal forall (A : Type@{i}) (x y : A), @paths@{i j} A x y -> @paths@{j k} A x y. intros A x y p. compute in *. destruct p. exact idpath. Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v index 4f5ef99740..b6c0da76ba 100644 --- a/test-suite/bugs/closed/HoTT_coq_108.v +++ b/test-suite/bugs/closed/HoTT_coq_108.v @@ -107,7 +107,7 @@ Section path_functor. Variable D : PreCategory. Local Notation path_functor'_T F G := { HO : object_of F = object_of G - | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) + & transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) HO (morphism_of F) = morphism_of G } -- cgit v1.2.3 From 67bdc25eb69ecd485ae1c8fa2dd71d1933f355d0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 19:05:47 +0200 Subject: Univs: fixed 3685 by side-effect :) --- test-suite/bugs/closed/3685.v | 75 +++++++++++++++++++++++++++++++++++++++++++ test-suite/bugs/opened/3685.v | 75 ------------------------------------------- 2 files changed, 75 insertions(+), 75 deletions(-) create mode 100644 test-suite/bugs/closed/3685.v delete mode 100644 test-suite/bugs/opened/3685.v diff --git a/test-suite/bugs/closed/3685.v b/test-suite/bugs/closed/3685.v new file mode 100644 index 0000000000..a5bea34a98 --- /dev/null +++ b/test-suite/bugs/closed/3685.v @@ -0,0 +1,75 @@ +Require Import TestSuite.admit. +Set Universe Polymorphism. +Class Funext := { }. +Delimit Scope category_scope with category. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Set Implicit Arguments. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall s m, morphism_of s s m = morphism_of s s m }. +Definition sub_pre_cat `{Funext} (P : PreCategory -> Type) : PreCategory. +Proof. + exact (@Build_PreCategory PreCategory Functor). +Defined. +Definition opposite (C : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory C (fun s d => morphism C d s)). +Defined. +Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition prod (C D : PreCategory) : PreCategory. +Proof. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). +Defined. +Local Infix "*" := prod : category_scope. +Record NaturalTransformation C D (F G : Functor C D) := {}. +Definition functor_category (C D : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory (Functor C D) (@NaturalTransformation C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Module Export PointwiseCore. + Local Open Scope category_scope. + Definition pointwise + (C C' : PreCategory) + (F : Functor C' C) + (D D' : PreCategory) + (G : Functor D D') + : Functor (C -> D) (C' -> D'). + Proof. + refine (Build_Functor + (C -> D) (C' -> D') + _ + _ + _); + abstract admit. + Defined. +End PointwiseCore. +Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. +Local Open Scope category_scope. +Module Success. + Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). +End Success. +Module Bad. + Include PointwiseCore. + Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v deleted file mode 100644 index b2b5db6be7..0000000000 --- a/test-suite/bugs/opened/3685.v +++ /dev/null @@ -1,75 +0,0 @@ -Require Import TestSuite.admit. -Set Universe Polymorphism. -Class Funext := { }. -Delimit Scope category_scope with category. -Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. -Set Implicit Arguments. -Record Functor (C D : PreCategory) := - { object_of :> C -> D; - morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); - identity_of : forall s m, morphism_of s s m = morphism_of s s m }. -Definition sub_pre_cat `{Funext} (P : PreCategory -> Type) : PreCategory. -Proof. - exact (@Build_PreCategory PreCategory Functor). -Defined. -Definition opposite (C : PreCategory) : PreCategory. -Proof. - exact (@Build_PreCategory C (fun s d => morphism C d s)). -Defined. -Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. -Definition prod (C D : PreCategory) : PreCategory. -Proof. - refine (@Build_PreCategory - (C * D)%type - (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). -Defined. -Local Infix "*" := prod : category_scope. -Record NaturalTransformation C D (F G : Functor C D) := {}. -Definition functor_category (C D : PreCategory) : PreCategory. -Proof. - exact (@Build_PreCategory (Functor C D) (@NaturalTransformation C D)). -Defined. -Local Notation "C -> D" := (functor_category C D) : category_scope. -Module Export PointwiseCore. - Local Open Scope category_scope. - Definition pointwise - (C C' : PreCategory) - (F : Functor C' C) - (D D' : PreCategory) - (G : Functor D D') - : Functor (C -> D) (C' -> D'). - Proof. - refine (Build_Functor - (C -> D) (C' -> D') - _ - _ - _); - abstract admit. - Defined. -End PointwiseCore. -Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. -Local Open Scope category_scope. -Module Success. - Definition functor_uncurried `{Funext} (P : PreCategory -> Type) - (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) - : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) - := Eval cbv zeta in - let object_of := (fun CD => (((fst CD) -> (snd CD)))) - in Build_Functor - ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) - object_of - (fun CD C'D' FG => pointwise (fst FG) (snd FG)) - (fun _ _ => @Pidentity_of _ _ _ _). -End Success. -Module Bad. - Include PointwiseCore. - Fail Definition functor_uncurried `{Funext} (P : PreCategory -> Type) - (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) - : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) - := Eval cbv zeta in - let object_of := (fun CD => (((fst CD) -> (snd CD)))) - in Build_Functor - ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) - object_of - (fun CD C'D' FG => pointwise (fst FG) (snd FG)) - (fun _ _ => @Pidentity_of _ _ _ _). -- cgit v1.2.3 From c1630c9dcdf91dc965b3c375d68e3338fb737531 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 13:32:47 +0200 Subject: Univs: update checker --- checker/cic.mli | 2 +- checker/environ.ml | 19 +++++++++++++------ checker/environ.mli | 2 ++ checker/mod_checking.ml | 2 +- checker/modops.ml | 7 ++++--- checker/safe_typing.ml | 4 ++-- checker/univ.ml | 47 +++++++++++++++++++++++++++++++++++++++++++---- checker/univ.mli | 15 ++++++++++++++- checker/values.ml | 6 +++--- 9 files changed, 83 insertions(+), 21 deletions(-) diff --git a/checker/cic.mli b/checker/cic.mli index 881d3ca797..bd75111a2c 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -380,7 +380,7 @@ and module_body = (** algebraic type, kept if it's relevant for extraction *) mod_type_alg : module_expression option; (** set of all constraints in the module *) - mod_constraints : Univ.constraints; + mod_constraints : Univ.ContextSet.t; (** quotiented set of equivalent constants and inductive names *) mod_delta : delta_resolver; mod_retroknowledge : action list } diff --git a/checker/environ.ml b/checker/environ.ml index 6dbc44d6b8..f8f5c29b79 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -84,13 +84,20 @@ let push_rec_types (lna,typarray,_) env = Array.fold_left (fun e assum -> push_rel assum e) env ctxt (* Universe constraints *) -let add_constraints c env = - if c == Univ.Constraint.empty then - env - else - let s = env.env_stratification in +let map_universes f env = + let s = env.env_stratification in { env with env_stratification = - { s with env_universes = Univ.merge_constraints c s.env_universes } } + { s with env_universes = f s.env_universes } } + +let add_constraints c env = + if c == Univ.Constraint.empty then env + else map_universes (Univ.merge_constraints c) env + +let push_context ?(strict=false) ctx env = + map_universes (Univ.merge_context strict ctx) env + +let push_context_set ?(strict=false) ctx env = + map_universes (Univ.merge_context_set strict ctx) env let check_constraints cst env = Univ.check_constraints cst env.env_stratification.env_universes diff --git a/checker/environ.mli b/checker/environ.mli index f3b2dd839a..87f143d1bb 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -39,6 +39,8 @@ val push_rec_types : name array * constr array * 'a -> env -> env (* Universes *) val universes : env -> Univ.universes val add_constraints : Univ.constraints -> env -> env +val push_context : ?strict:bool -> Univ.universe_context -> env -> env +val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env val check_constraints : Univ.constraints -> env -> bool (* Constants *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 998e23c6e8..78fff1bbe6 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -69,7 +69,7 @@ let mk_mtb mp sign delta = mod_expr = Abstract; mod_type = sign; mod_type_alg = None; - mod_constraints = Univ.Constraint.empty; + mod_constraints = Univ.ContextSet.empty; mod_delta = delta; mod_retroknowledge = []; } diff --git a/checker/modops.ml b/checker/modops.ml index 8ccf118d3b..7f07f8bf84 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -83,12 +83,13 @@ let strengthen_const mp_from l cb resolver = | Def _ -> cb | _ -> let con = Constant.make2 mp_from l in - (* let con = constant_of_delta resolver con in*) let u = - if cb.const_polymorphic then Univ.UContext.instance cb.const_universes + if cb.const_polymorphic then + Univ.make_abstract_instance cb.const_universes else Univ.Instance.empty in - { cb with const_body = Def (Declarations.from_val (Const (con,u))) } + { cb with + const_body = Def (Declarations.from_val (Const (con,u))) } let rec strengthen_mod mp_from mp_to mb = if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index dd94823135..d3bc8373a5 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -27,7 +27,7 @@ let set_engagement c = (* full_add_module adds module with universes and constraints *) let full_add_module dp mb univs digest = let env = !genv in - let env = add_constraints mb.mod_constraints env in + let env = push_context_set ~strict:true mb.mod_constraints env in let env = add_constraints univs env in let env = Modops.add_module mb env in genv := add_digest env dp digest @@ -84,7 +84,7 @@ let import file clib univs digest = let mb = clib.comp_mod in Mod_checking.check_module (add_constraints univs - (add_constraints mb.mod_constraints env)) mb.mod_mp mb; + (push_context_set ~strict:true mb.mod_constraints env)) mb.mod_mp mb; stamp_library file digest; full_add_module clib.comp_name mb univs digest diff --git a/checker/univ.ml b/checker/univ.ml index 3bcb3bc950..50c0367bb6 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -244,7 +244,8 @@ module Level = struct let set = make Set let prop = make Prop - + let var i = make (Var i) + let is_small x = match data x with | Level _ -> false @@ -281,8 +282,8 @@ module Level = struct end (** Level sets and maps *) -module LSet = Set.Make (Level) -module LMap = Map.Make (Level) +module LMap = HMap.Make (Level) +module LSet = LMap.Set type 'a universe_map = 'a LMap.t @@ -559,6 +560,8 @@ let repr g u = in repr_rec u +let get_set_arc g = repr g Level.set + (* [safe_repr] also search for the canonical representative, but if the graph doesn't contain the searched universe, we add it. *) @@ -573,6 +576,24 @@ let safe_repr g u = let can = terminal u in enter_arc can g, can +exception AlreadyDeclared + +let add_universe vlev strict g = + try + let _arcv = UMap.find vlev g in + raise AlreadyDeclared + with Not_found -> + let v = terminal vlev in + let arc = + let arc = get_set_arc g in + if strict then + { arc with lt=vlev::arc.lt} + else + { arc with le=vlev::arc.le} + in + let g = enter_arc arc g in + enter_arc v g + (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) let reprleq g arcu = @@ -970,7 +991,7 @@ module Constraint = Set.Make(UConstraintOrd) let empty_constraint = Constraint.empty let merge_constraints c g = Constraint.fold enforce_constraint c g - + type constraints = Constraint.t (** A value with universe constraints. *) @@ -1158,6 +1179,7 @@ struct type t = LSet.t constrained let empty = LSet.empty, Constraint.empty let constraints (_, cst) = cst + let levels (ctx, _) = ctx end type universe_context_set = ContextSet.t @@ -1207,6 +1229,9 @@ let subst_instance_constraints s csts = (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) csts Constraint.empty +let make_abstract_instance (ctx, _) = + Array.mapi (fun i l -> Level.var i) ctx + (** Substitute instance inst for ctx in csts *) let instantiate_univ_context (ctx, csts) = (ctx, subst_instance_constraints ctx csts) @@ -1238,6 +1263,20 @@ let subst_univs_universe fn ul = List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) substs nosubst +let merge_context strict ctx g = + let g = Array.fold_left + (* Be lenient, module typing reintroduces universes and + constraints due to includes *) + (fun g v -> try add_universe v strict g with AlreadyDeclared -> g) + g (UContext.instance ctx) + in merge_constraints (UContext.constraints ctx) g + +let merge_context_set strict ctx g = + let g = LSet.fold + (fun v g -> try add_universe v strict g with AlreadyDeclared -> g) + (ContextSet.levels ctx) g + in merge_constraints (ContextSet.constraints ctx) g + (** Pretty-printing *) let pr_arc = function diff --git a/checker/univ.mli b/checker/univ.mli index 742ef91aed..459adfcd6d 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -74,6 +74,13 @@ val check_eq : universe check_function (** The initial graph of universes: Prop < Set *) val initial_universes : universes +(** Adds a universe to the graph, ensuring it is >= or > Set. + @raises AlreadyDeclared if the level is already declared in the graph. *) + +exception AlreadyDeclared + +val add_universe : universe_level -> bool -> universes -> universes + (** {6 Constraints. } *) type constraint_type = Lt | Le | Eq @@ -117,7 +124,7 @@ type univ_inconsistency = constraint_type * universe * universe exception UniverseInconsistency of univ_inconsistency val merge_constraints : constraints -> universes -> universes - + val check_constraints : constraints -> universes -> bool (** {6 Support for universe polymorphism } *) @@ -193,6 +200,9 @@ module ContextSet : type universe_context = UContext.t type universe_context_set = ContextSet.t +val merge_context : bool -> universe_context -> universes -> universes +val merge_context_set : bool -> universe_context_set -> universes -> universes + val empty_level_subst : universe_level_subst val is_empty_level_subst : universe_level_subst -> bool @@ -219,6 +229,9 @@ val subst_instance_constraints : universe_instance -> constraints -> constraints val instantiate_univ_context : universe_context -> universe_context val instantiate_univ_constraints : universe_instance -> universe_context -> constraints +(** Build the relative instance corresponding to the context *) +val make_abstract_instance : universe_context -> universe_instance + (** {6 Pretty-printing of universes. } *) val pr_universes : universes -> Pp.std_ppcmds diff --git a/checker/values.ml b/checker/values.ml index 45220bd051..34de511c8a 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 8b7e75b4b94a2d8506a62508e0374c0a checker/cic.mli +MD5 76312d06933f47498a1981a6261c9f75 checker/cic.mli *) @@ -307,10 +307,10 @@ and v_impl = and v_noimpl = v_enum "no_impl" 1 (* Abstract is mandatory for mtb *) and v_module = Tuple ("module_body", - [|v_mp;v_impl;v_sign;Opt v_mexpr;v_cstrs;v_resolver;Any|]) + [|v_mp;v_impl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) and v_modtype = Tuple ("module_type_body", - [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_cstrs;v_resolver;Any|]) + [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) (** kernel/safe_typing *) -- cgit v1.2.3 From b3d97c2147418f44fc704807d3812b04921591af Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 15:36:57 +0200 Subject: Univs: fix bug #4251, handling of template polymorphic constants. --- kernel/inductive.ml | 5 ++++- kernel/univ.ml | 4 ++++ kernel/univ.mli | 3 +++ pretyping/pretyping.ml | 2 +- test-suite/bugs/closed/4251.v | 17 +++++++++++++++++ 5 files changed, 29 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/4251.v diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 87c139f48d..a02d5e2055 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -165,7 +165,10 @@ let rec make_subst env = (* to be greater than the level of the argument; this is probably *) (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in - make (cons_subst u s subst) (sign, exp, args) + if Univ.Universe.is_levels s then + make (cons_subst u s subst) (sign, exp, args) + else (* Cannot handle substitution by i+n universes. *) + make subst (sign, exp, args) | (na,None,t)::sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) (* substitution (when [u] is distinct from all other universes in the *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 782778d09f..73d323426b 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -553,6 +553,10 @@ struct | Cons (l, _, Nil) -> Expr.is_level l | _ -> false + let rec is_levels l = match l with + | Cons (l, _, r) -> Expr.is_level l && is_levels r + | Nil -> true + let level l = match l with | Cons (l, _, Nil) -> Expr.level l | _ -> None diff --git a/kernel/univ.mli b/kernel/univ.mli index ad33d597ea..4cc8a2528f 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -91,6 +91,9 @@ sig val is_level : t -> bool (** Test if the universe is a level or an algebraic universe. *) + val is_levels : t -> bool + (** Test if the universe is a lub of levels or contains +n's. *) + val level : t -> Level.t option (** Try to get a level out of a universe, returns [None] if it is an algebraic universe. *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index edb76e52f4..f18657da82 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -645,7 +645,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ match evar_kind_of_term !evdref resj.uj_val with | App (f,args) -> let f = whd_evar !evdref f in - if isInd f && is_template_polymorphic env f then + if is_template_polymorphic env f then (* Special case for inductive type applications that must be refreshed right away. *) let sigma = !evdref in diff --git a/test-suite/bugs/closed/4251.v b/test-suite/bugs/closed/4251.v new file mode 100644 index 0000000000..66343d6671 --- /dev/null +++ b/test-suite/bugs/closed/4251.v @@ -0,0 +1,17 @@ + +Inductive array : Type -> Type := +| carray : forall A, array A. + +Inductive Mtac : Type -> Prop := +| bind : forall {A B}, Mtac A -> (A -> Mtac B) -> Mtac B +| array_make : forall {A}, A -> Mtac (array A). + +Definition Ref := array. + +Definition ref : forall {A}, A -> Mtac (Ref A) := + fun A x=> array_make x. +Check array Type. +Check fun A : Type => Ref A. + +Definition abs_val (a : Type) := + bind (ref a) (fun r : array Type => array_make tt). \ No newline at end of file -- cgit v1.2.3 From 90a2126b2fb2738a7684864e74e0d1ed3c861a98 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 15:41:30 +0200 Subject: Univs: the stdlib now needs 5 universes Prop < Set < i for every global univ i --- test-suite/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/Makefile b/test-suite/Makefile index 39c36d5414..31b2129001 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -388,7 +388,7 @@ misc/deps-order.log: } > "$@" # Sort universes for the whole standard library -EXPECTED_UNIVERSES := 3 +EXPECTED_UNIVERSES := 5 universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" -- cgit v1.2.3 From d4869e059bfb73d99e1f5ef1b0a1f0906fa27056 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 15:40:17 +0200 Subject: Univs: correct handling of with in modules For polymorphic and non-polymorphic parameters and definitions, fixes bugs #4298, #4294 --- kernel/mod_typing.ml | 73 ++++++++++++++++++++++++++++++------------- kernel/subtyping.ml | 4 ++- test-suite/bugs/closed/4294.v | 31 ++++++++++++++++++ test-suite/bugs/closed/4298.v | 7 +++++ 4 files changed, 93 insertions(+), 22 deletions(-) create mode 100644 test-suite/bugs/closed/4294.v create mode 100644 test-suite/bugs/closed/4298.v diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 7da0958eaf..3be89afbde 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -72,33 +72,64 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) - let ccst = Declareops.constraints_of_constant (opaque_tables env) cb in - let env' = Environ.add_constraints ccst env' in - let newus, cst = Univ.UContext.dest ctx in - let ctxs = Univ.ContextSet.of_context ctx in - let env' = Environ.add_constraints cst env' in - let c',ctx' = match cb.const_body with - | Undef _ | OpaqueDef _ -> - let j = Typeops.infer env' c in - let typ = Typeops.type_of_constant_type env' cb.const_type in - let cst' = Reduction.infer_conv_leq env' (Environ.universes env') - j.uj_type typ in - j.uj_val, Univ.ContextSet.add_constraints cst' ctxs - | Def cs -> - let cst' = Reduction.infer_conv env' (Environ.universes env') c - (Mod_subst.force_constr cs) in - let cst = (*FIXME MS: what to check here? subtyping of polymorphic constants... *) - (* if cb.const_polymorphic then *)Univ.ContextSet.add_constraints cst' ctxs - (* else cst' +++ cst *) + let uctx = Declareops.universes_of_constant (opaque_tables env) cb in + let uctx = (* Context of the spec *) + if cb.const_polymorphic then + Univ.instantiate_univ_context uctx + else uctx + in + let c', univs, ctx' = + if not cb.const_polymorphic then + let env' = Environ.push_context ~strict:true uctx env' in + let env' = Environ.push_context ~strict:true ctx env' in + let c',cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + let typ = Typeops.type_of_constant_type env' cb.const_type in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + j.uj_val, cst' + | Def cs -> + let c' = Mod_subst.force_constr cs in + c, Reduction.infer_conv env' (Environ.universes env') c c' + in c', ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) + else + let cus, ccst = Univ.UContext.dest uctx in + let newus, cst = Univ.UContext.dest ctx in + let () = + if not (Univ.Instance.length cus == Univ.Instance.length newus) then + error_incorrect_with_constraint lab + in + let inst = Univ.Instance.append cus newus in + let csti = Univ.enforce_eq_instances cus newus cst in + let csta = Univ.Constraint.union csti ccst in + let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in + let () = if not (Univ.check_constraints cst (Environ.universes env')) then + error_incorrect_with_constraint lab + in + let cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + let typ = Typeops.type_of_constant_type env' cb.const_type in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + cst' + | Def cs -> + let c' = Vars.subst_instance_constr cus (Mod_subst.force_constr cs) in + let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in + cst' in - c, cst + if not (Univ.Constraint.is_empty cst) then + error_incorrect_with_constraint lab; + let subst, ctx = Univ.abstract_universes true ctx in + Vars.subst_univs_level_constr subst c, ctx, Univ.ContextSet.empty in let def = Def (Mod_subst.from_val c') in let cb' = { cb with const_body = def; - const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' def); - const_universes = Univ.ContextSet.to_context ctx' } + const_universes = univs; + const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 463e28a1c6..58f3bcdf00 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -322,7 +322,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = else error (IncompatibleConstraints ctx1) with Univ.UniverseInconsistency incon -> error (IncompatibleUniverses incon) - else cst, env, Univ.Instance.empty + else + cst, env, Univ.Instance.empty in (* Now check types *) let typ1 = Typeops.type_of_constant_type env' cb1.const_type in @@ -459,6 +460,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = let check_subtypes env sup super = let env = add_module_type sup.mod_mp sup env in + let env = Environ.push_context_set ~strict:true super.mod_constraints env in check_modtypes Univ.Constraint.empty env (strengthen sup sup.mod_mp) super empty_subst (map_mp super.mod_mp sup.mod_mp sup.mod_delta) false diff --git a/test-suite/bugs/closed/4294.v b/test-suite/bugs/closed/4294.v new file mode 100644 index 0000000000..1d5e3c71b8 --- /dev/null +++ b/test-suite/bugs/closed/4294.v @@ -0,0 +1,31 @@ +Require Import Hurkens. + +Module NonPoly. +Module Type Foo. + Definition U := Type. + Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type. + Definition U := Type. + Definition eq : Type = U := eq_refl. +End M. + +Print Universes. +Fail Definition bad : False := TypeNeqSmallType.paradox M.U M.eq. +End NonPoly. + +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type. + Monomorphic Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type. + Definition U := Type. + Monomorphic Definition eq : Type = U := eq_refl. +End M. + +Fail Definition bad : False := TypeNeqSmallType.paradox Type M.eq. +(* Print Assumptions bad. *) diff --git a/test-suite/bugs/closed/4298.v b/test-suite/bugs/closed/4298.v new file mode 100644 index 0000000000..875612ddf4 --- /dev/null +++ b/test-suite/bugs/closed/4298.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type. +End Foo. + +Fail Module M : Foo with Definition U := Prop. -- cgit v1.2.3 From 1d01533266b247cbc32903935963674acf7c6c54 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:05:48 +0200 Subject: Univs: forgot a substitution in mod_typing. --- kernel/mod_typing.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 3be89afbde..922652287b 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -111,6 +111,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in + let typ = Vars.subst_instance_constr cus typ in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in cst' -- cgit v1.2.3 From b144ef5e2698932c5b2f7cdb1688a55ce4764dae Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:24:54 +0200 Subject: Fix after rebase... --- toplevel/auto_ind_decl.ml | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 009e423e4f..8ac273c84f 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -764,16 +764,10 @@ let make_lb_scheme mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in -<<<<<<< HEAD - let ctx = Evd.empty_evar_universe_context in + let ctx = Evd.make_evar_universe_context (Global.env ()) None in let side_eff = side_effect_of_mode mode in let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) -======= - let ctx = Evd.make_evar_universe_context (Global.env ()) None in - let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx lb_goal - (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) ->>>>>>> Univs: fix environment handling in scheme building. in ([|ans|], ctx), eff -- cgit v1.2.3 From f4db3d72abc1872839bcacd3b28a439e69d0a2e8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:41:23 +0200 Subject: Univs: fix test-suite file (4301 is invalid, but a good regression test) --- test-suite/bugs/closed/4301.v | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/test-suite/bugs/closed/4301.v b/test-suite/bugs/closed/4301.v index 1a8d3611bf..3b00efb213 100644 --- a/test-suite/bugs/closed/4301.v +++ b/test-suite/bugs/closed/4301.v @@ -4,14 +4,7 @@ Module Type Foo. Parameter U : Type. End Foo. -(* Module Lower (X : Foo). *) -(* Definition U' : Prop := X.U@{Prop}. *) -(* End Lower. *) -(* Module Lower (X : Foo with Definition U := Prop). *) -(* Definition U' := X.U@{Prop}. *) -(* End Lower. *) -Module Lower (X : Foo with Definition U := True). - (* Definition U' : Prop := X.U. *) +Module Lower (X : Foo with Definition U := True : Type). End Lower. Module M : Foo. -- cgit v1.2.3 From cbcf55ca44b5374f39979ced88061c82c03901b3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:42:39 +0200 Subject: Univs: Remove test-suite file #3309 This relied on universes lower than Prop. A proper test for the sharing option should be found, -type-in-type is not enough either. --- test-suite/bugs/closed/3309.v | 334 ------------------------------------------ 1 file changed, 334 deletions(-) delete mode 100644 test-suite/bugs/closed/3309.v diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v deleted file mode 100644 index 6e97ed2afe..0000000000 --- a/test-suite/bugs/closed/3309.v +++ /dev/null @@ -1,334 +0,0 @@ -Require Import TestSuite.admit. -(* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *) -(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *) -Set Universe Polymorphism. -Record sigT' {A} (P : A -> Type) := existT' { projT1' : A; projT2' : P projT1' }. -Notation "{ x : A &' P }" := (sigT' (A := A) (fun x => P)) : type_scope. -Arguments existT' {A} P _ _. -Axiom admit : forall {T}, T. -Notation paths := identity . - -Unset Automatic Introduction. - -Definition UU := Set. - -Definition dirprod ( X Y : UU ) := sigT' ( fun x : X => Y ) . -Definition dirprodpair { X Y : UU } := existT' ( fun x : X => Y ) . - -Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P. -Proof. - intros X Y P xp yp X0 . - set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) . - apply ( xp ( int1 yp ) ) . -Defined . -Definition weq ( X Y : UU ) : UU . -intros; exact ( sigT' (fun f:X->Y => admit) ). -Defined. -Definition pr1weq ( X Y : UU):= @projT1' _ _ : weq X Y -> (X -> Y). -Coercion pr1weq : weq >-> Funclass. - -Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X . -admit. -Defined. - -Definition hProp := sigT' (fun X : Type => admit). - -Definition hProppair ( X : UU ) ( is : admit ) : hProp@{i j Set k}. -intros; exact (existT' (fun X : UU => admit ) X is ). -Defined. -Definition hProptoType := @projT1' _ _ : hProp -> Type . -Coercion hProptoType: hProp >-> Sortclass. - -Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ). - -Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit. - -Definition hinhfun { X Y : UU } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y. -intros X Y f; exact ( fun isx : ishinh X => fun P : _ => fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) ). -Defined. - -Definition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P. -intros; exact ( wit P f ). -Defined. - -Definition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ). -intros; exact ( fun P:_ => ddualand (inx1 P) (iny1 P)) . -Defined. - -Definition UU' := Type. -Definition hSet:= sigT' (fun X : UU' => admit) . -Definition hSetpair := existT' (fun X : UU' => admit). -Definition pr1hSet:= @projT1' UU (fun X : UU' => admit) : hSet -> Type. -Coercion pr1hSet: hSet >-> Sortclass. - -Definition hPropset : hSet := existT' _ hProp admit . - -Definition hsubtypes ( X : UU ) : Type. -intros; exact (X -> hProp ). -Defined. -Definition carrier { X : UU } ( A : hsubtypes X ) : Type. -intros; exact (sigT' A). -Defined. -Coercion carrier : hsubtypes >-> Sortclass. - -Definition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ). -admit. -Defined. - -Lemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) . - admit. -Defined. - -Lemma ishinhsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) . -Proof . - intros . - apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) . - apply hinhand . - apply isa . - apply isb . -Defined . - -Definition hrel ( X : UU ) : Type. -intros; exact ( X -> X -> hProp). -Defined. - -Definition iseqrel { X : UU } ( R : hrel X ) : Type. -admit. -Defined. - -Definition eqrel ( X : UU ) : Type. -intros; exact ( sigT' ( fun R : hrel X => iseqrel R ) ). -Defined. -Definition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @projT1' _ _ . -Coercion pr1eqrel : eqrel >-> Funclass . - -Definition hreldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) : hrel ( dirprod X Y ) . -admit. -Defined. -Set Printing Universes. -Print hProp. -Print ishinh_UU. -Print hProppair. -Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type. -intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) )) . -Defined. -Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. -intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact ax2. -Defined. - -Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) . -intros X R A. exact (fun is : iseqclass R A => projT1' _ is ). -Defined. - -Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . -Proof . - intros . - set ( XY := dirprod X Y ) . - set ( AB := subtypesdirprod A B ) . - set ( RQ := hreldirprod R Q ) . - set ( ax0 := ishinhsubtypesdirprod A B ( eqax0 isa ) admit ) . - apply ( iseqclassconstr _ ax0 admit admit ) . -Defined . - -Definition image { X Y : UU } ( f : X -> Y ) : Type. -intros; exact ( sigT' ( fun y : Y => admit ) ). -Defined. -Definition pr1image { X Y : UU } ( f : X -> Y ) : image f -> Y. -intros X Y f; exact ( @projT1' _ ( fun y : Y => admit ) ). -Defined. - -Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. - admit. -Defined. - -Definition setquot { X : UU } ( R : hrel X ) : Set. -intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ). -Defined. -Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R. -intros; exact (existT' _ A is ). -Defined. -Definition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ). -intros X R. -exact ( @projT1' _ ( fun A : _ => iseqclass R A ) ). -Defined. -Coercion pr1setquot : setquot >-> hsubtypes . - -Definition setquotinset { X : UU } ( R : hrel X ) : hSet. -intros; exact ( hSetpair (setquot R) admit) . -Defined. - -Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot@{i j k l m n p Set q r} RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). -intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _ ( projT2' _ cd ) ) ) ). -Defined. - -Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . - -Definition binop ( X : UU ) : Type. -intros; exact ( X -> X -> X ). -Defined. - -Definition setwithbinop : Type. -exact (sigT' ( fun X : hSet => binop X ) ). -Defined. -Definition pr1setwithbinop : setwithbinop -> hSet@{j k Set l}. -unfold setwithbinop. -exact ( @projT1' _ ( fun X : hSet@{j k Set l} => binop@{Set} X ) ). -Defined. -Coercion pr1setwithbinop : setwithbinop >-> hSet . - -Definition op { X : setwithbinop } : binop X. -intros; exact ( projT2' _ X ). -Defined. - -Definition subsetswithbinop { X : setwithbinop } : Type. -admit. -Defined. - -Definition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop . -admit. -Defined. - -Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop . - -Definition binopeqrel { X : setwithbinop } : Type. -intros; exact (sigT' ( fun R : eqrel X => admit ) ). -Defined. -Definition binopeqrelpair { X : setwithbinop } := existT' ( fun R : eqrel X => admit ). -Definition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X. -intros X; exact ( @projT1' _ ( fun R : eqrel X => admit ) ) . -Defined. -Coercion pr1binopeqrel : binopeqrel >-> eqrel . - -Definition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop . -admit. -Defined. - -Definition monoid : Type. -exact ( sigT' ( fun X : setwithbinop => admit ) ). -Defined. -Definition monoidpair := existT' ( fun X : setwithbinop => admit ) . -Definition pr1monoid : monoid -> setwithbinop := @projT1' _ _ . -Coercion pr1monoid : monoid >-> setwithbinop . - -Notation "x + y" := ( op x y ) : addmonoid_scope . - -Definition submonoids { X : monoid } : Type. -admit. -Defined. - -Definition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X. -admit. -Defined. -Coercion submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop . - -Definition abmonoid : Type. -exact (sigT' ( fun X : setwithbinop => admit ) ). -Defined. - -Definition abmonoidtomonoid : abmonoid -> monoid. -exact (fun X : _ => monoidpair ( projT1' _ X ) admit ). -Defined. -Coercion abmonoidtomonoid : abmonoid >-> monoid . - -Definition subabmonoids { X : abmonoid } := @submonoids X . - -Definition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid . -Proof . - intros . - unfold subabmonoids in A . - split with A . - admit. -Defined . - -Coercion carrierofsubabmonoid : subabmonoids >-> abmonoid . - -Definition abmonoiddirprod ( X Y : abmonoid ) : abmonoid . -Proof . - intros . - split with ( setwithbinopdirprod X Y ) . - admit. -Defined . - -Open Scope addmonoid_scope . - -Definition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ). -admit. -Defined. - -Definition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ). -intros; exact ( @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) admit ). -Defined. - -Theorem setquotuniv { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ) : Y . -Proof. - intros. - apply ( pr1image ( fun x : c => f ( projT1' _ x ) ) ) . - apply ( @hinhuniv ( projT1' _ c ) ( hProppair _ admit ) ( prtoimage ( fun x : c => f ( projT1' _ x ) ) ) ) . - pose ( eqax0 ( projT2' _ c ) ) as h. - simpl in *. - Set Printing Universes. - exact h. -Defined . - -Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y . -Proof. - intros . - set ( RR := hreldirprod R R ) . - apply (setquotuniv RR Y admit). - apply dirprodtosetquot. - apply dirprodpair. - exact c. - exact c0. -Defined . - -Definition setquotfun2 { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( cx cx0 : setquot RX ) : setquot RY . -Proof . - intros . - apply ( setquotuniv2 RX ( setquotinset RY ) admit admit admit admit ) . -Defined . - -Definition quotrel { X : UU } { R : hrel X } : hrel ( setquot R ). -intros; exact ( setquotuniv2 R hPropset admit admit ). -Defined. - -Definition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop . -Proof . - intros . - split with ( setquotinset R ) . - set ( qtmlt := setquotfun2 R R op ) . - simpl . - unfold binop . - apply qtmlt . -Defined . - -Definition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid . -Proof . - intros . - split with ( setwithbinopquot R ) . - admit. -Defined . - -Definition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid. -intros; exact ( @abmonoidquot (abmonoiddirprod X (@carrierofsubabmonoid X A)) ( binopeqrelabmonoidfrac X A ) ). -Defined. - -Definition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) : hrel (@setquot (setwithbinopdirprod X A) (eqrelabmonoidfrac X A)). -intros; exact (@quotrel _ _). -Defined. - -Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. - -Definition ispartlbinopabmonoidfracrel_type : Type := - forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ), - @abmonoidfracrel X A ( ( admit + z ) )admit. - -Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in - ispartlbinopabmonoidfracrel_type in exact t)$. - -Unset Kernel Term Sharing. - -Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. - -Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in - ispartlbinopabmonoidfracrel_type in exact t)$. - -- cgit v1.2.3 From 6b9ff2261c738ff8ce47b75e5ced2b85476b6210 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:46:08 +0200 Subject: Univs: fix test-suite file for #4287, now properly rejected. --- test-suite/bugs/closed/4287.v | 52 ++----------------------------------------- 1 file changed, 2 insertions(+), 50 deletions(-) diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 732f19f33c..e139c5b6c9 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -100,35 +100,15 @@ End Hurkens. Polymorphic Record box (T : Type) := wrap {unwrap : T}. -(* Here we instantiate to Prop *) -(* Here we instantiate to Prop *) +(* Here we instantiate to Set *) -Fail Definition down (x : Type) : Set := box x. -Definition down (x : Set) : Set := box x. +Fail Definition down (x : Type) : Prop := box x. Definition up (x : Prop) : Type := x. Fail Definition back A : up (down A) -> A := unwrap A. Fail Definition forth A : A -> up (down A) := wrap A. -(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) -(* P (back A (forth A a)) -> P a. *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) -(* P a -> P (back A (forth A a)). *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Theorem bad : False. *) -(* apply (paradox down up back forth backforth backforth_r). *) -(* Qed. *) - -(* Print Assumptions bad. *) - Definition id {A : Type} (a : A) := a. Definition setlt (A : Type@{i}) := let foo := Type@{i} : Type@{j} in True. @@ -142,31 +122,3 @@ Check @setle@{Prop j}. Fail Definition foo := @setle@{j Prop}. Definition foo := @setle@{Prop j}. - -(* Definition up (x : Prop) : Type := x. *) - -(* Definition back A : up (down A) -> A := unwrap A. *) - -(* Definition forth A : A -> up (down A) := wrap A. *) - -(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) -(* P (back A (forth A a)) -> P a. *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) -(* P a -> P (back A (forth A a)). *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Theorem bad : False. *) -(* apply (paradox down up back forth backforth backforth_r). *) -(* Qed. *) - -(* Print Assumptions bad. *) - -(* Polymorphic Record box (T : Type) := wrap {unwrap : T}. *) - -(* Definition down (x : Type) : Prop := box x. *) -- cgit v1.2.3 From de648c72a79ae5ba35db166575669ca465b11770 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 18:41:49 +0200 Subject: Univs: fix checker generating undeclared universes. --- checker/mod_checking.ml | 20 ++++++++++++++------ checker/reduction.ml | 2 +- checker/univ.ml | 42 ++++++++++++++++-------------------------- checker/univ.mli | 5 +++-- 4 files changed, 34 insertions(+), 35 deletions(-) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 78fff1bbe6..3ea5ed0d34 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -18,19 +18,27 @@ let refresh_arity ar = let ctxt, hd = decompose_prod_assum ar in match hd with Sort (Type u) when not (Univ.is_univ_variable u) -> - let u' = Univ.Universe.make (Univ.Level.make empty_dirpath 1) in - mkArity (ctxt,Prop Null), - Univ.enforce_leq u u' Univ.empty_constraint - | _ -> ar, Univ.empty_constraint + let ul = Univ.Level.make empty_dirpath 1 in + let u' = Univ.Universe.make ul in + let cst = Univ.enforce_leq u u' Univ.empty_constraint in + let ctx = Univ.ContextSet.make (Univ.LSet.singleton ul) cst in + mkArity (ctxt,Prop Null), ctx + | _ -> ar, Univ.ContextSet.empty let check_constant_declaration env kn cb = Flags.if_verbose ppnl (str " checking cst: " ++ prcon kn); pp_flush (); - let env' = add_constraints (Univ.UContext.constraints cb.const_universes) env in + let env' = + if cb.const_polymorphic then + let inst = Univ.make_abstract_instance cb.const_universes in + let ctx = Univ.UContext.make (inst, Univ.UContext.constraints cb.const_universes) in + push_context ~strict:false ctx env + else push_context ~strict:true cb.const_universes env + in let envty, ty = match cb.const_type with RegularArity ty -> let ty', cu = refresh_arity ty in - let envty = add_constraints cu env' in + let envty = push_context_set cu env' in let _ = infer_type envty ty' in envty, ty | TemplateArity(ctxt,par) -> let _ = check_ctxt env' ctxt in diff --git a/checker/reduction.ml b/checker/reduction.ml index 8ddeea2a20..384d883ea3 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -175,7 +175,7 @@ let sort_cmp env univ pb s0 s1 = then begin if !Flags.debug then begin let op = match pb with CONV -> "=" | CUMUL -> "<=" in - Printf.eprintf "cort_cmp: %s\n%!" Pp.(string_of_ppcmds + Printf.eprintf "sort_cmp: %s\n%!" Pp.(string_of_ppcmds (str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut() ++ Univ.pr_universes univ)) end; diff --git a/checker/univ.ml b/checker/univ.ml index 50c0367bb6..648e478176 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -562,20 +562,6 @@ let repr g u = let get_set_arc g = repr g Level.set -(* [safe_repr] also search for the canonical representative, but - if the graph doesn't contain the searched universe, we add it. *) - -let safe_repr g u = - let rec safe_repr_rec u = - match UMap.find u g with - | Equiv v -> safe_repr_rec v - | Canonical arc -> arc - in - try g, safe_repr_rec u - with Not_found -> - let can = terminal u in - enter_arc can g, can - exception AlreadyDeclared let add_universe vlev strict g = @@ -760,8 +746,8 @@ let is_lt g arcu arcv = (** First, checks on universe levels *) let check_equal g u v = - let g, arcu = safe_repr g u in - let _, arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in arcu == arcv let check_eq_level g u v = u == v || check_equal g u v @@ -770,8 +756,8 @@ let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ let check_smaller g strict u v = - let g, arcu = safe_repr g u in - let g, arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in if strict then is_lt g arcu arcv else @@ -921,8 +907,8 @@ let error_inconsistency o u v = (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in match fast_compare g arcu arcv with | FastEQ -> g | FastLT -> error_inconsistency Eq v u @@ -937,8 +923,8 @@ let enforce_univ_eq u v g = (* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in if is_leq g arcu arcv then g else match fast_compare g arcv arcu with @@ -949,8 +935,8 @@ let enforce_univ_leq u v g = (* enforce_univ_lt u v will force u g | FastLE -> fst (setlt g arcu arcv) @@ -962,7 +948,10 @@ let enforce_univ_lt u v g = | FastLE | FastLT -> error_inconsistency Lt u v (* Prop = Set is forbidden here. *) -let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty +let initial_universes = + let g = enter_arc (terminal Level.set) UMap.empty in + let g = enter_arc (terminal Level.prop) g in + enforce_univ_lt Level.prop Level.set g (* Constraints and sets of constraints. *) @@ -1167,7 +1156,7 @@ struct (** Universe contexts (variables as a list) *) let empty = (Instance.empty, Constraint.empty) - + let make x = x let instance (univs, cst) = univs let constraints (univs, cst) = cst end @@ -1180,6 +1169,7 @@ struct let empty = LSet.empty, Constraint.empty let constraints (_, cst) = cst let levels (ctx, _) = ctx + let make ctx cst = (ctx, cst) end type universe_context_set = ContextSet.t diff --git a/checker/univ.mli b/checker/univ.mli index 459adfcd6d..02c1bbdb91 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -131,7 +131,7 @@ val check_constraints : constraints -> universes -> bool (** Polymorphic maps from universe levels to 'a *) module LMap : Map.S with type key = universe_level - +module LSet : CSig.SetS with type elt = universe_level type 'a universe_map = 'a LMap.t (** {6 Substitution} *) @@ -184,7 +184,7 @@ sig type t val empty : t - + val make : universe_instance constrained -> t val instance : t -> Instance.t val constraints : t -> constraints @@ -193,6 +193,7 @@ end module ContextSet : sig type t + val make : LSet.t -> constraints -> t val empty : t val constraints : t -> constraints end -- cgit v1.2.3 From 4585baa53e7fa4c25e304b8136944748a7622e10 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 18:42:38 +0200 Subject: Univs: refined handling of assumptions According to their polymorphic/non-polymorphic status, which imply that universe variables introduced with it are assumed to be >= or > Set respectively in the following definitions. --- kernel/safe_typing.ml | 51 +++++++++++++++++++++++++----------------------- kernel/safe_typing.mli | 7 ++++--- library/declare.ml | 11 ++++++----- library/global.ml | 6 +++--- library/global.mli | 6 +++--- library/lib.ml | 1 + library/universes.ml | 32 ++++++++++++++---------------- tactics/extratactics.ml4 | 2 +- 8 files changed, 60 insertions(+), 56 deletions(-) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 43358d604d..4299f729da 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -221,22 +221,23 @@ let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env type constraints_addition = - Now of Univ.ContextSet.t | Later of Univ.ContextSet.t Future.computation + | Now of bool * Univ.ContextSet.t + | Later of Univ.ContextSet.t Future.computation let add_constraints cst senv = match cst with | Later fc -> {senv with future_cst = fc :: senv.future_cst} - | Now cst -> + | Now (poly,cst) -> { senv with - env = Environ.push_context_set ~strict:true cst senv.env; + env = Environ.push_context_set ~strict:(not poly) cst senv.env; univ = Univ.ContextSet.union cst senv.univ } let add_constraints_list cst senv = List.fold_left (fun acc c -> add_constraints c acc) senv cst -let push_context_set ctx = add_constraints (Now ctx) -let push_context ctx = add_constraints (Now (Univ.ContextSet.of_context ctx)) +let push_context_set poly ctx = add_constraints (Now (poly,ctx)) +let push_context poly ctx = add_constraints (Now (poly,Univ.ContextSet.of_context ctx)) let is_curmod_library senv = match senv.modvariant with LIBRARY -> true | _ -> false @@ -246,7 +247,7 @@ let join_safe_environment ?(except=Future.UUIDSet.empty) e = List.fold_left (fun e fc -> if Future.UUIDSet.mem (Future.uuid fc) except then e - else add_constraints (Now (Future.join fc)) e) + else add_constraints (Now (false, Future.join fc)) e) {e with future_cst = []} e.future_cst let is_joined_environment e = List.is_empty e.future_cst @@ -337,20 +338,20 @@ let safe_push_named (id,_,_ as d) env = let push_named_def (id,de) senv = let c,typ,univs = Term_typing.translate_local_def senv.env id de in - let senv' = push_context univs senv in + let senv' = push_context de.Entries.const_entry_polymorphic univs senv in let c, senv' = match c with | Def c -> Mod_subst.force_constr c, senv' | OpaqueDef o -> Opaqueproof.force_proof (Environ.opaque_tables senv'.env) o, - push_context_set - (Opaqueproof.force_constraints (Environ.opaque_tables senv'.env) o) + push_context_set de.Entries.const_entry_polymorphic + (Opaqueproof.force_constraints (Environ.opaque_tables senv'.env) o) senv' | _ -> assert false in let env'' = safe_push_named (id,Some c,typ) senv'.env in {senv' with env=env''} -let push_named_assum ((id,t),ctx) senv = - let senv' = push_context_set ctx senv in +let push_named_assum ((id,t,poly),ctx) senv = + let senv' = push_context_set poly ctx senv in let t = Term_typing.translate_local_assum senv'.env t in let env'' = safe_push_named (id,None,t) senv'.env in {senv' with env=env''} @@ -373,10 +374,10 @@ let labels_of_mib mib = let globalize_constant_universes env cb = if cb.const_polymorphic then - [Now Univ.ContextSet.empty] + [Now (true, Univ.ContextSet.empty)] else let cstrs = Univ.ContextSet.of_context cb.const_universes in - Now cstrs :: + Now (false, cstrs) :: (match cb.const_body with | (Undef _ | Def _) -> [] | OpaqueDef lc -> @@ -385,20 +386,20 @@ let globalize_constant_universes env cb = | Some fc -> match Future.peek_val fc with | None -> [Later fc] - | Some c -> [Now c]) + | Some c -> [Now (false, c)]) let globalize_mind_universes mb = if mb.mind_polymorphic then - [Now Univ.ContextSet.empty] + [Now (true, Univ.ContextSet.empty)] else - [Now (Univ.ContextSet.of_context mb.mind_universes)] + [Now (false, Univ.ContextSet.of_context mb.mind_universes)] let constraints_of_sfb env sfb = match sfb with | SFBconst cb -> globalize_constant_universes env cb | SFBmind mib -> globalize_mind_universes mib - | SFBmodtype mtb -> [Now mtb.mod_constraints] - | SFBmodule mb -> [Now mb.mod_constraints] + | SFBmodtype mtb -> [Now (false, mtb.mod_constraints)] + | SFBmodule mb -> [Now (false, mb.mod_constraints)] (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) @@ -501,13 +502,13 @@ let add_modtype l params_mte inl senv = (** full_add_module adds module with universes and constraints *) let full_add_module mb senv = - let senv = add_constraints (Now mb.mod_constraints) senv in + let senv = add_constraints (Now (false, mb.mod_constraints)) senv in let dp = ModPath.dp mb.mod_mp in let linkinfo = Nativecode.link_info_of_dirpath dp in { senv with env = Modops.add_linked_module mb linkinfo senv.env } let full_add_module_type mp mt senv = - let senv = add_constraints (Now mt.mod_constraints) senv in + let senv = add_constraints (Now (false, mt.mod_constraints)) senv in { senv with env = Modops.add_module_type mp mt senv.env } (** Insertion of modules *) @@ -688,14 +689,16 @@ let add_include me is_module inl senv = let mtb = translate_modtype senv.env mp_sup inl ([],me) in mtb.mod_type,mtb.mod_constraints,mtb.mod_delta in - let senv = add_constraints (Now cst) senv in + let senv = add_constraints (Now (false, cst)) senv in (* Include Self support *) let rec compute_sign sign mb resolver senv = match sign with | MoreFunctor(mbid,mtb,str) -> let cst_sub = Subtyping.check_subtypes senv.env mb mtb in - let senv = add_constraints - (Now (Univ.ContextSet.add_constraints cst_sub Univ.ContextSet.empty)) senv in + let senv = + add_constraints + (Now (false, Univ.ContextSet.add_constraints cst_sub Univ.ContextSet.empty)) + senv in let mpsup_delta = Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta in @@ -858,7 +861,7 @@ let register_inline kn senv = let add_constraints c = add_constraints - (Now (Univ.ContextSet.add_constraints c Univ.ContextSet.empty)) + (Now (false, Univ.ContextSet.add_constraints c Univ.ContextSet.empty)) (* NB: The next old comment probably refers to [propagate_loads] above. diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 2b4324b96f..b971a1bd42 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -57,7 +57,8 @@ val is_joined_environment : safe_environment -> bool (** Insertion of local declarations (Local or Variables) *) val push_named_assum : - (Id.t * Term.types) Univ.in_universe_context_set -> safe_transformer0 + (Id.t * Term.types * bool (* polymorphic *)) + Univ.in_universe_context_set -> safe_transformer0 val push_named_def : Id.t * Entries.definition_entry -> safe_transformer0 @@ -88,10 +89,10 @@ val add_modtype : (** Adding universe constraints *) val push_context_set : - Univ.universe_context_set -> safe_transformer0 + bool -> Univ.universe_context_set -> safe_transformer0 val push_context : - Univ.universe_context -> safe_transformer0 + bool -> Univ.universe_context -> safe_transformer0 val add_constraints : Univ.constraints -> safe_transformer0 diff --git a/library/declare.ml b/library/declare.ml index 8908a2c919..ec0e1047e7 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -42,7 +42,7 @@ type variable_declaration = DirPath.t * section_variable_entry * logical_kind let cache_variable ((sp,_),o) = match o with - | Inl ctx -> Global.push_context_set ctx + | Inl ctx -> Global.push_context_set false ctx | Inr (id,(p,d,mk)) -> (* Constr raisonne sur les noms courts *) if variable_exists id then @@ -50,7 +50,7 @@ let cache_variable ((sp,_),o) = let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) | SectionLocalAssum ((ty,ctx),poly,impl) -> - let () = Global.push_named_assum ((id,ty),ctx) in + let () = Global.push_named_assum ((id,ty,poly),ctx) in let impl = if impl then Implicit else Explicit in impl, true, poly, ctx | SectionLocalDef (de) -> @@ -116,8 +116,9 @@ let open_constant i ((sp,kn), obj) = match (Global.lookup_constant con).const_body with | (Def _ | Undef _) -> () | OpaqueDef lc -> - match Opaqueproof.get_constraints (Global.opaque_tables ())lc with - | Some f when Future.is_val f -> Global.push_context_set (Future.force f) + match Opaqueproof.get_constraints (Global.opaque_tables ()) lc with + | Some f when Future.is_val f -> + Global.push_context_set false (Future.force f) | _ -> () let exists_name id = @@ -462,7 +463,7 @@ let do_universe l = Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in - Global.push_context_set ctx; + Global.push_context_set false ctx; Lib.add_anonymous_leaf (input_universes glob') diff --git a/library/global.ml b/library/global.ml index 0419799b67..382abb8467 100644 --- a/library/global.ml +++ b/library/global.ml @@ -80,8 +80,8 @@ let i2l = Label.of_id let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) let push_named_def d = globalize0 (Safe_typing.push_named_def d) let add_constraints c = globalize0 (Safe_typing.add_constraints c) -let push_context_set c = globalize0 (Safe_typing.push_context_set c) -let push_context c = globalize0 (Safe_typing.push_context c) +let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) +let push_context b c = globalize0 (Safe_typing.push_context b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) @@ -249,7 +249,7 @@ let current_dirpath () = let with_global f = let (a, ctx) = f (env ()) (current_dirpath ()) in - push_context_set ctx; a + push_context_set false ctx; a (* spiwack: register/unregister functions for retroknowledge *) let register field value by_clause = diff --git a/library/global.mli b/library/global.mli index 363bb57890..e6b5c1cbab 100644 --- a/library/global.mli +++ b/library/global.mli @@ -30,7 +30,7 @@ val set_engagement : Declarations.engagement -> unit (** Variables, Local definitions, constants, inductive types *) -val push_named_assum : (Id.t * Constr.types) Univ.in_universe_context_set -> unit +val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit val push_named_def : (Id.t * Entries.definition_entry) -> unit val add_constant : @@ -41,8 +41,8 @@ val add_mind : (** Extra universe constraints *) val add_constraints : Univ.constraints -> unit -val push_context : Univ.universe_context -> unit -val push_context_set : Univ.universe_context_set -> unit +val push_context : bool -> Univ.universe_context -> unit +val push_context_set : bool -> Univ.universe_context_set -> unit (** Non-interactive modules and module types *) diff --git a/library/lib.ml b/library/lib.ml index 81db547efd..f4f52db53b 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -420,6 +420,7 @@ let extract_hyps (secs,ohyps) = in aux (secs,ohyps) let instance_from_variable_context sign = + let rec inst_rec = function | (id,b,None,_) :: sign -> id :: inst_rec sign | _ :: sign -> inst_rec sign diff --git a/library/universes.ml b/library/universes.ml index 9bc21b0e55..bc42cc044c 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -849,19 +849,20 @@ let normalize_context_set ctx us algs = ctx Univ.empty_universes in let g = - Univ.Constraint.fold (fun (l, d, r) g -> - let g = - if not (Level.is_small l || LSet.mem l ctx) then - try Univ.add_universe l false g - with Univ.AlreadyDeclared -> g - else g - in - let g = - if not (Level.is_small r || LSet.mem r ctx) then - try Univ.add_universe r false g - with Univ.AlreadyDeclared -> g - else g - in g) csts g + Univ.Constraint.fold + (fun (l, d, r) g -> + let g = + if not (Level.is_small l || LSet.mem l ctx) then + try Univ.add_universe l false g + with Univ.AlreadyDeclared -> g + else g + in + let g = + if not (Level.is_small r || LSet.mem r ctx) then + try Univ.add_universe r false g + with Univ.AlreadyDeclared -> g + else g + in g) csts g in let g = Univ.Constraint.fold Univ.enforce_constraint csts g in Univ.constraints_of_universes g @@ -870,10 +871,7 @@ let normalize_context_set ctx us algs = Constraint.fold (fun (l,d,r as cstr) noneqs -> if d == Eq then (UF.union l r uf; noneqs) else (* We ignore the trivial Prop/Set <= i constraints. *) - if d == Le && Univ.Level.is_small l then - noneqs - else if Level.is_small l && d == Lt && not (LSet.mem r ctx) then - noneqs + if d == Le && Univ.Level.is_small l then noneqs else Constraint.add cstr noneqs) csts Constraint.empty in diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index a72c6ab51e..cab74968d2 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -270,7 +270,7 @@ let add_rewrite_hint bases ort t lcsr = let ctx = let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in if poly then ctx - else (Global.push_context_set ctx; Univ.ContextSet.empty) + else (Global.push_context_set false ctx; Univ.ContextSet.empty) in Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in let eqs = List.map f lcsr in -- cgit v1.2.3 From 8860362de4a26286b0cb20cf4e02edc5209bdbd1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 23:35:51 +0200 Subject: Univs: Change intf of push_named_def to return the computed universe context Let-bound definitions can be opaque but the whole universe context was not gathered to be discharged at section closing time. --- kernel/safe_typing.ml | 17 +++++++++-------- kernel/safe_typing.mli | 5 ++++- library/declare.ml | 6 +++--- library/global.ml | 2 +- library/global.mli | 2 +- 5 files changed, 18 insertions(+), 14 deletions(-) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 4299f729da..9329b16861 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -338,17 +338,18 @@ let safe_push_named (id,_,_ as d) env = let push_named_def (id,de) senv = let c,typ,univs = Term_typing.translate_local_def senv.env id de in - let senv' = push_context de.Entries.const_entry_polymorphic univs senv in - let c, senv' = match c with - | Def c -> Mod_subst.force_constr c, senv' + let poly = de.Entries.const_entry_polymorphic in + let univs = Univ.ContextSet.of_context univs in + let c, univs = match c with + | Def c -> Mod_subst.force_constr c, univs | OpaqueDef o -> - Opaqueproof.force_proof (Environ.opaque_tables senv'.env) o, - push_context_set de.Entries.const_entry_polymorphic - (Opaqueproof.force_constraints (Environ.opaque_tables senv'.env) o) - senv' + Opaqueproof.force_proof (Environ.opaque_tables senv.env) o, + Univ.ContextSet.union univs + (Opaqueproof.force_constraints (Environ.opaque_tables senv.env) o) | _ -> assert false in + let senv' = push_context_set poly univs senv in let env'' = safe_push_named (id,Some c,typ) senv'.env in - {senv' with env=env''} + univs, {senv' with env=env''} let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index b971a1bd42..eac08eb834 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -59,8 +59,11 @@ val is_joined_environment : safe_environment -> bool val push_named_assum : (Id.t * Term.types * bool (* polymorphic *)) Univ.in_universe_context_set -> safe_transformer0 + +(** Returns the full universe context necessary to typecheck the definition + (futures are forced) *) val push_named_def : - Id.t * Entries.definition_entry -> safe_transformer0 + Id.t * Entries.definition_entry -> Univ.universe_context_set safe_transformer (** Insertion of global axioms or definitions *) diff --git a/library/declare.ml b/library/declare.ml index ec0e1047e7..16803b3bfa 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -54,9 +54,9 @@ let cache_variable ((sp,_),o) = let impl = if impl then Implicit else Explicit in impl, true, poly, ctx | SectionLocalDef (de) -> - let () = Global.push_named_def (id,de) in - Explicit, de.const_entry_opaque, de.const_entry_polymorphic, - (Univ.ContextSet.of_context de.const_entry_universes) in + let univs = Global.push_named_def (id,de) in + Explicit, de.const_entry_opaque, + de.const_entry_polymorphic, univs in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); add_section_variable id impl poly ctx; Dischargedhypsmap.set_discharged_hyps sp []; diff --git a/library/global.ml b/library/global.ml index 382abb8467..6002382c1f 100644 --- a/library/global.ml +++ b/library/global.ml @@ -78,7 +78,7 @@ let globalize_with_summary fs f = let i2l = Label.of_id let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) -let push_named_def d = globalize0 (Safe_typing.push_named_def d) +let push_named_def d = globalize (Safe_typing.push_named_def d) let add_constraints c = globalize0 (Safe_typing.add_constraints c) let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) let push_context b c = globalize0 (Safe_typing.push_context b c) diff --git a/library/global.mli b/library/global.mli index e6b5c1cbab..ac231f7fd8 100644 --- a/library/global.mli +++ b/library/global.mli @@ -31,7 +31,7 @@ val set_engagement : Declarations.engagement -> unit (** Variables, Local definitions, constants, inductive types *) val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit -val push_named_def : (Id.t * Entries.definition_entry) -> unit +val push_named_def : (Id.t * Entries.definition_entry) -> Univ.universe_context_set val add_constant : DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant -- cgit v1.2.3 From 6e1c88226eb2ab188a1aaaf9a31667967c85fc65 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 2 Oct 2015 16:32:20 +0200 Subject: Update the history of versions with recent versions. --- dev/doc/versions-history.tex | 50 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index 9892a4419f..fab6a37ef4 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -265,7 +265,17 @@ Coq V7.3.1& released 5 October 2002 & \feature{module system} [2-8-2002]\\ & & \feature{pattern-matching compilation} (version 2) [13-6-2002]\\ Coq V7.4& released 6 February 2003 & \feature{notation}, \feature{scopes} [13-10-2002]\\ +\end{tabular} +\medskip +\bigskip + +\centerline{V- New concrete syntax} +\mbox{}\\ +\mbox{}\\ +\begin{tabular}{l|l|l} +version & date & comments \\ +\hline Coq V8.0& released 21 April 2004 & \feature{new concrete syntax}, \feature{Set predicative}, \feature{CoqIDE} [from 4-2-2003]\\ Coq V8.0pl1& released 18 July 2004\\ @@ -307,6 +317,46 @@ Coq V8.2 & released 17 February 2009 & \feature{type classes} [10-12-2007], \fea & & a first package released on February 11 was incomplete\\ +Coq V8.2pl1& released 4 July 2009 & \\ +Coq V8.2pl2& released 29 June 2010 & \\ +\end{tabular} + +\medskip +\bigskip + +\newpage +\mbox{}\\ +\mbox{}\\ +\begin{tabular}{l|l|l} +Coq V8.3 beta & released 16 February 2010 & \feature{MSets library} [13-10-2009] \\ +Coq V8.3 & released 14 October 2010 & \feature{nsatz} [3-6-2010] \\ +Coq V8.3pl1& released 23 December 2010 & \\ +Coq V8.3pl2& released 19 April 2011 & \\ +Coq V8.3pl3& released 19 December 2011 & \\ +Coq V8.3pl3& released 26 March 2012 & \\ +Coq V8.3pl5& released 28 September 2012 & \\ +Coq V8.4 beta & released 27 December 2011 & \feature{modular arithmetic library} [2010-2012]\\ +&& \feature{vector library} [10-12-2010]\\ +&& \feature{structured scripts} [22-4-2010]\\ +&& \feature{eta-conversion} [20-9-2010]\\ +&& \feature{new proof engine available} [10-12-2010]\\ +Coq V8.4 beta2 & released 21 May 2012 & \\ +Coq V8.4 & released 12 August 2012 &\\ +Coq V8.4pl1& released 22 December 2012 & \\ +Coq V8.4pl2& released 4 April 2013 & \\ +Coq V8.4pl3& released 21 December 2013 & \\ +Coq V8.4pl4& released 24 April 2014 & \\ +Coq V8.4pl5& released 22 October 2014 & \\ +Coq V8.4pl6& released 9 April 2015 & \\ + +Coq V8.5 beta1 & released 21 January 2015 & \feature{computation via compilation to OCaml} [22-1-2013]\\ +&& \feature{asynchonous evaluation} [8-8-2013]\\ +&& \feature{new proof engine deployed} [2-11-2013]\\ +&& \feature{universe polymorphism} [6-5-2014]\\ +&& \feature{primitive projections} [6-5-2014]\\ + +Coq V8.5 beta2 & released 22 April 2015 & \feature{MMaps library} [4-3-2015]\\ + \end{tabular} \medskip -- cgit v1.2.3 From 9227d6e9412ae4ebe70fb9b6bd5d2f6ecc354864 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 1 Oct 2015 09:29:10 +0200 Subject: Improving reference manual in that auto uses simple apply rather than apply. Still, there are small differences, e.g. on "use_metas_eagerly_in_conv_on_closed_terms", but also maybe in some amount of use of delta that Matthieu would know better than me if it matters or not in practice. --- doc/refman/RefMan-tac.tex | 51 ++++++++++++++++++++++++++--------------------- 1 file changed, 28 insertions(+), 23 deletions(-) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index fa6f783934..06431055ad 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3394,7 +3394,7 @@ local definition. Example: {\tt unfold not in (Type of H1) (Type of H3).} This tactic implements a Prolog-like resolution procedure to solve the current goal. It first tries to solve the goal using the {\tt assumption} tactic, then it reduces the goal to an atomic one using -{\tt intros} and introducing the newly generated hypotheses as hints. +{\tt intros} and introduces the newly generated hypotheses as hints. Then it looks at the list of tactics associated to the head symbol of the goal and tries to apply one of them (starting from the tactics with lower cost). This process is recursively applied to the generated @@ -3454,11 +3454,10 @@ intact. \texttt{auto} and \texttt{trivial} never fail. \tacindex{eauto} \label{eauto} -This tactic generalizes {\tt auto}. In contrast with -the latter, {\tt eauto} uses unification of the goal -against the hints rather than pattern-matching -(in other words, it uses {\tt eapply} instead of -{\tt apply}). +This tactic generalizes {\tt auto}. While {\tt auto} does not try +resolution hints which would leave existential variables in the goal, +{\tt eauto} does try them (informally speaking, it uses {\tt eapply} +where {\tt auto} uses {\tt apply}). As a consequence, {\tt eauto} can solve such a goal: \begin{coq_eval} @@ -3623,21 +3622,27 @@ The {\hintdef} is one of the following expressions: \item {\tt Resolve \term} \comindex{Hint Resolve} - This command adds {\tt apply {\term}} to the hint list + This command adds {\tt simple apply {\term}} to the hint list with the head symbol of the type of \term. The cost of that hint is - the number of subgoals generated by {\tt apply {\term}}. - - In case the inferred type of \term\ does not start with a product the - tactic added in the hint list is {\tt exact {\term}}. In case this - type can be reduced to a type starting with a product, the tactic {\tt - apply {\term}} is also stored in the hints list. - - If the inferred type of \term\ contains a dependent - quantification on a predicate, it is added to the hint list of {\tt - eapply} instead of the hint list of {\tt apply}. In this case, a - warning is printed since the hint is only used by the tactic {\tt - eauto} (see \ref{eauto}). A typical example of a hint that is used - only by \texttt{eauto} is a transitivity lemma. + the number of subgoals generated by {\tt simple apply {\term}}. +%{\tt auto} actually uses a slightly modified variant of {\tt simple apply} with use_metas_eagerly_in_conv_on_closed_terms set to false + + The cost of that hint is the number of subgoals generated by that + tactic. + + % Is it really needed? + %% In case the inferred type of \term\ does not start with a product + %% the tactic added in the hint list is {\tt exact {\term}}. In case + %% this type can however be reduced to a type starting with a product, + %% the tactic {\tt apply {\term}} is also stored in the hints list. + + If the inferred type of \term\ contains a dependent quantification + on a variable which occurs only in the premisses of the type and not + in its conclusion, no instance could be inferred for the variable by + unification with the goal. In this case, the hint is added to the + hint list of {\tt eauto} (see \ref{eauto}) instead of the hint list + of {\tt auto} and a warning is printed. A typical example of a hint + that is used only by \texttt{eauto} is a transitivity lemma. \begin{ErrMsgs} \item \errindex{Bound head variable} @@ -3649,7 +3654,7 @@ The {\hintdef} is one of the following expressions: The type of {\term} contains products over variables that do not appear in the conclusion. A typical example is a transitivity axiom. - In that case the {\tt apply} tactic fails, and thus is useless. + In that case the {\tt simple apply} tactic fails, and thus is useless. \end{ErrMsgs} @@ -3664,10 +3669,10 @@ The {\hintdef} is one of the following expressions: \item \texttt{Immediate {\term}} \comindex{Hint Immediate} - This command adds {\tt apply {\term}; trivial} to the hint list + This command adds {\tt simple apply {\term}; trivial} to the hint list associated with the head symbol of the type of {\ident} in the given database. This tactic will fail if all the subgoals generated by - {\tt apply {\term}} are not solved immediately by the {\tt trivial} + {\tt simple apply {\term}} are not solved immediately by the {\tt trivial} tactic (which only tries tactics with cost $0$). This command is useful for theorems such as the symmetry of equality -- cgit v1.2.3 From 5e62675419fb6a5a8f8a86fbf3f6df4427e70d21 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 2 Oct 2015 16:50:26 +0200 Subject: Fixing error messages about Hint. --- doc/refman/RefMan-tac.tex | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 06431055ad..a21e5631fc 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3645,16 +3645,16 @@ The {\hintdef} is one of the following expressions: that is used only by \texttt{eauto} is a transitivity lemma. \begin{ErrMsgs} - \item \errindex{Bound head variable} +%% \item \errindex{Bound head variable} + + \item \term\ \errindex{cannot be used as a hint} The head symbol of the type of {\term} is a bound variable such that this tactic cannot be associated to a constant. - \item \term\ \errindex{cannot be used as a hint} - - The type of {\term} contains products over variables that do not - appear in the conclusion. A typical example is a transitivity axiom. - In that case the {\tt simple apply} tactic fails, and thus is useless. + %% The type of {\term} contains products over variables that do not + %% appear in the conclusion. A typical example is a transitivity axiom. + %% In that case the {\tt simple apply} tactic fails, and thus is useless. \end{ErrMsgs} @@ -3684,7 +3684,7 @@ The {\hintdef} is one of the following expressions: \begin{ErrMsgs} - \item \errindex{Bound head variable} +%% \item \errindex{Bound head variable} \item \term\ \errindex{cannot be used as a hint} @@ -3710,7 +3710,9 @@ The {\hintdef} is one of the following expressions: \item {\ident} \errindex{is not an inductive type} - \item {\ident} \errindex{not declared} +% No need to have this message here, is is generic to all commands +% referring to globals +%% \item {\ident} \errindex{not declared} \end{ErrMsgs} -- cgit v1.2.3 From beedccef9ddc8633c705d7c5ee2f1bbbb3ec8a47 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 2 Oct 2015 17:43:32 +0200 Subject: Updating versions history with data from Gérard. Adding Gérard's history file about V1-V5 versions. --- dev/doc/README-V1-V5 | 293 +++++++++++++++++++++++++++++++++++++++++++ dev/doc/versions-history.tex | 59 ++++++--- 2 files changed, 333 insertions(+), 19 deletions(-) create mode 100644 dev/doc/README-V1-V5 diff --git a/dev/doc/README-V1-V5 b/dev/doc/README-V1-V5 new file mode 100644 index 0000000000..2ca62e3d74 --- /dev/null +++ b/dev/doc/README-V1-V5 @@ -0,0 +1,293 @@ + + Notes on the prehistory of Coq + +This archive contains the sources of the CONSTR ancestor of the Coq proof +assistant. CONSTR, then Coq, was designed and implemented in the Formel team, +joint between the INRIA Rocquencourt laboratory and the Ecole Normale Supérieure +of Paris, from 1984 onwards. + +Version 1 + +This software is a prototype type-checker for a higher-order logical formalism +known as the Theory of Constructions, presented in his PhD thesis by +Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath. +The metamathematical analysis of the system is the +PhD work of Thierry Coquand. The software is mostly the work of Gérard Huet. +Most of the mathematical examples verified with the software are due +to Thierry Coquand. + +The programming language of the CONSTR software (as it was called at the time) +is a version of ML issued from the Edinburgh LCF system and running on +a LISP backend. The main improvements from the original LCF ML are that ML +is compiled rather than interpreted (Gérard Huet building on the original +translator by Lockwood Morris), and that it is enriched by recursively +defined types (work of Guy Cousineau). This ancestor of CAML was used +and improved by Larry Paulson for his implementation of Cambridge LCF. + +Software developments of this prototype occurred from late 1983 to early 1985. + +Version 1.10 was frozen on December 22nd 1984. It is the version used for the +examples in Thierry Coquand's thesis, defended on January 31st 1985. +There was a unique binding operator, used both for universal quantification +(dependent product) at the level of types and functional abstraction (lambda) +at the level of terms/proofs, in the manner of Automath. Substitution +(lambda reduction) was implemented using de Bruijn's indexes. + +Version 1.11 was frozen on February 19th, 1985. It is the version used for the +examples in the paper: +Th. Coquand, G. Huet. Constructions: A Higher Order Proof System for Mechanizing +Mathematics. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag +LNCS 203, pp. 151-184. + +Christine Paulin joined the team at this point, for her DEA research internship. +In her DEA memoir (August 1985) she presents developments for the lambo function +computing the minimal m such that f(m) is greater than n, for f an increasing +integer function, a challenge for constructive mathematics. She also encoded +the majority voting algorithm of Boyer and Moore. + +Version 2 + +The formal system, now renamed as the "Calculus of Constructions", was presented +with a proof of consistency and comparisons with proof systems of Per +Martin Löf, Girard, and the Automath family of N. de Bruijn, in the paper: +T. Coquand and G. Huet. The Calculus of Constructions. +Submitted on June 30th 1985, accepted on December 5th, 1985, +Information and Computation. Preprint as Rapport de Recherche Inria n°530, +Mai 1986. Final version in Information and Computation 76,2/3, Feb. 88. + +An abstraction of the software design, in the form of an abstract machine +for proof checking, and a fuller sequence of mathematical developments was +presented in: +Th. Coquand, G. Huet. Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions. Invited paper, European Logic Colloquium, Orsay, +July 1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. +Published in Logic Colloquium 1985, North-Holland, 1987. + +Version 2.8 was frozen on December 16th, 1985, and served for developing +the exemples in the above papers. + +This calculus was then enriched in version 2.9 with a cumulative hierarchy of +universes. Universe levels were initially explicit natural numbers. +Another improvement was the possibility of automatic synthesis of implicit +type arguments, relieving the user of tedious redundant declarations. + +Christine Paulin wrote an article "Algorithm development in the Calculus of +Constructions", preprint as Rapport de recherche INRIA n°497, March 86. +Final version in Proceedings Symposium on Logic in Computer Science, Cambridge, +MA, 1986 (IEEE Computer Society Press). Besides lambo and majority, +she presents quicksort and a text formatting algorithm. + +Version 2.13 of the calculus of constructions with universes was frozen +on June 25th, 1986. + +A synthetic presentation of type theory along constructive lines with ML +algorithms was given by Gérard Huet in his May 1986 CMU course notes +"Formal Structures for Computation and Deduction". Its chapter +"Induction and Recursion in the Theory of Constructions" was presented +as an invited paper at the Joint Conference on Theory and Practice of Software +Development TAPSOFT’87 at Pise in March 1987, and published as +"Induction Principles Formalized in the Calculus of Constructions" in +Programming of Future Generation Computers, Ed. K. Fuchi and M. Nivat, +North-Holland, 1988. + +Version 3 + +This version saw the beginning of proof automation, with a search algorithm +inspired from PROLOG and the applicative logic programming programs +of the course notes "Formal structures for computation and deduction". +The search algorithm was implemented in ML by Thierry Coquand. +The proof system could thus be used in two modes: proof verification and +proof synthesis, with tactics such as "AUTO". + +The implementation language was now called CAML, for "categorical abstract +machine language". It used as backend the LLM3 virtual machine of Le Lisp +by Jérôme Chailloux. The main developers of CAML were Michel Mauny, +Ascander Suarez and Pierre Weis. + +V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November +1986. V3.4 was developed in the first half of 1987. + +Thierry Coquand held a post-doctoral position in Cambrige University in 1986-87, +where he developed a variant implementation in SML, with which he wrote +some developments on fixpoints in Scott's domains. + +Version 4 + +This version saw the beginning of program extraction from proofs, with +two varieties of the type Prop of propositions, indicating constructive intent. +The proof extraction algorithms were implemented by Christine Paulin-Mohring. + +V4.1 was frozen on July 24th, 1987. It had a first identified library of +mathematical developments (directory exemples), with libraries Logic +(containing impredicative encodings of intuitionistic logic and algebraic +primitives for booleans, natural numbers and list), Peano developing second-order +Peano arithmetic, Arith defining addition, multiplication, euclidean division +and factorial. Typical developments were the Knaster-Tarski theorem +and Newman's lemma from rewriting theory. + +V4.2 was a joint development of a team consisting of Thierry Coquand, Gérard +Huet and Christine Paulin-Mohring. A file V4.2.log records the log of changes. +It was frozen on September 1987 as the last version implemented in CAML 2.3, +and V4.3 followed on CAML 2.5, a more stable development system. + +V4.3 saw the first top-level of the system. Instead of evaluating explicit +quotations, the user could develop his mathematics in a high-level language +called the mathematical vernacular (following Automath terminology). +The user could develop files in the vernacular notation (with .v extension) +which were now separate from the ml sources of the implementation. +Gilles Dowek joined the team to develop the vernacular language as his +DEA internship research. + +A notion of sticky constant was introduced, in order to keep names of lemmas +when local hypotheses of proofs were discharged. This gave a notion +of global mathematical environment with local sections. + +Another significant practical change was that the system, originally developped +on the VAX central computer of our lab, was transferred on SUN personal +workstations, allowing a level of distributed development. +The extraction algorithm was modified, with three annotations Pos, Null and +Typ decorating the sorts Prop and Type. + +Version 4.3 was frozen at the end of November 1987, and was distributed to an +early community of users (among those were Hugo Herbelin and Loic Colson). + +V4.4 saw the first version of (encoded) inductive types. +Now natural numbers could be defined as: +Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. +These inductive types were encoded impredicatively in the calculus, +using a subsystem "rec" due to Christine Paulin. +V4.4 was frozen on March 6th 1988. + +Version 4.5 was the first one to support inductive types and program extraction. +Its banner was "Calcul des Constructions avec Realisations et Synthese". +The vernacular language was enriched to accommodate extraction commands. + +The verification engine design was presented as: +G. Huet. The Constructive Engine. Version 4.5. Invited Conference, 2nd European +Symposium on Programming, Nancy, March 88. +The final paper, describing the V4.9 implementation, appeared in: +A perspective in Theoretical Computer Science, Commemorative Volume in memory +of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. + +Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical +Foundations of Functional Programming organized by Gérard Huet at Austin, Texas. + +Version 4.6 was started during summer 1988. Its main improvement was the +complete rehaul of the proof synthesis engine by Thierry Coquand, with +a tree structure of goals. + +Its source code was communicated to Randy Pollack on September 2nd 1988. +It evolved progressively into LEGO, proof system for Luo's formalism +of Extended Calculus of Constructions. + +The discharge tactic was modified by G. Huet to allow for inter-dependencies +in discharged lemmas. Christine Paulin improved the inductive definition scheme +in order to accommodate predicates of any arity. + +Version 4.7 was started on September 6th, 1988. + +This version starts exploiting the CAML notion of module in order to improve the +modularity of the implementation. Now the term verifier is identified as +a proper module Machine, which the structure of its internal data structures +being hidden and thus accessible only through the legitimate operations. +This machine (the constructive engine) was the trusted core of the +implementation. The proof synthesis mechanism was a separate proof term +generator. Once a complete proof term was synthesized with the help of tactics, +it was entirely re-checked by the engine. Thus there was no need to certify +the tactics, and the system took advantage of this fact by having tactics ignore +the universe levels, universe consistency check being relegated to the final +type-checking pass. This induced a certain puzzlement of early users who saw +their successful proof search ended with QED, followed by silence, followed by +a failure message of universe inconsistency rejection... + +The set of examples comprise set theory experiments by Hugo Herbelin, +and notably the Schroeder-Bernstein theorem. + +Version 4.8, started on October 8th, 1988, saw a major re-implementation of the +abstract syntax type constr, separating variables of the formalism and +metavariables denoting incomplete terms managed by the search mechanism. +A notion of level (with three values TYPE, OBJECT and PROOF) is made explicit +and a type judgement clarifies the constructions, whose implementation is now +fully explicit. Structural equality is speeded up by using pointer equality, +yielding spectacular improvements. Thierry Coquand adapts the proof synthesis +to the new representation, and simplifies pattern matching to 1st order +predicate calculus matching, with important performance gain. + +A new representation of the universe hierarchy is then defined by G. Huet. +Universe levels are now implemented implicitly, through a hidden graph +of abstract levels constrained with an order relation. +Checking acyclicity of the graph insures well-foundedness of the ordering, +and thus consistency. This was documented in a memo +"Adding Type:Type to the Calculus of Constructions" which was never published. + +The development version is released as a stable 4.8 at the end of 1988. + +Version 4.9 is released on March 1st 1989, with the new "elastic" +universe hierarchy. + +The spring 89 saw the first attempt at documenting the system usage, +with a number of papers describing the formalism: +- Metamathematical Investigations of a Calculus of Constructions, by +Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published in +Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, 1990) +- Inductive definitions in the Calculus of Constructions, by +Christine Paulin-Mohring, +- Extracting Fomega's programs from proofs in the Calculus of Constructions, by +Christine Paulin-Mohring (published in POPL'89) +- The Constructive Engine, by Gérard Huet +as well as a number of user guides: +- A short user's guide for the Constructions Version 4.10, by Gérard Huet +- A Vernacular Syllabus, by Gilles Dowek. +- The Tactics Theorem Prover, User's guide, Version 4.10, by Thierry Coquand. + +Stable V4.10, released on May 1st, 1989, was then a mature system, +distributed with CAML V2.6. + +In the mean time, Thierry Coquand and Christine Paulin-Mohring +had been investigating how to add native inductive types to the +Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic +Type Theory. The impredicative encoding had already been presented in: +F. Pfenning and C. Paulin-Mohring. Inductively defined types in the Calculus +of Constructions. Preprint technical report CMU-CS-89-209, final version in +Proceedings of Mathematical Foundations of Programming Semantics, +volume 442, Lecture Notes in Computer Science. Springer-Verlag, 1990. +An extension of the calculus with primitive inductive types appeared in: +Th. Coquand and C. Paulin-Mohring. Inductively defined types. +In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417, +Lecture Notes in Computer Science. Springer-Verlag, 1990. + +This lead to the Calculus of Inductive Constructions, logical formalism +implemented in Versions 5 upward of the system, and documented in: +C. Paulin-Mohring. Inductive Definitions in the System Coq - Rules and +Properties. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference +Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer +Science, 1993. + +The last version of CONSTR is Version 4.11, which was last distributed +in Spring 1990. It was demonstrated at the first workshop of the European +Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990. + +At the end of 1989, Version 5.1 was started, and renamed as the system Coq +for the Calculus of Inductive Constructions. It was then ported to the new +stand-alone implementation of ML called Caml-light. + +In 1990 many changes occurred. Thierry Coquand left for Chalmers University +in Göteborg. Christine Paulin-Mohring took a CNRS researcher position +at the LIP laboratory of Ecole Normale Supérieure de Lyon. Project Formel +was terminated, and gave rise to two teams: Cristal at INRIA-Roquencourt, +that continued developments in functional programming with Caml-light then +Ocaml, and Coq, continuing the type theory research, with a joint team +headed by Gérard Huet at INRIA-Rocquencourt and Christine Paulin-Mohring +at the LIP laboratory of CNRS-ENS Lyon. + +Chetan Murthy joined the team in 1991 and became the main software architect +of Version 5. He completely rehauled the implementation for efficiency. +Versions 5.6 and 5.8 were major distributed versions, with complete +documentation and a library of users' developements. The use of the RCS +revision control system, and systematic ChangeLog files, allow a more +precise tracking of the software developments. + +Developments from Version 6 upwards are documented in the credits section of +Coq's Reference Manual. + +September 2015 +Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index fab6a37ef4..1b1d3500a4 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -10,55 +10,76 @@ \begin{center} \begin{huge} -An history of Coq versions +A history of Coq versions \end{huge} \end{center} \bigskip \centerline{\large 1984-1989: The Calculus of Constructions} + +\bigskip +\centerline{\large (see README.V1-V5 for details)} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline -CoC V1.10& mention of dates from 6 December & implementation language is Caml\\ - & 1984 to 13 February 1985 \\ -CoC V1.11& mention of dates from 6 December\\ - & 1984 to 19 February 1985\\ +CONSTR V1.10& mention of dates from 6 December & \feature{type-checker for Coquand's Calculus }\\ + & 1984 to 13 February 1985 & \feature{of Constructions}, implementation \\ + & frozen 22 December 1984 & language is a predecessor of CAML\\ + +CONSTR V1.11& mention of dates from 6 December\\ + & 1984 to 19 February 1985 (freeze date) &\\ + +CoC V2.8& dated 16 December 1985 (freeze date)\\ -CoC V2.13& dated 16 December 1985\\ +CoC V2.9& & \feature{cumulative hierarchy of universes}\\ -CoC V2.13& dated 25 June 1986\\ +CoC V2.13& dated 25 June 1986 (freeze date)\\ -CoC V3.1& dated 20 November 1986 & \feature{auto}\\ +CoC V3.1& started summer 1986 & \feature{AUTO tactic}\\ + & dated 20 November 1986 & implementation language now named CAML\\ CoC V3.2& dated 27 November 1986\\ -CoC V3.3 and V3.4& dated 1 January 1987 & creation of a directory for examples\\ +CoC V3.3& dated 1 January 1987 & creation of a directory for examples\\ -CoC V4.1& dated 24 July 1987\\ +CoC V3.4& dated 1 January 1987 & \feature{lambda and product distinguished in the syntax}\\ + +CoC V4.1& dated 24 July 1987 (freeze date)\\ CoC V4.2& dated 10 September 1987\\ -CoC V4.3& dated 15 September 1987\\ +CoC V4.3& dated 15 September 1987 & \feature{mathematical vernacular toplevel}\\ + & frozen November 1987 & \feature{section mechanism}\\ + & & \feature{logical vs computational content (sorte Spec)}\\ + & & \feature{LCF engine}\\ + +CoC V4.4& dated 27 January 1988 & \feature{impredicatively encoded inductive types}\\ + & frozen March 1988\\ -CoC V4.4& dated 27 January 1988\\ +CoC V4.5 and V4.5.5& dated 15 March 1988 & \feature{program extraction}\\ + & demonstrated in June 1988\\ -CoC V4.5 and V4.5.5& dated 15 March 1988\\ +CoC V4.6& dated 1 September 1988 & start of LEGO fork\\ -CoC V4.6 and V4.7& dated 1 September 1988\\ +CoC V4.7& started 6 September 1988 \\ -CoC V4.8& dated 1 December 1988\\ +CoC V4.8& dated 1 December 1988 (release time) & \feature{floating universes}\\ -CoC V4.8.5& dated 1 February 1989\\ +CoC V4.8.5& dated 1 February 1989 & \\ -CoC V4.9& dated 1 March 1989\\ +CoC V4.9& dated 1 March 1989 (release date)\\ -CoC V4.10 and 4.10.1& dated 1 May 1989 & first public release - in English\\ +CoC V4.10 and 4.10.1& dated 1 May 1989 & released with documentation in English\\ \end{tabular} \bigskip + +\noindent Note: CoC above stands as an abbreviation for {\em Calculus of + Constructions}, official name of the system. +\bigskip \bigskip \newpage @@ -80,7 +101,7 @@ Coq V5.2 & log dated 4 October 1990 & internal use \\ Coq V5.3 & log dated 12 October 1990 & internal use \\ -Coq V5.4 & headers dated 24 October 1990 & internal use, \feature{extraction} (version 1) [3-12-90]\\ +Coq V5.4 & headers dated 24 October 1990 & internal use, new \feature{extraction} (version 1) [3-12-90]\\ Coq V5.5 & started 6 December 1990 & internal use \\ -- cgit v1.2.3 From f41de34bcd48f008cf7d3fae4c7fce925048e606 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 2 Oct 2015 21:32:25 +0200 Subject: Mark the Coq.Compat files for documentation. (Fix bug #4353) --- doc/stdlib/index-list.html.template | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 024e13413a..866193ffb4 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -591,7 +591,7 @@ through the Require Import command.

Program: - Support for dependently-typed programming. + Support for dependently-typed programming
theories/Program/Basics.v @@ -612,4 +612,12 @@ through the Require Import command.

theories/Unicode/Utf8_core.v theories/Unicode/Utf8.v
+ +
Compat: + Compatibility wrappers for previous versions of Coq +
+
+ theories/Compat/Coq84.v + theories/Compat/Coq85.v +
-- cgit v1.2.3 From 2b033589d1b7900fdb86dfad145f1c284657ae8c Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sun, 4 Oct 2015 09:22:16 +0200 Subject: Fix typo. (Fix bug #4355) --- doc/refman/RefMan-oth.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 739a89af4c..4b2b8660c2 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -967,8 +967,8 @@ the constants {\qualid$_1$} {\ldots} {\qualid$_n$} in tactics using $\delta$-conversion (unfolding a constant is replacing it by its definition). -{\tt Opaque} has also on effect on the conversion algorithm of {\Coq}, -telling it to delay the unfolding of a constant as mush as possible when +{\tt Opaque} has also an effect on the conversion algorithm of {\Coq}, +telling it to delay the unfolding of a constant as much as possible when {\Coq} has to check the conversion (see Section~\ref{conv-rules}) of two distinct applied constants. -- cgit v1.2.3 From 6f51b8cafe7a873600e7a0c8675a72a8aee40184 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 5 Oct 2015 10:29:37 +0200 Subject: Univs: fix handling of evar_map in identity coercion construction. --- toplevel/class.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/toplevel/class.ml b/toplevel/class.ml index 0e270f960b..f925a2d07e 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -186,8 +186,9 @@ let error_not_transparent source = let build_id_coercion idf_opt source poly = let env = Global.env () in - let vs, ctx = match source with - | CL_CONST sp -> Universes.fresh_global_instance env (ConstRef sp) + let sigma = Evd.from_env env in + let sigma, vs = match source with + | CL_CONST sp -> Evd.fresh_global env sigma (ConstRef sp) | _ -> error_not_transparent source in let c = match constant_opt_value_in env (destConst vs) with | Some c -> c @@ -208,8 +209,8 @@ let build_id_coercion idf_opt source poly = (* juste pour verification *) let _ = if not - (Reductionops.is_conv_leq env Evd.empty - (Typing.unsafe_type_of env Evd.empty val_f) typ_f) + (Reductionops.is_conv_leq env sigma + (Typing.unsafe_type_of env sigma val_f) typ_f) then errorlabstrm "" (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") @@ -218,13 +219,13 @@ let build_id_coercion idf_opt source poly = match idf_opt with | Some idf -> idf | None -> - let cl,u,_ = find_class_type Evd.empty t in + let cl,u,_ = find_class_type sigma t in Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry - (definition_entry ~types:typ_f ~poly ~univs:(Univ.ContextSet.to_context ctx) + (definition_entry ~types:typ_f ~poly ~univs:(Evd.universe_context sigma) ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) in let decl = (constr_entry, IsDefinition IdentityCoercion) in -- cgit v1.2.3 From bba2cfb5921653f18d6cedf2800cdc1abf9310af Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 5 Oct 2015 16:34:57 +0200 Subject: Update the .mailmap file. The update process is as follows: run "git shortlog -s -e" and look for duplicate or missing contributors. --- .mailmap | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/.mailmap b/.mailmap index 7223b7354a..13c71558f0 100644 --- a/.mailmap +++ b/.mailmap @@ -9,47 +9,47 @@ ## If you're mentionned here and want to update your information, ## either amend this file and commit it, or contact the coqdev list +Jim Apple jbapple Bruno Barras barras Bruno Barras barras-local Yves Bertot bertot -Yves Bertot Yves Bertot Frédéric Besson fbesson Pierre Boutillier pboutill Pierre Boutillier Pierre Pierre Boutillier Pierre Boutillier Xavier Clerc xclerc Xavier Clerc xclerc -Pierre Corbineau corbinea +Pierre Corbineau corbinea Judicaël Courant courant Pierre Courtieu courtieu -# uncapitalises the email address: -Pierre Courtieu Pierre Courtieu David Delahaye delahaye Maxime Dénès mdenes Daniel De Rauglaudre ddr Olivier Desmettre desmettr Damien Doligez doligez -Jean-Christophe Filliâtre filliatr +Jean-Christophe Filliâtre filliatr +Jean-Christophe Filliâtre Jean-Christophe Filliatre Julien Forest jforest Julien Forest forest Julien Forest jforest +Julien Forest jforest Stéphane Glondu glondu -# corrects accent: Stéphane Glondu Stephane Glondu -Benjamin Grégoire bgregoir -Benjamin Grégoire gregoire +Benjamin Grégoire Benjamin Gregoire +Benjamin Grégoire bgregoir +Benjamin Grégoire gregoire Jason Gross Jason Gross +Jason Gross Jason Gross Vincent Gross vgross Huang Guan-Shieng huang Hugo Herbelin herbelin -# uncapitalises the email address: -Hugo Herbelin Hugo Herbelin Tom Hutchinson thutchin Cezary Kaliszyk cek Florent Kirchner fkirchne Florent Kirchner kirchner +Marc Lasson mlasson Pierre Letouzey letouzey -Assia Mahboubi amahboub +Assia Mahboubi amahboub Evgeny Makarov emakarov Gregory Malecha Gregory Malecha Lionel Elie Mamane lmamane @@ -68,7 +68,7 @@ Christine Paulin mohring ppedrot Loïc Pottier pottier Matthias Puech puech -Yann Régis-Gianas regisgia +Yann Régis-Gianas regisgia Clément Renard clrenard Claudio Sacerdoti Coen sacerdot Vincent Siles vsiles @@ -77,8 +77,7 @@ Matthieu Sozeau msozeau Matthieu Sozeau Arnaud Spiwack aspiwack Enrico Tassi gareuselesinge -# uncapitalizes the email address -Enrico Tassi Enrico Tassi +Enrico Tassi Enrico Tassi Enrico Tassi Enrico Tassi Laurent Théry thery Benjamin Werner werner -- cgit v1.2.3 From 92ee78086f1ca89646ac69a00256ff45fcaee22c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 5 Oct 2015 17:00:11 +0200 Subject: Univs: fix printing bug #3797. --- printing/printmod.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/printing/printmod.ml b/printing/printmod.ml index a80bbb146a..53d0508c7f 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -259,6 +259,10 @@ let print_body is_impl env mp (l,body) = | SFBmodule _ -> keyword "Module" ++ spc () ++ name | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name | SFBconst cb -> + let u = + if cb.const_polymorphic then Univ.UContext.instance cb.const_universes + else Univ.Instance.empty + in (match cb.const_body with | Def _ -> def "Definition" ++ spc () | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () @@ -268,14 +272,16 @@ let print_body is_impl env mp (l,body) = | Some env -> str " :" ++ spc () ++ hov 0 (Printer.pr_ltype_env env Evd.empty (* No evars in modules *) - (Typeops.type_of_constant_type env cb.const_type)) ++ + (Vars.subst_instance_constr u + (Typeops.type_of_constant_type env cb.const_type))) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ hov 2 (str ":= " ++ - Printer.pr_lconstr_env env Evd.empty (Mod_subst.force_constr l)) + Printer.pr_lconstr_env env Evd.empty + (Vars.subst_instance_constr u (Mod_subst.force_constr l))) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx cb.const_universes) + Printer.pr_universe_ctx (Univ.instantiate_univ_context cb.const_universes)) | SFBmind mib -> try let env = Option.get env in -- cgit v1.2.3 From efce61af32ff1b09a21dcf88bca7d6609a0bfd27 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 5 Oct 2015 17:22:31 +0200 Subject: Univs: fix bug #4288, Print Sorted generated backward < constraints. --- kernel/univ.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/kernel/univ.ml b/kernel/univ.ml index 73d323426b..34eb283d73 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1582,8 +1582,8 @@ let sort_universes orig = let sorted = LMap.fold fold compact UMap.empty in (** Add all [Type.n] nodes *) let fold i accu u = - if 0 < i then - let pred = types.(i - 1) in + if i < max then + let pred = types.(i + 1) in let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in UMap.add u (Canonical arc) accu else accu -- cgit v1.2.3 From 07f4e6b07775052cc1c5dc34cdfa7ad4eacfa94f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 4 Oct 2015 14:50:45 +0200 Subject: Fix bug #4354: interpret hints in the right env and sigma. --- pretyping/evd.ml | 5 ++++- tactics/auto.ml | 7 +++++-- tactics/class_tactics.ml | 6 +++--- tactics/eauto.ml4 | 5 +++-- tactics/hints.ml | 23 ++++++++++++----------- tactics/hints.mli | 4 ++-- test-suite/bugs/closed/4354.v | 10 ++++++++++ 7 files changed, 39 insertions(+), 21 deletions(-) create mode 100644 test-suite/bugs/closed/4354.v diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 842b87c57e..4e0b6f75e7 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -312,7 +312,10 @@ let union_evar_universe_context ctx ctx' = let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) (Univ.ContextSet.levels ctx.uctx_local) in - let declarenew g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g in + let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in + let declarenew g = + Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g + in let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; diff --git a/tactics/auto.ml b/tactics/auto.ml index 72ba9e0bd9..e5fdf6a7c2 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -309,7 +309,8 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in let hyp = Context.map_named_declaration nf decl in let hintl = make_resolve_hyp env sigma hyp - in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) + in trivial_fail_db dbg mod_delta db_list + (Hint_db.add_list env sigma hintl local_db) end) in Proofview.Goal.enter begin fun gl -> @@ -438,7 +439,9 @@ let possible_resolve dbg mod_delta db_list local_db cl = with Not_found -> [] let extend_local_db decl db gl = - Hint_db.add_list (make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) decl) db + let env = Tacmach.New.pf_env gl in + let sigma = Proofview.Goal.sigma gl in + Hint_db.add_list env sigma (make_resolve_hyp env sigma decl) db (* Introduce an hypothesis, then call the continuation tactic [kont] with the hint db extended with the so-obtained hypothesis *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 80f47c680f..ed5b783f6c 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -190,7 +190,7 @@ let rec e_trivial_fail_db db_list local_db goal = let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list - (Hint_db.add_list hintl local_db) g'))) :: + (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: (List.map (fun (x,_,_,_,_) -> x) (e_trivial_resolve db_list local_db (project goal) (pf_concl goal))) in @@ -339,7 +339,7 @@ let make_hints g st only_classes sign = (PathOr (paths, path), hint @ hints) else (paths, hints)) (PathEmpty, []) sign - in Hint_db.add_list hintlist (Hint_db.empty st true) + in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) let make_autogoal_hints = let cache = ref (true, Environ.empty_named_context_val, @@ -374,7 +374,7 @@ let intro_tac : atac = let context = Environ.named_context_of_val (Goal.V82.hyps s g') in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) (true,false,false) info.only_classes None (List.hd context) in - let ldb = Hint_db.add_list hint info.hints in + let ldb = Hint_db.add_list env s hint info.hints in (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls in {it = gls'; sigma = s;}) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 34f87c6cf0..83498cabd8 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -147,7 +147,7 @@ let rec e_trivial_fail_db db_list local_db goal = let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list - (Hint_db.add_list hintl local_db) g'))) :: + (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) in tclFIRST (List.map tclCOMPLETE tacl) goal @@ -269,7 +269,8 @@ module SearchProblem = struct let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in - let ldb = Hint_db.add_list hintl (List.hd s.localdb) in + let ldb = Hint_db.add_list (pf_env g') (project g') + hintl (List.hd s.localdb) in { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb; prev = ps }) diff --git a/tactics/hints.ml b/tactics/hints.ml index a7eae667d0..dbb2340364 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -266,11 +266,10 @@ let strip_params env c = | _ -> c) | _ -> c -let instantiate_hint p = +let instantiate_hint env sigma p = let mk_clenv c cty ctx = - let env = Global.env () in - let sigma = Evd.merge_context_set univ_flexible (Evd.from_env env) ctx in - let cl = mk_clenv_from_env (Global.env()) sigma None (c,cty) in + let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let cl = mk_clenv_from_env env sigma None (c,cty) in {cl with templval = { cl.templval with rebus = strip_params env cl.templval.rebus }; env = empty_env} @@ -524,8 +523,8 @@ module Hint_db = struct in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - let add_one (k, v) db = - let v = instantiate_hint v in + let add_one env sigma (k, v) db = + let v = instantiate_hint env sigma v in let st',db,rebuild = match v.code.obj with | Unfold_nth egr -> @@ -542,7 +541,7 @@ module Hint_db = struct let db, id = next_hint_id db in addkv k id v db - let add_list l db = List.fold_left (fun db k -> add_one k db) db l + let add_list env sigma l db = List.fold_left (fun db k -> add_one env sigma k db) db l let remove_sdl p sdl = List.smartfilter p sdl @@ -812,7 +811,9 @@ let add_hint dbname hintlist = in let () = List.iter check hintlist in let db = get_db dbname in - let db' = Hint_db.add_list hintlist db in + let env = Global.env () in + let sigma = Evd.from_env env in + let db' = Hint_db.add_list env sigma hintlist db in searchtable_add (dbname,db') let add_transparency dbname grs b = @@ -1166,8 +1167,8 @@ let expand_constructor_hints env sigma lems = let add_hint_lemmas env sigma eapply lems hint_db = let lems = expand_constructor_hints env sigma lems in let hintlist' = - List.map_append (make_resolves env sigma (eapply,true,false) None true) lems in - Hint_db.add_list hintlist' hint_db + List.map_append (make_resolves env sigma (eapply,true,false) None false) lems in + Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = let sign = Environ.named_context env in @@ -1177,7 +1178,7 @@ let make_local_hint_db env sigma ts eapply lems = in let hintlist = List.map_append (make_resolve_hyp env sigma) sign in add_hint_lemmas env sigma eapply lems - (Hint_db.add_list hintlist (Hint_db.empty ts false)) + (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false)) let make_local_hint_db = if Flags.profile then diff --git a/tactics/hints.mli b/tactics/hints.mli index 687bc78c76..5a4fb77091 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -93,8 +93,8 @@ module Hint_db : arguments. *) val map_auto : (global_reference * constr array) -> constr -> t -> full_hint list - val add_one : hint_entry -> t -> t - val add_list : (hint_entry) list -> t -> t + val add_one : env -> evar_map -> hint_entry -> t -> t + val add_list : env -> evar_map -> hint_entry list -> t -> t val remove_one : global_reference -> t -> t val remove_list : global_reference list -> t -> t val iter : (global_reference option -> bool array list -> full_hint list -> unit) -> t -> unit diff --git a/test-suite/bugs/closed/4354.v b/test-suite/bugs/closed/4354.v new file mode 100644 index 0000000000..6a2f9672d3 --- /dev/null +++ b/test-suite/bugs/closed/4354.v @@ -0,0 +1,10 @@ +Inductive True : Prop := I. +Class Lift (T : Type). +Axiom closed_increment : forall {T} {H : Lift T}, True. +Create HintDb core. +Lemma closed_monotonic T (H : Lift T) : True. + auto using closed_increment. Show Universes. +Qed. + +(* also fails with -nois, so the content of the hint database does not matter +*) \ No newline at end of file -- cgit v1.2.3 From df9caebb04fb681ec66b79c41ae01918cd2336de Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 6 Oct 2015 09:58:20 +0200 Subject: Univs (pretyping): call vm_compute/native_compute with the current universe graph --- pretyping/pretyping.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f18657da82..2efd8fe413 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -903,7 +903,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in if not (occur_existential cty || occur_existential tval) then begin - try + try + let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj with Reduction.NotConvertible -> error_actual_type_loc loc env !evdref cj tval @@ -915,6 +916,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in let evars = Nativenorm.evars_of_evar_map !evdref in + let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in begin try ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj -- cgit v1.2.3 From 840155eafd9607c7656c80770de1e2819fe56a13 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 6 Oct 2015 13:38:15 +0200 Subject: Fixing emacs output in debugging mode. Goal displaying during Debugging ltac is a notice message now. Other messages are debug messages. This does not change anything in coqide or coqtop, but allows proofgeneral to dispatch them in the right buffers (pg had to be fixed too). --- proofs/logic_monad.ml | 6 +++++- proofs/logic_monad.mli | 4 ++++ proofs/tactic_debug.ml | 5 +++-- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml index cb3e5a1860..81f02b66db 100644 --- a/proofs/logic_monad.ml +++ b/proofs/logic_monad.ml @@ -95,7 +95,11 @@ struct let print_char = fun c -> (); fun () -> print_char c (** {!Pp.pp}. The buffer is also flushed. *) - let print = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e -> + let print_debug = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e -> + let (e, info) = Errors.push e in raise ~info e () + + (** {!Pp.pp}. The buffer is also flushed. *) + let print = fun s -> (); fun () -> try Pp.msg_notice s; Pp.pp_flush () with e -> let (e, info) = Errors.push e in raise ~info e () let timeout = fun n t -> (); fun () -> diff --git a/proofs/logic_monad.mli b/proofs/logic_monad.mli index ab729aff71..511dd7a6ed 100644 --- a/proofs/logic_monad.mli +++ b/proofs/logic_monad.mli @@ -58,6 +58,10 @@ module NonLogical : sig (** {!Pp.pp}. The buffer is also flushed. *) val print : Pp.std_ppcmds -> unit t + (* FIXME: shouldn't we have a logger instead? *) + (** {!Pp.pp}. The buffer is also flushed. *) + val print_debug : Pp.std_ppcmds -> unit t + (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) val raise : ?info:Exninfo.info -> exn -> 'a t diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index d7f4b5ead5..667765dbf2 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -32,7 +32,8 @@ let explain_logic_error = ref (fun e -> mt()) let explain_logic_error_no_anomaly = ref (fun e -> mt()) -let msg_tac_debug s = Proofview.NonLogical.print (s++fnl()) +let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print (s++fnl()) (* Prints the goal *) @@ -48,7 +49,7 @@ let db_pr_goal gl = let db_pr_goal = Proofview.Goal.nf_enter begin fun gl -> let pg = db_pr_goal gl in - Proofview.tclLIFT (msg_tac_debug (str "Goal:" ++ fnl () ++ pg)) + Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) end -- cgit v1.2.3 From 84add29c036735ceacde73ea98a9a5a454a5e3a0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 6 Oct 2015 19:09:10 +0200 Subject: Splitting kernel universe code in two modules. 1. The Univ module now only cares about definitions about universes. 2. The UGraph module contains the algorithm responsible for aciclicity. --- dev/printers.mllib | 1 + dev/top_printers.ml | 2 +- engine/evd.ml | 44 +-- engine/evd.mli | 4 +- kernel/constr.ml | 20 +- kernel/constr.mli | 8 +- kernel/environ.ml | 12 +- kernel/environ.mli | 2 +- kernel/indtypes.ml | 4 +- kernel/kernel.mllib | 1 + kernel/mod_typing.ml | 2 +- kernel/pre_env.ml | 4 +- kernel/pre_env.mli | 2 +- kernel/reduction.ml | 16 +- kernel/reduction.mli | 6 +- kernel/subtyping.ml | 2 +- kernel/term.mli | 4 +- kernel/uGraph.ml | 868 +++++++++++++++++++++++++++++++++++++++++++++ kernel/uGraph.mli | 63 ++++ kernel/univ.ml | 834 ------------------------------------------- kernel/univ.mli | 54 +-- library/global.mli | 2 +- library/universes.ml | 34 +- library/universes.mli | 10 +- pretyping/pretyping.ml | 2 +- pretyping/reductionops.mli | 2 +- toplevel/vernacentries.ml | 8 +- 27 files changed, 1034 insertions(+), 977 deletions(-) create mode 100644 kernel/uGraph.ml create mode 100644 kernel/uGraph.mli diff --git a/dev/printers.mllib b/dev/printers.mllib index 07b48ed573..f19edf1c80 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -55,6 +55,7 @@ Monad Names Univ +UGraph Esubst Uint31 Sorts diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0900bb0962..1d3d711ac7 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -221,7 +221,7 @@ let ppuniverseconstraints c = pp (Universes.Constraints.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx -let ppuniverses u = pp (Univ.pr_universes Level.pr u) +let ppuniverses u = pp (UGraph.pr_universes Level.pr u) let ppnamedcontextval e = pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e)) diff --git a/engine/evd.ml b/engine/evd.ml index cd0b52ecaa..3f4bfe7afe 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -283,8 +283,8 @@ type evar_universe_context = (** The subset of unification variables that can be instantiated with algebraic universes as they appear in types and universe instances only. *) - uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) - uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *) + uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) + uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) } let empty_evar_universe_context = @@ -292,8 +292,8 @@ let empty_evar_universe_context = uctx_local = Univ.ContextSet.empty; uctx_univ_variables = Univ.LMap.empty; uctx_univ_algebraic = Univ.LSet.empty; - uctx_universes = Univ.initial_universes; - uctx_initial_universes = Univ.initial_universes } + uctx_universes = UGraph.initial_universes; + uctx_initial_universes = UGraph.initial_universes } let evar_universe_context_from e = let u = universes e in @@ -314,7 +314,7 @@ let union_evar_universe_context ctx ctx' = (Univ.ContextSet.levels ctx.uctx_local) in let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in let declarenew g = - Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g + Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); @@ -328,7 +328,7 @@ let union_evar_universe_context ctx ctx' = if local == ctx.uctx_local then ctx.uctx_universes else let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in - Univ.merge_constraints cstrsr (declarenew ctx.uctx_universes) } + UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes) } (* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) (* let union_evar_universe_context = *) @@ -374,7 +374,7 @@ let process_universe_constraints univs vars alg cstrs = | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) in if d == Universes.ULe then - if Univ.check_leq univs l r then + if UGraph.check_leq univs l r then (** Keep Prop/Set <= var around if var might be instantiated by prop or set later. *) if Univ.Universe.is_level l then @@ -413,7 +413,7 @@ let process_universe_constraints univs vars alg cstrs = instantiate_variable l' r vars else if rloc then instantiate_variable r' l vars - else if not (Univ.check_eq univs l r) then + else if not (UGraph.check_eq univs l r) then (* Two rigid/global levels, none of them being local, one of them being Prop/Set, disallow *) if Univ.Level.is_small l' || Univ.Level.is_small r' then @@ -433,7 +433,7 @@ let process_universe_constraints univs vars alg cstrs = Univ.enforce_leq inst lu local else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) | _, _ (* One of the two is algebraic or global *) -> - if Univ.check_eq univs l r then local + if UGraph.check_eq univs l r then local else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) in let local = @@ -459,7 +459,7 @@ let add_constraints_context ctx cstrs = in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; - uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } + uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } (* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) (* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) @@ -473,7 +473,7 @@ let add_universe_constraints_context ctx cstrs = in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; - uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } + uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } (* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) (* let add_universe_constraints_context = *) @@ -1012,13 +1012,13 @@ let merge_uctx sideff rigid uctx ctx' = in let declare g = LSet.fold (fun u g -> - try Univ.add_universe u false g - with Univ.AlreadyDeclared when sideff -> g) + try UGraph.add_universe u false g + with UGraph.AlreadyDeclared when sideff -> g) levels g in let initial = declare uctx.uctx_initial_universes in let univs = declare uctx.uctx_universes in - let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in + let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } let merge_context_set rigid evd ctx' = @@ -1079,11 +1079,11 @@ let uctx_new_univ_variable rigid name predicative | None -> uctx.uctx_names in let initial = - Univ.add_universe u false uctx.uctx_initial_universes + UGraph.add_universe u false uctx.uctx_initial_universes in let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = Univ.add_universe u false uctx.uctx_universes; + uctx_universes = UGraph.add_universe u false uctx.uctx_universes; uctx_initial_universes = initial} in uctx', u @@ -1102,10 +1102,10 @@ let new_sort_variable ?name ?(predicative=true) rigid d = let add_global_univ d u = let uctx = d.universes in let initial = - Univ.add_universe u true uctx.uctx_initial_universes + UGraph.add_universe u true uctx.uctx_initial_universes in let univs = - Univ.add_universe u true uctx.uctx_universes + UGraph.add_universe u true uctx.uctx_universes in { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; @@ -1245,10 +1245,10 @@ let set_leq_sort env evd s1 s2 = else evd let check_eq evd s s' = - Univ.check_eq evd.universes.uctx_universes s s' + UGraph.check_eq evd.universes.uctx_universes s s' let check_leq evd s s' = - Univ.check_leq evd.universes.uctx_universes s s' + UGraph.check_leq evd.universes.uctx_universes s s' let subst_univs_context_with_def def usubst (ctx, cst) = (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) @@ -1301,10 +1301,10 @@ let refresh_undefined_univ_variables uctx = (Option.map (Univ.subst_univs_level_universe subst) v) acc) uctx.uctx_univ_variables Univ.LMap.empty in - let declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g) + let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) (Univ.ContextSet.levels ctx') g in let initial = declare uctx.uctx_initial_universes in - let univs = declare Univ.initial_universes in + let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; uctx_local = ctx'; uctx_univ_variables = vars; uctx_univ_algebraic = alg; diff --git a/engine/evd.mli b/engine/evd.mli index db60f5ff43..22d0174973 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -489,7 +489,7 @@ val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map val universe_of_name : evar_map -> string -> Univ.universe_level val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map -val universes : evar_map -> Univ.universes +val universes : evar_map -> UGraph.t val add_constraints_context : evar_universe_context -> Univ.constraints -> evar_universe_context @@ -532,7 +532,7 @@ val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set val universe_context : ?names:(Id.t located) list -> evar_map -> Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst -val universes : evar_map -> Univ.universes +val universes : evar_map -> UGraph.t val merge_universe_context : evar_map -> evar_universe_context -> evar_map diff --git a/kernel/constr.ml b/kernel/constr.ml index e2b1d3fd9c..753d188455 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -545,8 +545,8 @@ let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) let eq_constr_univs univs m n = if m == n then true else - let eq_universes _ = Univ.Instance.check_eq univs in - let eq_sorts s1 s2 = s1 == s2 || Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let eq_universes _ = UGraph.check_eq_instances univs in + let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in compare_head_gen eq_universes eq_sorts eq_constr' m n @@ -554,11 +554,11 @@ let eq_constr_univs univs m n = let leq_constr_univs univs m n = if m == n then true else - let eq_universes _ = Univ.Instance.check_eq univs in + let eq_universes _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || - Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let leq_sorts s1 s2 = s1 == s2 || - Univ.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + UGraph.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in @@ -571,12 +571,12 @@ let eq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in - let eq_universes strict = Univ.Instance.check_eq univs in + let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true + if UGraph.check_eq univs u1 u2 then true else (cstrs := Univ.enforce_eq u1 u2 !cstrs; true) @@ -591,12 +591,12 @@ let leq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in - let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in + let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true + if UGraph.check_eq univs u1 u2 then true else (cstrs := Univ.enforce_eq u1 u2 !cstrs; true) in @@ -604,7 +604,7 @@ let leq_constr_univs_infer univs m n = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_leq univs u1 u2 then true + if UGraph.check_leq univs u1 u2 then true else (cstrs := Univ.enforce_leq u1 u2 !cstrs; true) diff --git a/kernel/constr.mli b/kernel/constr.mli index e6a3e71f89..5a370d31d8 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -205,19 +205,19 @@ val equal : constr -> constr -> bool (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [u]. *) -val eq_constr_univs : constr Univ.check_function +val eq_constr_univs : constr UGraph.check_function (** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) -val leq_constr_univs : constr Univ.check_function +val leq_constr_univs : constr UGraph.check_function (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [u]. *) -val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained +val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained (** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) -val leq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained +val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained (** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and ignoring universe instances. *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 1cc07c0ab8..09fe64d77b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -188,10 +188,10 @@ let map_universes f env = let add_constraints c env = if Univ.Constraint.is_empty c then env - else map_universes (Univ.merge_constraints c) env + else map_universes (UGraph.merge_constraints c) env let check_constraints c env = - Univ.check_constraints c env.env_stratification.env_universes + UGraph.check_constraints c env.env_stratification.env_universes let push_constraints_to_env (_,univs) env = add_constraints univs env @@ -199,19 +199,19 @@ let push_constraints_to_env (_,univs) env = let add_universes strict ctx g = let g = Array.fold_left (* Be lenient, module typing reintroduces universes and constraints due to includes *) - (fun g v -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + (fun g v -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) g (Univ.Instance.to_array (Univ.UContext.instance ctx)) in - Univ.merge_constraints (Univ.UContext.constraints ctx) g + UGraph.merge_constraints (Univ.UContext.constraints ctx) g let push_context ?(strict=false) ctx env = map_universes (add_universes strict ctx) env let add_universes_set strict ctx g = let g = Univ.LSet.fold - (fun v g -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + (fun v g -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) (Univ.ContextSet.levels ctx) g - in Univ.merge_constraints (Univ.ContextSet.constraints ctx) g + in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g let push_context_set ?(strict=false) ctx env = map_universes (add_universes_set strict ctx) env diff --git a/kernel/environ.mli b/kernel/environ.mli index 9f6ea522a7..714c260666 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -41,7 +41,7 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env -val universes : env -> Univ.universes +val universes : env -> UGraph.t val rel_context : env -> rel_context val named_context : env -> named_context val named_context_val : env -> named_context_val diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 5a234d09b9..155ad79879 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -290,7 +290,7 @@ let typecheck_inductive env mie = let full_polymorphic () = let defu = Term.univ_of_sort def_level in let is_natural = - type_in_type env || (check_leq (universes env') infu defu && + type_in_type env || (UGraph.check_leq (universes env') infu defu && not (is_type0m_univ defu && not is_unit) (* (~ is_type0m_univ defu \/ is_unit) (\* infu <= defu && not prop or unital *\) *) @@ -320,7 +320,7 @@ let typecheck_inductive env mie = (* conclusions of the parameters *) (* We enforce [u >= lev] in case [lev] has a strict upper *) (* constraints over [u] *) - let b = type_in_type env || check_leq (universes env') infu u in + let b = type_in_type env || UGraph.check_leq (universes env') infu u in if not b then anomaly ~label:"check_inductive" (Pp.str"Incorrect universe " ++ diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 29fe887d75..f7220c94a1 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -1,6 +1,7 @@ Names Uint31 Univ +UGraph Esubst Sorts Evar diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 922652287b..0f3ea1d0a6 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -104,7 +104,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let csti = Univ.enforce_eq_instances cus newus cst in let csta = Univ.Constraint.union csti ccst in let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in - let () = if not (Univ.check_constraints cst (Environ.universes env')) then + let () = if not (UGraph.check_constraints cst (Environ.universes env')) then error_incorrect_with_constraint lab in let cst = match cb.const_body with diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 5f3f559a2c..615b9d49ba 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -45,7 +45,7 @@ type globals = { env_modtypes : module_type_body MPmap.t} type stratification = { - env_universes : universes; + env_universes : UGraph.t; env_engagement : engagement } @@ -93,7 +93,7 @@ let empty_env = { env_rel_val = []; env_nb_rel = 0; env_stratification = { - env_universes = initial_universes; + env_universes = UGraph.initial_universes; env_engagement = (PredicativeSet,StratifiedType) }; env_conv_oracle = Conv_oracle.empty; retroknowledge = Retroknowledge.initial_retroknowledge; diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 0ce0bed235..b499ac0c52 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -32,7 +32,7 @@ type globals = { env_modtypes : module_type_body MPmap.t} type stratification = { - env_universes : universes; + env_universes : UGraph.t; env_engagement : engagement } diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 2cf3f88735..29c6009ce4 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -147,7 +147,7 @@ let betazeta_appvect n c v = (* Conversion utility functions *) type 'a conversion_function = env -> 'a -> 'a -> unit type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function -type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit type 'a trans_universe_conversion_function = Names.transparent_state -> 'a universe_conversion_function @@ -180,7 +180,7 @@ type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints let sort_cmp_universes env pb s0 s1 (u, check) = (check.compare env pb s0 s1 u, check) @@ -560,10 +560,10 @@ let clos_fconv trans cv_pb l2r evars env univs t1 t2 = let check_eq univs u u' = - if not (check_eq univs u u') then raise NotConvertible + if not (UGraph.check_eq univs u u') then raise NotConvertible let check_leq univs u u' = - if not (check_leq univs u u') then raise NotConvertible + if not (UGraph.check_leq univs u u') then raise NotConvertible let check_sort_cmp_universes env pb s0 s1 univs = match (s0,s1) with @@ -590,7 +590,7 @@ let checked_sort_cmp_universes env pb s0 s1 univs = check_sort_cmp_universes env pb s0 s1 univs; univs let check_convert_instances _flex u u' univs = - if Univ.Instance.check_eq univs u u' then univs + if UGraph.check_eq_instances univs u u' then univs else raise NotConvertible let checked_universes = @@ -598,12 +598,12 @@ let checked_universes = compare_instances = check_convert_instances } let infer_eq (univs, cstrs as cuniv) u u' = - if Univ.check_eq univs u u' then cuniv + if UGraph.check_eq univs u u' then cuniv else univs, (Univ.enforce_eq u u' cstrs) let infer_leq (univs, cstrs as cuniv) u u' = - if Univ.check_leq univs u u' then cuniv + if UGraph.check_leq univs u u' then cuniv else let cstrs' = Univ.enforce_leq u u' cstrs in univs, cstrs' @@ -632,7 +632,7 @@ let infer_cmp_universes env pb s0 s1 univs = let infer_convert_instances flex u u' (univs,cstrs) = (univs, Univ.enforce_eq_instances u u' cstrs) -let infered_universes : (Univ.universes * Univ.Constraint.t) universe_compare = +let infered_universes : (UGraph.t * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 6ced5c4985..a22f3730e9 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -30,7 +30,7 @@ exception NotConvertibleVect of int type 'a conversion_function = env -> 'a -> 'a -> unit type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function -type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit type 'a trans_universe_conversion_function = Names.transparent_state -> 'a universe_conversion_function @@ -47,10 +47,10 @@ type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints val check_sort_cmp_universes : - env -> conv_pb -> sorts -> sorts -> Univ.universes -> unit + env -> conv_pb -> sorts -> sorts -> UGraph.t -> unit (* val sort_cmp : *) (* conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 58f3bcdf00..a00a462e1b 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -317,7 +317,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = (* Check that the given definition does not add any constraint over the expected ones, so that it can be used in place of the original. *) - if Univ.check_constraints ctx1 (Environ.universes env) then + if UGraph.check_constraints ctx1 (Environ.universes env) then cstrs, env, inst2 else error (IncompatibleConstraints ctx1) with Univ.UniverseInconsistency incon -> diff --git a/kernel/term.mli b/kernel/term.mli index 501aaf741e..f8badb0ddc 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -427,11 +427,11 @@ val eq_constr : constr -> constr -> bool (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [u]. *) -val eq_constr_univs : constr Univ.check_function +val eq_constr_univs : constr UGraph.check_function (** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe constraints in [u]. *) -val leq_constr_univs : constr Univ.check_function +val leq_constr_univs : constr UGraph.check_function (** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and ignoring universe instances. *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml new file mode 100644 index 0000000000..356cf4da62 --- /dev/null +++ b/kernel/uGraph.ml @@ -0,0 +1,868 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* false +| SetLe | SetLt -> true + +let arc_is_lt arc = match arc.status with +| Unset | SetLe -> false +| SetLt -> true + +let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset} + +module UMap : +sig + type key = Level.t + type +'a t + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val find : key -> 'a t -> 'a + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val iter : (key -> 'a -> unit) -> 'a t -> unit + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t +end = HMap.Make(Level) + +(* A Level.t is either an alias for another one, or a canonical one, + for which we know the universes that are above *) + +type univ_entry = + Canonical of canonical_arc + | Equiv of Level.t + +type universes = univ_entry UMap.t + +type t = universes + +(** Used to cleanup universes if a traversal function is interrupted before it + has the opportunity to do it itself. *) +let unsafe_cleanup_universes g = + let iter _ arc = match arc with + | Equiv _ -> () + | Canonical arc -> arc.status <- Unset + in + UMap.iter iter g + +let rec cleanup_universes g = + try unsafe_cleanup_universes g + with e -> + (** The only way unsafe_cleanup_universes may raise an exception is when + a serious error (stack overflow, out of memory) occurs, or a signal is + sent. In this unlikely event, we relaunch the cleanup until we finally + succeed. *) + cleanup_universes g; raise e + +let enter_equiv_arc u v g = + UMap.add u (Equiv v) g + +let enter_arc ca g = + UMap.add ca.univ (Canonical ca) g + +(* Every Level.t has a unique canonical arc representative *) + +(** The graph always contains nodes for Prop and Set. *) + +let terminal_lt u v = + {(terminal u) with lt=[v]} + +let empty_universes = + let g = enter_arc (terminal Level.set) UMap.empty in + let g = enter_arc (terminal_lt Level.prop Level.set) g in + g + +(* repr : universes -> Level.t -> canonical_arc *) +(* canonical representative : we follow the Equiv links *) + +let rec repr g u = + let a = + try UMap.find u g + with Not_found -> anomaly ~label:"Univ.repr" + (str"Universe " ++ Level.pr u ++ str" undefined") + in + match a with + | Equiv v -> repr g v + | Canonical arc -> arc + +let get_prop_arc g = repr g Level.prop +let get_set_arc g = repr g Level.set +let is_set_arc u = Level.is_set u.univ +let is_prop_arc u = Level.is_prop u.univ + +exception AlreadyDeclared + +let add_universe vlev strict g = + try + let _arcv = UMap.find vlev g in + raise AlreadyDeclared + with Not_found -> + let v = terminal vlev in + let arc = + let arc = get_set_arc g in + if strict then + { arc with lt=vlev::arc.lt} + else + { arc with le=vlev::arc.le} + in + let g = enter_arc arc g in + enter_arc v g + +(* reprleq : canonical_arc -> canonical_arc list *) +(* All canonical arcv such that arcu<=arcv with arcv#arcu *) +let reprleq g arcu = + let rec searchrec w = function + | [] -> w + | v :: vl -> + let arcv = repr g v in + if List.memq arcv w || arcu==arcv then + searchrec w vl + else + searchrec (arcv :: w) vl + in + searchrec [] arcu.le + + +(* between : Level.t -> canonical_arc -> canonical_arc list *) +(* between u v = { w | u<=w<=v, w canonical } *) +(* between is the most costly operation *) + +let between g arcu arcv = + (* good are all w | u <= w <= v *) + (* bad are all w | u <= w ~<= v *) + (* find good and bad nodes in {w | u <= w} *) + (* explore b u = (b or "u is good") *) + let rec explore ((good, bad, b) as input) arcu = + if List.memq arcu good then + (good, bad, true) (* b or true *) + else if List.memq arcu bad then + input (* (good, bad, b or false) *) + else + let leq = reprleq g arcu in + (* is some universe >= u good ? *) + let good, bad, b_leq = + List.fold_left explore (good, bad, false) leq + in + if b_leq then + arcu::good, bad, true (* b or true *) + else + good, arcu::bad, b (* b or false *) + in + let good,_,_ = explore ([arcv],[],false) arcu in + good +(* We assume compare(u,v) = LE with v canonical (see compare below). + In this case List.hd(between g u v) = repr u + Otherwise, between g u v = [] + *) + +(** [fast_compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? + + In [strict] mode, we fully distinguish between LE and LT, while in + non-strict mode, we simply answer LE for both situations. + + If [arcv] is encountered in a LT part, we could directly answer + without visiting unneeded parts of this transitive closure. + In [strict] mode, if [arcv] is encountered in a LE part, we could only + change the default answer (1st arg [c]) from NLE to LE, since a strict + constraint may appear later. During the recursive traversal, + [lt_done] and [le_done] are universes we have already visited, + they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], + two lists of universes not yet considered, known to be above [arcu], + strictly or not. + + We use depth-first search, but the presence of [arcv] in [new_lt] + is checked as soon as possible : this seems to be slightly faster + on a test. + + We do the traversal imperatively, setting the [status] flag on visited nodes. + This ensures O(1) check, but it also requires unsetting the flag when leaving + the function. Some special care has to be taken in order to ensure we do not + recover a messed up graph at the end. This occurs in particular when the + traversal raises an exception. Even though the code below is exception-free, + OCaml may still raise random exceptions, essentially fatal exceptions or + signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note + also that the use of an imperative solution does make this function + thread-unsafe. For now we do not check universes in different threads, but if + ever this is to be done, we would need some lock somewhere. + +*) + +let get_explanation strict g arcu arcv = + (* [c] characterizes whether (and how) arcv has already been related + to arcu among the lt_done,le_done universe *) + let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with + | [],[] -> (to_revert, c) + | (arc,p)::lt_todo, le_todo -> + if arc_is_lt arc then + cmp c to_revert lt_todo le_todo + else + let rec find lt_todo lt le = match le with + | [] -> + begin match lt with + | [] -> + let () = arc.status <- SetLt in + cmp c (arc :: to_revert) lt_todo le_todo + | u :: lt -> + let arc = repr g u in + let p = (Lt, Universe.make u) :: p in + if arc == arcv then + if strict then (to_revert, p) else (to_revert, p) + else find ((arc, p) :: lt_todo) lt le + end + | u :: le -> + let arc = repr g u in + let p = (Le, Universe.make u) :: p in + if arc == arcv then + if strict then (to_revert, p) else (to_revert, p) + else find ((arc, p) :: lt_todo) lt le + in + find lt_todo arc.lt arc.le + | [], (arc,p)::le_todo -> + if arc == arcv then + (* No need to continue inspecting universes above arc: + if arcv is strictly above arc, then we would have a cycle. + But we cannot answer LE yet, a stronger constraint may + come later from [le_todo]. *) + if strict then cmp p to_revert [] le_todo else (to_revert, p) + else + if arc_is_le arc then + cmp c to_revert [] le_todo + else + let rec find lt_todo lt = match lt with + | [] -> + let fold accu u = + let p = (Le, Universe.make u) :: p in + let node = (repr g u, p) in + node :: accu + in + let le_new = List.fold_left fold le_todo arc.le in + let () = arc.status <- SetLe in + cmp c (arc :: to_revert) lt_todo le_new + | u :: lt -> + let arc = repr g u in + let p = (Lt, Universe.make u) :: p in + if arc == arcv then + if strict then (to_revert, p) else (to_revert, p) + else find ((arc, p) :: lt_todo) lt + in + find [] arc.lt + in + let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in + try + let (to_revert, c) = cmp start [] [] [(arcu, [])] in + (** Reset all the touched arcs. *) + let () = List.iter (fun arc -> arc.status <- Unset) to_revert in + List.rev c + with e -> + (** Unlikely event: fatal error or signal *) + let () = cleanup_universes g in + raise e + +let get_explanation strict g arcu arcv = + if !Flags.univ_print then Some (get_explanation strict g arcu arcv) + else None + +type fast_order = FastEQ | FastLT | FastLE | FastNLE + +let fast_compare_neq strict g arcu arcv = + (* [c] characterizes whether arcv has already been related + to arcu among the lt_done,le_done universe *) + let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with + | [],[] -> (to_revert, c) + | arc::lt_todo, le_todo -> + if arc_is_lt arc then + cmp c to_revert lt_todo le_todo + else + let () = arc.status <- SetLt in + process_lt c (arc :: to_revert) lt_todo le_todo arc.lt arc.le + | [], arc::le_todo -> + if arc == arcv then + (* No need to continue inspecting universes above arc: + if arcv is strictly above arc, then we would have a cycle. + But we cannot answer LE yet, a stronger constraint may + come later from [le_todo]. *) + if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE) + else + if arc_is_le arc then + cmp c to_revert [] le_todo + else + let () = arc.status <- SetLe in + process_le c (arc :: to_revert) [] le_todo arc.lt arc.le + + and process_lt c to_revert lt_todo le_todo lt le = match le with + | [] -> + begin match lt with + | [] -> cmp c to_revert lt_todo le_todo + | u :: lt -> + let arc = repr g u in + if arc == arcv then + if strict then (to_revert, FastLT) else (to_revert, FastLE) + else process_lt c to_revert (arc :: lt_todo) le_todo lt le + end + | u :: le -> + let arc = repr g u in + if arc == arcv then + if strict then (to_revert, FastLT) else (to_revert, FastLE) + else process_lt c to_revert (arc :: lt_todo) le_todo lt le + + and process_le c to_revert lt_todo le_todo lt le = match lt with + | [] -> + let fold accu u = + let node = repr g u in + node :: accu + in + let le_new = List.fold_left fold le_todo le in + cmp c to_revert lt_todo le_new + | u :: lt -> + let arc = repr g u in + if arc == arcv then + if strict then (to_revert, FastLT) else (to_revert, FastLE) + else process_le c to_revert (arc :: lt_todo) le_todo lt le + + in + try + let (to_revert, c) = cmp FastNLE [] [] [arcu] in + (** Reset all the touched arcs. *) + let () = List.iter (fun arc -> arc.status <- Unset) to_revert in + c + with e -> + (** Unlikely event: fatal error or signal *) + let () = cleanup_universes g in + raise e + +let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv + +let fast_compare g arcu arcv = + if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv + +let is_leq g arcu arcv = + arcu == arcv || + (match fast_compare_neq false g arcu arcv with + | FastNLE -> false + | (FastEQ|FastLE|FastLT) -> true) + +let is_lt g arcu arcv = + if arcu == arcv then false + else + match fast_compare_neq true g arcu arcv with + | FastLT -> true + | (FastEQ|FastLE|FastNLE) -> false + +(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ + compare(u,v) = LT or LE => compare(v,u) = NLE + compare(u,v) = NLE => compare(v,u) = NLE or LE or LT + + Adding u>=v is consistent iff compare(v,u) # LT + and then it is redundant iff compare(u,v) # NLE + Adding u>v is consistent iff compare(v,u) = NLE + and then it is redundant iff compare(u,v) = LT *) + +(** * Universe checks [check_eq] and [check_leq], used in coqchk *) + +(** First, checks on universe levels *) + +let check_equal g u v = + let arcu = repr g u and arcv = repr g v in + arcu == arcv + +let check_eq_level g u v = u == v || check_equal g u v + +let check_smaller g strict u v = + let arcu = repr g u and arcv = repr g v in + if strict then + is_lt g arcu arcv + else + is_prop_arc arcu + || (is_set_arc arcu && not (is_prop_arc arcv)) + || is_leq g arcu arcv + +(** Then, checks on universes *) + +type 'a check_function = universes -> 'a -> 'a -> bool + +let check_equal_expr g x y = + x == y || (let (u, n) = x and (v, m) = y in + Int.equal n m && check_equal g u v) + +let check_eq_univs g l1 l2 = + let f x1 x2 = check_equal_expr g x1 x2 in + let exists x1 l = Universe.exists (fun x2 -> f x1 x2) l in + Universe.for_all (fun x1 -> exists x1 l2) l1 + && Universe.for_all (fun x2 -> exists x2 l1) l2 + +let check_eq g u v = + Universe.equal u v || check_eq_univs g u v + +let check_smaller_expr g (u,n) (v,m) = + let diff = n - m in + match diff with + | 0 -> check_smaller g false u v + | 1 -> check_smaller g true u v + | x when x < 0 -> check_smaller g false u v + | _ -> false + +let exists_bigger g ul l = + Universe.exists (fun ul' -> + check_smaller_expr g ul ul') l + +let real_check_leq g u v = + Universe.for_all (fun ul -> exists_bigger g ul v) u + +let check_leq g u v = + Universe.equal u v || + is_type0m_univ u || + check_eq_univs g u v || real_check_leq g u v + +(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) + +(* setlt : Level.t -> Level.t -> reason -> unit *) +(* forces u > v *) +(* this is normally an update of u in g rather than a creation. *) +let setlt g arcu arcv = + let arcu' = {arcu with lt=arcv.univ::arcu.lt} in + enter_arc arcu' g, arcu' + +(* checks that non-redundant *) +let setlt_if (g,arcu) v = + let arcv = repr g v in + if is_lt g arcu arcv then g, arcu + else setlt g arcu arcv + +(* setleq : Level.t -> Level.t -> unit *) +(* forces u >= v *) +(* this is normally an update of u in g rather than a creation. *) +let setleq g arcu arcv = + let arcu' = {arcu with le=arcv.univ::arcu.le} in + enter_arc arcu' g, arcu' + +(* checks that non-redundant *) +let setleq_if (g,arcu) v = + let arcv = repr g v in + if is_leq g arcu arcv then g, arcu + else setleq g arcu arcv + +(* merge : Level.t -> Level.t -> unit *) +(* we assume compare(u,v) = LE *) +(* merge u v forces u ~ v with repr u as canonical repr *) +let merge g arcu arcv = + (* we find the arc with the biggest rank, and we redirect all others to it *) + let arcu, g, v = + let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = + if Level.is_small arc.univ || + (arc.rank >= max_rank && not (Level.is_small best_arc.univ)) + then (arc.rank, max_rank, arc, best_arc::rest) + else (max_rank, old_max_rank, best_arc, arc::rest) + in + match between g arcu arcv with + | [] -> anomaly (str "Univ.between") + | arc::rest -> + let (max_rank, old_max_rank, best_arc, rest) = + List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in + if max_rank > old_max_rank then best_arc, g, rest + else begin + (* one redirected node also has max_rank *) + let arcu = {best_arc with rank = max_rank + 1} in + arcu, enter_arc arcu g, rest + end + in + let redirect (g,w,w') arcv = + let g' = enter_equiv_arc arcv.univ arcu.univ g in + (g',List.unionq arcv.lt w,arcv.le@w') + in + let (g',w,w') = List.fold_left redirect (g,[],[]) v in + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu w in + let g_arcu = List.fold_left setleq_if g_arcu w' in + fst g_arcu + +(* merge_disc : Level.t -> Level.t -> unit *) +(* we assume compare(u,v) = compare(v,u) = NLE *) +(* merge_disc u v forces u ~ v with repr u as canonical repr *) +let merge_disc g arc1 arc2 = + let arcu, arcv = if Level.is_small arc2.univ || arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in + let arcu, g = + if not (Int.equal arc1.rank arc2.rank) then arcu, g + else + let arcu = {arcu with rank = succ arcu.rank} in + arcu, enter_arc arcu g + in + let g' = enter_equiv_arc arcv.univ arcu.univ g in + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in + let g_arcu = List.fold_left setleq_if g_arcu arcv.le in + fst g_arcu + +(* enforce_univ_eq : Level.t -> Level.t -> unit *) +(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *) + +let enforce_univ_eq u v g = + let arcu = repr g u and arcv = repr g v in + match fast_compare g arcu arcv with + | FastEQ -> g + | FastLT -> + let p = get_explanation_strict g arcu arcv in + error_inconsistency Eq v u p + | FastLE -> merge g arcu arcv + | FastNLE -> + (match fast_compare g arcv arcu with + | FastLT -> + let p = get_explanation_strict g arcv arcu in + error_inconsistency Eq u v p + | FastLE -> merge g arcv arcu + | FastNLE -> merge_disc g arcu arcv + | FastEQ -> anomaly (Pp.str "Univ.compare")) + +(* enforce_univ_leq : Level.t -> Level.t -> unit *) +(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) +let enforce_univ_leq u v g = + let arcu = repr g u and arcv = repr g v in + if is_leq g arcu arcv then g + else + match fast_compare g arcv arcu with + | FastLT -> + let p = get_explanation_strict g arcv arcu in + error_inconsistency Le u v p + | FastLE -> merge g arcv arcu + | FastNLE -> fst (setleq g arcu arcv) + | FastEQ -> anomaly (Pp.str "Univ.compare") + +(* enforce_univ_lt u v will force u g + | FastLE -> fst (setlt g arcu arcv) + | FastEQ -> error_inconsistency Lt u v (Some [(Eq,Universe.make v)]) + | FastNLE -> + match fast_compare_neq false g arcv arcu with + FastNLE -> fst (setlt g arcu arcv) + | FastEQ -> anomaly (Pp.str "Univ.compare") + | (FastLE|FastLT) -> + let p = get_explanation false g arcv arcu in + error_inconsistency Lt u v p + +(* Prop = Set is forbidden here. *) +let initial_universes = empty_universes + +let is_initial_universes g = UMap.equal (==) g initial_universes + +let enforce_constraint cst g = + match cst with + | (u,Lt,v) -> enforce_univ_lt u v g + | (u,Le,v) -> enforce_univ_leq u v g + | (u,Eq,v) -> enforce_univ_eq u v g + +let merge_constraints c g = + Constraint.fold enforce_constraint c g + +let check_constraint g (l,d,r) = + match d with + | Eq -> check_equal g l r + | Le -> check_smaller g false l r + | Lt -> check_smaller g true l r + +let check_constraints c g = + Constraint.for_all (check_constraint g) c + +(* Normalization *) + +let lookup_level u g = + try Some (UMap.find u g) with Not_found -> None + +(** [normalize_universes g] returns a graph where all edges point + directly to the canonical representent of their target. The output + graph should be equivalent to the input graph from a logical point + of view, but optimized. We maintain the invariant that the key of + a [Canonical] element is its own name, by keeping [Equiv] edges + (see the assertion)... I (Stéphane Glondu) am not sure if this + plays a role in the rest of the module. *) +let normalize_universes g = + let rec visit u arc cache = match lookup_level u cache with + | Some x -> x, cache + | None -> match Lazy.force arc with + | None -> + u, UMap.add u u cache + | Some (Canonical {univ=v; lt=_; le=_}) -> + v, UMap.add u v cache + | Some (Equiv v) -> + let v, cache = visit v (lazy (lookup_level v g)) cache in + v, UMap.add u v cache + in + let cache = UMap.fold + (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) + g UMap.empty + in + let repr x = UMap.find x cache in + let lrepr us = List.fold_left + (fun e x -> LSet.add (repr x) e) LSet.empty us + in + let canonicalize u = function + | Equiv _ -> Equiv (repr u) + | Canonical {univ=v; lt=lt; le=le; rank=rank} -> + assert (u == v); + (* avoid duplicates and self-loops *) + let lt = lrepr lt and le = lrepr le in + let le = LSet.filter + (fun x -> x != u && not (LSet.mem x lt)) le + in + LSet.iter (fun x -> assert (x != u)) lt; + Canonical { + univ = v; + lt = LSet.elements lt; + le = LSet.elements le; + rank = rank; + status = Unset; + } + in + UMap.mapi canonicalize g + +let constraints_of_universes g = + let constraints_of u v acc = + match v with + | Canonical {univ=u; lt=lt; le=le} -> + let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in + let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in + acc + | Equiv v -> Constraint.add (u,Eq,v) acc + in + UMap.fold constraints_of g Constraint.empty + +let constraints_of_universes g = + constraints_of_universes (normalize_universes g) + +(** Longest path algorithm. This is used to compute the minimal number of + universes required if the only strict edge would be the Lt one. This + algorithm assumes that the given universes constraints are a almost DAG, in + the sense that there may be {Eq, Le}-cycles. This is OK for consistent + universes, which is the only case where we use this algorithm. *) + +(** Adjacency graph *) +type graph = constraint_type LMap.t LMap.t + +exception Connected + +(** Check connectedness *) +let connected x y (g : graph) = + let rec connected x target seen g = + if Level.equal x target then raise Connected + else if not (LSet.mem x seen) then + let seen = LSet.add x seen in + let fold z _ seen = connected z target seen g in + let neighbours = try LMap.find x g with Not_found -> LMap.empty in + LMap.fold fold neighbours seen + else seen + in + try ignore(connected x y LSet.empty g); false with Connected -> true + +let add_edge x y v (g : graph) = + try + let neighbours = LMap.find x g in + let neighbours = LMap.add y v neighbours in + LMap.add x neighbours g + with Not_found -> + LMap.add x (LMap.singleton y v) g + +(** We want to keep the graph DAG. If adding an edge would cause a cycle, that + would necessarily be an {Eq, Le}-cycle, otherwise there would have been a + universe inconsistency. Therefore we may omit adding such a cycling edge + without changing the compacted graph. *) +let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g + +(** Construct the DAG and its inverse at the same time. *) +let make_graph g : (graph * graph) = + let fold u arc accu = match arc with + | Equiv v -> + let (dir, rev) = accu in + (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev) + | Canonical { univ; lt; le; } -> + let () = assert (u == univ) in + let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in + let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in + (** Order is important : lt after le, because of the possible redundancy + between [le] and [lt] in a canonical arc. This way, the [lt] constraint + is the last one set, which is correct because it implies [le]. *) + let accu = List.fold_left fold_le accu le in + let accu = List.fold_left fold_lt accu lt in + accu + in + UMap.fold fold g (LMap.empty, LMap.empty) + +(** Construct a topological order out of a DAG. *) +let rec topological_fold u g rem seen accu = + let is_seen = + try + let status = LMap.find u seen in + assert status; (** If false, not a DAG! *) + true + with Not_found -> false + in + if not is_seen then + let rem = LMap.remove u rem in + let seen = LMap.add u false seen in + let neighbours = try LMap.find u g with Not_found -> LMap.empty in + let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in + let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in + (rem, LMap.add u true seen, u :: accu) + else (rem, seen, accu) + +let rec topological g rem seen accu = + let node = try Some (LMap.choose rem) with Not_found -> None in + match node with + | None -> accu + | Some (u, _) -> + let rem, seen, accu = topological_fold u g rem seen accu in + topological g rem seen accu + +(** Compute the longest path from any vertex. *) +let constraint_cost = function +| Eq | Le -> 0 +| Lt -> 1 + +(** This algorithm browses the graph in topological order, computing for each + encountered node the length of the longest path leading to it. Should be + O(|V|) or so (modulo map representation). *) +let rec flatten_graph rem (rev : graph) map mx = match rem with +| [] -> map, mx +| u :: rem -> + let prev = try LMap.find u rev with Not_found -> LMap.empty in + let fold v cstr accu = + let v_cost = LMap.find v map in + max (v_cost + constraint_cost cstr) accu + in + let u_cost = LMap.fold fold prev 0 in + let map = LMap.add u u_cost map in + flatten_graph rem rev map (max mx u_cost) + +(** [sort_universes g] builds a map from universes in [g] to natural + numbers. It outputs a graph containing equivalence edges from each + level appearing in [g] to [Type.n], and [lt] edges between the + [Type.n]s. The output graph should imply the input graph (and the + [Type.n]s. The output graph should imply the input graph (and the + implication will be strict most of the time), but is not + necessarily minimal. Note: the result is unspecified if the input + graph already contains [Type.n] nodes (calling a module Type is + probably a bad idea anyway). *) +let sort_universes orig = + let (dir, rev) = make_graph orig in + let order = topological dir dir LMap.empty [] in + let compact, max = flatten_graph order rev LMap.empty 0 in + let mp = Names.DirPath.make [Names.Id.of_string "Type"] in + let types = Array.init (max + 1) (fun n -> Level.make mp n) in + (** Old universes are made equal to [Type.n] *) + let fold u level accu = UMap.add u (Equiv types.(level)) accu in + let sorted = LMap.fold fold compact UMap.empty in + (** Add all [Type.n] nodes *) + let fold i accu u = + if i < max then + let pred = types.(i + 1) in + let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in + UMap.add u (Canonical arc) accu + else accu + in + Array.fold_left_i fold sorted types + +(** Instances *) + +let check_eq_instances g t1 t2 = + let t1 = Instance.to_array t1 in + let t2 = Instance.to_array t2 in + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) + in aux 0) + +let pr_arc prl = function + | _, Canonical {univ=u; lt=[]; le=[]} -> + mt () + | _, Canonical {univ=u; lt=lt; le=le} -> + let opt_sep = match lt, le with + | [], _ | _, [] -> mt () + | _ -> spc () + in + prl u ++ str " " ++ + v 0 + (pr_sequence (fun v -> str "< " ++ prl v) lt ++ + opt_sep ++ + pr_sequence (fun v -> str "<= " ++ prl v) le) ++ + fnl () + | u, Equiv v -> + prl u ++ str " = " ++ prl v ++ fnl () + +let pr_universes prl g = + let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in + prlist (pr_arc prl) graph + +(* Dumping constraints to a file *) + +let dump_universes output g = + let dump_arc u = function + | Canonical {univ=u; lt=lt; le=le} -> + let u_str = Level.to_string u in + List.iter (fun v -> output Lt (Level.to_string v) u_str) lt; + List.iter (fun v -> output Le (Level.to_string v) u_str) le + | Equiv v -> + output Eq (Level.to_string u) (Level.to_string v) + in + UMap.iter dump_arc g + +(** Profiling *) + +let merge_constraints = + if Flags.profile then + let key = Profile.declare_profile "merge_constraints" in + Profile.profile2 key merge_constraints + else merge_constraints + +let check_constraints = + if Flags.profile then + let key = Profile.declare_profile "check_constraints" in + Profile.profile2 key check_constraints + else check_constraints + +let check_eq = + if Flags.profile then + let check_eq_key = Profile.declare_profile "check_eq" in + Profile.profile3 check_eq_key check_eq + else check_eq + +let check_leq = + if Flags.profile then + let check_leq_key = Profile.declare_profile "check_leq" in + Profile.profile3 check_leq_key check_leq + else check_leq diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli new file mode 100644 index 0000000000..e95cf4d1cb --- /dev/null +++ b/kernel/uGraph.mli @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> 'a -> bool +val check_leq : universe check_function +val check_eq : universe check_function + +(** The empty graph of universes *) +val empty_universes : universes + +(** The initial graph of universes: Prop < Set *) +val initial_universes : universes + +val is_initial_universes : universes -> bool + +val sort_universes : universes -> universes + +(** Adds a universe to the graph, ensuring it is >= or > Set. + @raises AlreadyDeclared if the level is already declared in the graph. *) + +exception AlreadyDeclared + +val add_universe : universe_level -> bool -> universes -> universes + +(** {6 ... } *) +(** Merge of constraints in a universes graph. + The function [merge_constraints] merges a set of constraints in a given + universes graph. It raises the exception [UniverseInconsistency] if the + constraints are not satisfiable. *) + +val enforce_constraint : univ_constraint -> universes -> universes +val merge_constraints : constraints -> universes -> universes + +val constraints_of_universes : universes -> constraints + +val check_constraint : universes -> univ_constraint -> bool +val check_constraints : constraints -> universes -> bool + +val check_eq_instances : Instance.t check_function +(** Check equality of instances w.r.t. a universe graph *) + +(** {6 Pretty-printing of universes. } *) + +val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds + +(** {6 Dumping to a file } *) + +val dump_universes : + (constraint_type -> string -> string -> unit) -> + universes -> unit diff --git a/kernel/univ.ml b/kernel/univ.ml index 34eb283d73..7e6d4de235 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -653,170 +653,6 @@ open Universe let universe_level = Universe.level -type status = Unset | SetLe | SetLt - -(* Comparison on this type is pointer equality *) -type canonical_arc = - { univ: Level.t; - lt: Level.t list; - le: Level.t list; - rank : int; - mutable status : status; - (** Guaranteed to be unset out of the [compare_neq] functions. It is used - to do an imperative traversal of the graph, ensuring a O(1) check that - a node has already been visited. Quite performance critical indeed. *) - } - -let arc_is_le arc = match arc.status with -| Unset -> false -| SetLe | SetLt -> true - -let arc_is_lt arc = match arc.status with -| Unset | SetLe -> false -| SetLt -> true - -let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset} - -module UMap : -sig - type key = Level.t - type +'a t - val empty : 'a t - val add : key -> 'a -> 'a t -> 'a t - val find : key -> 'a t -> 'a - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val iter : (key -> 'a -> unit) -> 'a t -> unit - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t -end = HMap.Make(Level) - -(* A Level.t is either an alias for another one, or a canonical one, - for which we know the universes that are above *) - -type univ_entry = - Canonical of canonical_arc - | Equiv of Level.t - -type universes = univ_entry UMap.t - -(** Used to cleanup universes if a traversal function is interrupted before it - has the opportunity to do it itself. *) -let unsafe_cleanup_universes g = - let iter _ arc = match arc with - | Equiv _ -> () - | Canonical arc -> arc.status <- Unset - in - UMap.iter iter g - -let rec cleanup_universes g = - try unsafe_cleanup_universes g - with e -> - (** The only way unsafe_cleanup_universes may raise an exception is when - a serious error (stack overflow, out of memory) occurs, or a signal is - sent. In this unlikely event, we relaunch the cleanup until we finally - succeed. *) - cleanup_universes g; raise e - -let enter_equiv_arc u v g = - UMap.add u (Equiv v) g - -let enter_arc ca g = - UMap.add ca.univ (Canonical ca) g - -(* Every Level.t has a unique canonical arc representative *) - -(** The graph always contains nodes for Prop and Set. *) - -let terminal_lt u v = - {(terminal u) with lt=[v]} - -let empty_universes = - let g = enter_arc (terminal Level.set) UMap.empty in - let g = enter_arc (terminal_lt Level.prop Level.set) g in - g - -(* repr : universes -> Level.t -> canonical_arc *) -(* canonical representative : we follow the Equiv links *) - -let rec repr g u = - let a = - try UMap.find u g - with Not_found -> anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined") - in - match a with - | Equiv v -> repr g v - | Canonical arc -> arc - -let get_prop_arc g = repr g Level.prop -let get_set_arc g = repr g Level.set -let is_set_arc u = Level.is_set u.univ -let is_prop_arc u = Level.is_prop u.univ - -exception AlreadyDeclared - -let add_universe vlev strict g = - try - let _arcv = UMap.find vlev g in - raise AlreadyDeclared - with Not_found -> - let v = terminal vlev in - let arc = - let arc = get_set_arc g in - if strict then - { arc with lt=vlev::arc.lt} - else - { arc with le=vlev::arc.le} - in - let g = enter_arc arc g in - enter_arc v g - -(* reprleq : canonical_arc -> canonical_arc list *) -(* All canonical arcv such that arcu<=arcv with arcv#arcu *) -let reprleq g arcu = - let rec searchrec w = function - | [] -> w - | v :: vl -> - let arcv = repr g v in - if List.memq arcv w || arcu==arcv then - searchrec w vl - else - searchrec (arcv :: w) vl - in - searchrec [] arcu.le - - -(* between : Level.t -> canonical_arc -> canonical_arc list *) -(* between u v = { w | u<=w<=v, w canonical } *) -(* between is the most costly operation *) - -let between g arcu arcv = - (* good are all w | u <= w <= v *) - (* bad are all w | u <= w ~<= v *) - (* find good and bad nodes in {w | u <= w} *) - (* explore b u = (b or "u is good") *) - let rec explore ((good, bad, b) as input) arcu = - if List.memq arcu good then - (good, bad, true) (* b or true *) - else if List.memq arcu bad then - input (* (good, bad, b or false) *) - else - let leq = reprleq g arcu in - (* is some universe >= u good ? *) - let good, bad, b_leq = - List.fold_left explore (good, bad, false) leq - in - if b_leq then - arcu::good, bad, true (* b or true *) - else - good, arcu::bad, b (* b or false *) - in - let good,_,_ = explore ([arcv],[],false) arcu in - good -(* We assume compare(u,v) = LE with v canonical (see compare below). - In this case List.hd(between g u v) = repr u - Otherwise, between g u v = [] - *) type constraint_type = Lt | Le | Eq @@ -831,343 +667,6 @@ let constraint_type_ord c1 c2 = match c1, c2 with | Eq, Eq -> 0 | Eq, _ -> 1 -(** [fast_compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? - - In [strict] mode, we fully distinguish between LE and LT, while in - non-strict mode, we simply answer LE for both situations. - - If [arcv] is encountered in a LT part, we could directly answer - without visiting unneeded parts of this transitive closure. - In [strict] mode, if [arcv] is encountered in a LE part, we could only - change the default answer (1st arg [c]) from NLE to LE, since a strict - constraint may appear later. During the recursive traversal, - [lt_done] and [le_done] are universes we have already visited, - they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], - two lists of universes not yet considered, known to be above [arcu], - strictly or not. - - We use depth-first search, but the presence of [arcv] in [new_lt] - is checked as soon as possible : this seems to be slightly faster - on a test. - - We do the traversal imperatively, setting the [status] flag on visited nodes. - This ensures O(1) check, but it also requires unsetting the flag when leaving - the function. Some special care has to be taken in order to ensure we do not - recover a messed up graph at the end. This occurs in particular when the - traversal raises an exception. Even though the code below is exception-free, - OCaml may still raise random exceptions, essentially fatal exceptions or - signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note - also that the use of an imperative solution does make this function - thread-unsafe. For now we do not check universes in different threads, but if - ever this is to be done, we would need some lock somewhere. - -*) - -let get_explanation strict g arcu arcv = - (* [c] characterizes whether (and how) arcv has already been related - to arcu among the lt_done,le_done universe *) - let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with - | [],[] -> (to_revert, c) - | (arc,p)::lt_todo, le_todo -> - if arc_is_lt arc then - cmp c to_revert lt_todo le_todo - else - let rec find lt_todo lt le = match le with - | [] -> - begin match lt with - | [] -> - let () = arc.status <- SetLt in - cmp c (arc :: to_revert) lt_todo le_todo - | u :: lt -> - let arc = repr g u in - let p = (Lt, make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt le - end - | u :: le -> - let arc = repr g u in - let p = (Le, make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt le - in - find lt_todo arc.lt arc.le - | [], (arc,p)::le_todo -> - if arc == arcv then - (* No need to continue inspecting universes above arc: - if arcv is strictly above arc, then we would have a cycle. - But we cannot answer LE yet, a stronger constraint may - come later from [le_todo]. *) - if strict then cmp p to_revert [] le_todo else (to_revert, p) - else - if arc_is_le arc then - cmp c to_revert [] le_todo - else - let rec find lt_todo lt = match lt with - | [] -> - let fold accu u = - let p = (Le, make u) :: p in - let node = (repr g u, p) in - node :: accu - in - let le_new = List.fold_left fold le_todo arc.le in - let () = arc.status <- SetLe in - cmp c (arc :: to_revert) lt_todo le_new - | u :: lt -> - let arc = repr g u in - let p = (Lt, make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt - in - find [] arc.lt - in - let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in - try - let (to_revert, c) = cmp start [] [] [(arcu, [])] in - (** Reset all the touched arcs. *) - let () = List.iter (fun arc -> arc.status <- Unset) to_revert in - List.rev c - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -let get_explanation strict g arcu arcv = - if !Flags.univ_print then Some (get_explanation strict g arcu arcv) - else None - -type fast_order = FastEQ | FastLT | FastLE | FastNLE - -let fast_compare_neq strict g arcu arcv = - (* [c] characterizes whether arcv has already been related - to arcu among the lt_done,le_done universe *) - let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with - | [],[] -> (to_revert, c) - | arc::lt_todo, le_todo -> - if arc_is_lt arc then - cmp c to_revert lt_todo le_todo - else - let () = arc.status <- SetLt in - process_lt c (arc :: to_revert) lt_todo le_todo arc.lt arc.le - | [], arc::le_todo -> - if arc == arcv then - (* No need to continue inspecting universes above arc: - if arcv is strictly above arc, then we would have a cycle. - But we cannot answer LE yet, a stronger constraint may - come later from [le_todo]. *) - if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE) - else - if arc_is_le arc then - cmp c to_revert [] le_todo - else - let () = arc.status <- SetLe in - process_le c (arc :: to_revert) [] le_todo arc.lt arc.le - - and process_lt c to_revert lt_todo le_todo lt le = match le with - | [] -> - begin match lt with - | [] -> cmp c to_revert lt_todo le_todo - | u :: lt -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else process_lt c to_revert (arc :: lt_todo) le_todo lt le - end - | u :: le -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else process_lt c to_revert (arc :: lt_todo) le_todo lt le - - and process_le c to_revert lt_todo le_todo lt le = match lt with - | [] -> - let fold accu u = - let node = repr g u in - node :: accu - in - let le_new = List.fold_left fold le_todo le in - cmp c to_revert lt_todo le_new - | u :: lt -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else process_le c to_revert (arc :: lt_todo) le_todo lt le - - in - try - let (to_revert, c) = cmp FastNLE [] [] [arcu] in - (** Reset all the touched arcs. *) - let () = List.iter (fun arc -> arc.status <- Unset) to_revert in - c - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv - -let fast_compare g arcu arcv = - if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv - -let is_leq g arcu arcv = - arcu == arcv || - (match fast_compare_neq false g arcu arcv with - | FastNLE -> false - | (FastEQ|FastLE|FastLT) -> true) - -let is_lt g arcu arcv = - if arcu == arcv then false - else - match fast_compare_neq true g arcu arcv with - | FastLT -> true - | (FastEQ|FastLE|FastNLE) -> false - -(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ - compare(u,v) = LT or LE => compare(v,u) = NLE - compare(u,v) = NLE => compare(v,u) = NLE or LE or LT - - Adding u>=v is consistent iff compare(v,u) # LT - and then it is redundant iff compare(u,v) # NLE - Adding u>v is consistent iff compare(v,u) = NLE - and then it is redundant iff compare(u,v) = LT *) - -(** * Universe checks [check_eq] and [check_leq], used in coqchk *) - -(** First, checks on universe levels *) - -let check_equal g u v = - let arcu = repr g u and arcv = repr g v in - arcu == arcv - -let check_eq_level g u v = u == v || check_equal g u v - -let check_smaller g strict u v = - let arcu = repr g u and arcv = repr g v in - if strict then - is_lt g arcu arcv - else - is_prop_arc arcu - || (is_set_arc arcu && not (is_prop_arc arcv)) - || is_leq g arcu arcv - -(** Then, checks on universes *) - -type 'a check_function = universes -> 'a -> 'a -> bool - -let check_equal_expr g x y = - x == y || (let (u, n) = x and (v, m) = y in - Int.equal n m && check_equal g u v) - -let check_eq_univs g l1 l2 = - let f x1 x2 = check_equal_expr g x1 x2 in - let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in - Huniv.for_all (fun x1 -> exists x1 l2) l1 - && Huniv.for_all (fun x2 -> exists x2 l1) l2 - -let check_eq g u v = - Universe.equal u v || check_eq_univs g u v - -let check_smaller_expr g (u,n) (v,m) = - let diff = n - m in - match diff with - | 0 -> check_smaller g false u v - | 1 -> check_smaller g true u v - | x when x < 0 -> check_smaller g false u v - | _ -> false - -let exists_bigger g ul l = - Huniv.exists (fun ul' -> - check_smaller_expr g ul ul') l - -let real_check_leq g u v = - Huniv.for_all (fun ul -> exists_bigger g ul v) u - -let check_leq g u v = - Universe.equal u v || - Universe.is_type0m u || - check_eq_univs g u v || real_check_leq g u v - -(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) - -(* setlt : Level.t -> Level.t -> reason -> unit *) -(* forces u > v *) -(* this is normally an update of u in g rather than a creation. *) -let setlt g arcu arcv = - let arcu' = {arcu with lt=arcv.univ::arcu.lt} in - enter_arc arcu' g, arcu' - -(* checks that non-redundant *) -let setlt_if (g,arcu) v = - let arcv = repr g v in - if is_lt g arcu arcv then g, arcu - else setlt g arcu arcv - -(* setleq : Level.t -> Level.t -> unit *) -(* forces u >= v *) -(* this is normally an update of u in g rather than a creation. *) -let setleq g arcu arcv = - let arcu' = {arcu with le=arcv.univ::arcu.le} in - enter_arc arcu' g, arcu' - -(* checks that non-redundant *) -let setleq_if (g,arcu) v = - let arcv = repr g v in - if is_leq g arcu arcv then g, arcu - else setleq g arcu arcv - -(* merge : Level.t -> Level.t -> unit *) -(* we assume compare(u,v) = LE *) -(* merge u v forces u ~ v with repr u as canonical repr *) -let merge g arcu arcv = - (* we find the arc with the biggest rank, and we redirect all others to it *) - let arcu, g, v = - let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = - if Level.is_small arc.univ || - (arc.rank >= max_rank && not (Level.is_small best_arc.univ)) - then (arc.rank, max_rank, arc, best_arc::rest) - else (max_rank, old_max_rank, best_arc, arc::rest) - in - match between g arcu arcv with - | [] -> anomaly (str "Univ.between") - | arc::rest -> - let (max_rank, old_max_rank, best_arc, rest) = - List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in - if max_rank > old_max_rank then best_arc, g, rest - else begin - (* one redirected node also has max_rank *) - let arcu = {best_arc with rank = max_rank + 1} in - arcu, enter_arc arcu g, rest - end - in - let redirect (g,w,w') arcv = - let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',List.unionq arcv.lt w,arcv.le@w') - in - let (g',w,w') = List.fold_left redirect (g,[],[]) v in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu w in - let g_arcu = List.fold_left setleq_if g_arcu w' in - fst g_arcu - -(* merge_disc : Level.t -> Level.t -> unit *) -(* we assume compare(u,v) = compare(v,u) = NLE *) -(* merge_disc u v forces u ~ v with repr u as canonical repr *) -let merge_disc g arc1 arc2 = - let arcu, arcv = if Level.is_small arc2.univ || arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in - let arcu, g = - if not (Int.equal arc1.rank arc2.rank) then arcu, g - else - let arcu = {arcu with rank = succ arcu.rank} in - arcu, enter_arc arcu g - in - let g' = enter_equiv_arc arcv.univ arcu.univ g in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in - let g_arcu = List.fold_left setleq_if g_arcu arcv.le in - fst g_arcu - (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) @@ -1178,70 +677,10 @@ exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v (p:explanation option) = raise (UniverseInconsistency (o,make u,make v,p)) -(* enforce_univ_eq : Level.t -> Level.t -> unit *) -(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *) - -let enforce_univ_eq u v g = - let arcu = repr g u and arcv = repr g v in - match fast_compare g arcu arcv with - | FastEQ -> g - | FastLT -> - let p = get_explanation_strict g arcu arcv in - error_inconsistency Eq v u p - | FastLE -> merge g arcu arcv - | FastNLE -> - (match fast_compare g arcv arcu with - | FastLT -> - let p = get_explanation_strict g arcv arcu in - error_inconsistency Eq u v p - | FastLE -> merge g arcv arcu - | FastNLE -> merge_disc g arcu arcv - | FastEQ -> anomaly (Pp.str "Univ.compare")) - -(* enforce_univ_leq : Level.t -> Level.t -> unit *) -(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) -let enforce_univ_leq u v g = - let arcu = repr g u and arcv = repr g v in - if is_leq g arcu arcv then g - else - match fast_compare g arcv arcu with - | FastLT -> - let p = get_explanation_strict g arcv arcu in - error_inconsistency Le u v p - | FastLE -> merge g arcv arcu - | FastNLE -> fst (setleq g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") - -(* enforce_univ_lt u v will force u g - | FastLE -> fst (setlt g arcu arcv) - | FastEQ -> error_inconsistency Lt u v (Some [(Eq,make v)]) - | FastNLE -> - match fast_compare_neq false g arcv arcu with - FastNLE -> fst (setlt g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") - | (FastLE|FastLT) -> - let p = get_explanation false g arcv arcu in - error_inconsistency Lt u v p - -(* Prop = Set is forbidden here. *) -let initial_universes = empty_universes - -let is_initial_universes g = UMap.equal (==) g initial_universes - (* Constraints and sets of constraints. *) type univ_constraint = Level.t * constraint_type * Level.t -let enforce_constraint cst g = - match cst with - | (u,Lt,v) -> enforce_univ_lt u v g - | (u,Le,v) -> enforce_univ_leq u v g - | (u,Eq,v) -> enforce_univ_eq u v g - let pr_constraint_type op = let op_str = match op with | Lt -> " < " @@ -1276,8 +715,6 @@ end let empty_constraint = Constraint.empty let union_constraint = Constraint.union let eq_constraint = Constraint.equal -let merge_constraints c g = - Constraint.fold enforce_constraint c g type constraints = Constraint.t @@ -1378,218 +815,12 @@ let enforce_leq u v c = let enforce_leq_level u v c = if Level.equal u v then c else Constraint.add (u,Le,v) c -let check_constraint g (l,d,r) = - match d with - | Eq -> check_equal g l r - | Le -> check_smaller g false l r - | Lt -> check_smaller g true l r - -let check_constraints c g = - Constraint.for_all (check_constraint g) c - let enforce_univ_constraint (u,d,v) = match d with | Eq -> enforce_eq u v | Le -> enforce_leq u v | Lt -> enforce_leq (super u) v -(* Normalization *) - -let lookup_level u g = - try Some (UMap.find u g) with Not_found -> None - -(** [normalize_universes g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges - (see the assertion)... I (Stéphane Glondu) am not sure if this - plays a role in the rest of the module. *) -let normalize_universes g = - let rec visit u arc cache = match lookup_level u cache with - | Some x -> x, cache - | None -> match Lazy.force arc with - | None -> - u, UMap.add u u cache - | Some (Canonical {univ=v; lt=_; le=_}) -> - v, UMap.add u v cache - | Some (Equiv v) -> - let v, cache = visit v (lazy (lookup_level v g)) cache in - v, UMap.add u v cache - in - let cache = UMap.fold - (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) - g UMap.empty - in - let repr x = UMap.find x cache in - let lrepr us = List.fold_left - (fun e x -> LSet.add (repr x) e) LSet.empty us - in - let canonicalize u = function - | Equiv _ -> Equiv (repr u) - | Canonical {univ=v; lt=lt; le=le; rank=rank} -> - assert (u == v); - (* avoid duplicates and self-loops *) - let lt = lrepr lt and le = lrepr le in - let le = LSet.filter - (fun x -> x != u && not (LSet.mem x lt)) le - in - LSet.iter (fun x -> assert (x != u)) lt; - Canonical { - univ = v; - lt = LSet.elements lt; - le = LSet.elements le; - rank = rank; - status = Unset; - } - in - UMap.mapi canonicalize g - -let constraints_of_universes g = - let constraints_of u v acc = - match v with - | Canonical {univ=u; lt=lt; le=le} -> - let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in - let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in - acc - | Equiv v -> Constraint.add (u,Eq,v) acc - in - UMap.fold constraints_of g Constraint.empty - -let constraints_of_universes g = - constraints_of_universes (normalize_universes g) - -(** Longest path algorithm. This is used to compute the minimal number of - universes required if the only strict edge would be the Lt one. This - algorithm assumes that the given universes constraints are a almost DAG, in - the sense that there may be {Eq, Le}-cycles. This is OK for consistent - universes, which is the only case where we use this algorithm. *) - -(** Adjacency graph *) -type graph = constraint_type LMap.t LMap.t - -exception Connected - -(** Check connectedness *) -let connected x y (g : graph) = - let rec connected x target seen g = - if Level.equal x target then raise Connected - else if not (LSet.mem x seen) then - let seen = LSet.add x seen in - let fold z _ seen = connected z target seen g in - let neighbours = try LMap.find x g with Not_found -> LMap.empty in - LMap.fold fold neighbours seen - else seen - in - try ignore(connected x y LSet.empty g); false with Connected -> true - -let add_edge x y v (g : graph) = - try - let neighbours = LMap.find x g in - let neighbours = LMap.add y v neighbours in - LMap.add x neighbours g - with Not_found -> - LMap.add x (LMap.singleton y v) g - -(** We want to keep the graph DAG. If adding an edge would cause a cycle, that - would necessarily be an {Eq, Le}-cycle, otherwise there would have been a - universe inconsistency. Therefore we may omit adding such a cycling edge - without changing the compacted graph. *) -let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g - -(** Construct the DAG and its inverse at the same time. *) -let make_graph g : (graph * graph) = - let fold u arc accu = match arc with - | Equiv v -> - let (dir, rev) = accu in - (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev) - | Canonical { univ; lt; le; } -> - let () = assert (u == univ) in - let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in - let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in - (** Order is important : lt after le, because of the possible redundancy - between [le] and [lt] in a canonical arc. This way, the [lt] constraint - is the last one set, which is correct because it implies [le]. *) - let accu = List.fold_left fold_le accu le in - let accu = List.fold_left fold_lt accu lt in - accu - in - UMap.fold fold g (LMap.empty, LMap.empty) - -(** Construct a topological order out of a DAG. *) -let rec topological_fold u g rem seen accu = - let is_seen = - try - let status = LMap.find u seen in - assert status; (** If false, not a DAG! *) - true - with Not_found -> false - in - if not is_seen then - let rem = LMap.remove u rem in - let seen = LMap.add u false seen in - let neighbours = try LMap.find u g with Not_found -> LMap.empty in - let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in - let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in - (rem, LMap.add u true seen, u :: accu) - else (rem, seen, accu) - -let rec topological g rem seen accu = - let node = try Some (LMap.choose rem) with Not_found -> None in - match node with - | None -> accu - | Some (u, _) -> - let rem, seen, accu = topological_fold u g rem seen accu in - topological g rem seen accu - -(** Compute the longest path from any vertex. *) -let constraint_cost = function -| Eq | Le -> 0 -| Lt -> 1 - -(** This algorithm browses the graph in topological order, computing for each - encountered node the length of the longest path leading to it. Should be - O(|V|) or so (modulo map representation). *) -let rec flatten_graph rem (rev : graph) map mx = match rem with -| [] -> map, mx -| u :: rem -> - let prev = try LMap.find u rev with Not_found -> LMap.empty in - let fold v cstr accu = - let v_cost = LMap.find v map in - max (v_cost + constraint_cost cstr) accu - in - let u_cost = LMap.fold fold prev 0 in - let map = LMap.add u u_cost map in - flatten_graph rem rev map (max mx u_cost) - -(** [sort_universes g] builds a map from universes in [g] to natural - numbers. It outputs a graph containing equivalence edges from each - level appearing in [g] to [Type.n], and [lt] edges between the - [Type.n]s. The output graph should imply the input graph (and the - [Type.n]s. The output graph should imply the input graph (and the - implication will be strict most of the time), but is not - necessarily minimal. Note: the result is unspecified if the input - graph already contains [Type.n] nodes (calling a module Type is - probably a bad idea anyway). *) -let sort_universes orig = - let (dir, rev) = make_graph orig in - let order = topological dir dir LMap.empty [] in - let compact, max = flatten_graph order rev LMap.empty 0 in - let mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let types = Array.init (max + 1) (fun n -> Level.make mp n) in - (** Old universes are made equal to [Type.n] *) - let fold u level accu = UMap.add u (Equiv types.(level)) accu in - let sorted = LMap.fold fold compact UMap.empty in - (** Add all [Type.n] nodes *) - let fold i accu u = - if i < max then - let pred = types.(i + 1) in - let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in - UMap.add u (Canonical arc) accu - else accu - in - Array.fold_left_i fold sorted types - (* Miscellaneous functions to remove or test local univ assumed to occur in a universe *) @@ -1645,7 +876,6 @@ module Instance : sig val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds val levels : t -> LSet.t - val check_eq : t check_function end = struct type t = Level.t array @@ -1729,13 +959,6 @@ struct (* Necessary as universe instances might come from different modules and unmarshalling doesn't preserve sharing *)) - let check_eq g t1 t2 = - t1 == t2 || - (Int.equal (Array.length t1) (Array.length t2) && - let rec aux i = - (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) - in aux 0) - end let enforce_eq_instances x y = @@ -1985,27 +1208,6 @@ let abstract_universes poly ctx = (** Pretty-printing *) -let pr_arc prl = function - | _, Canonical {univ=u; lt=[]; le=[]} -> - mt () - | _, Canonical {univ=u; lt=lt; le=le} -> - let opt_sep = match lt, le with - | [], _ | _, [] -> mt () - | _ -> spc () - in - prl u ++ str " " ++ - v 0 - (pr_sequence (fun v -> str "< " ++ prl v) lt ++ - opt_sep ++ - pr_sequence (fun v -> str "<= " ++ prl v) le) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - -let pr_universes prl g = - let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in - prlist (pr_arc prl) graph - let pr_constraints prl = Constraint.pr prl let pr_universe_context = UContext.pr @@ -2018,19 +1220,6 @@ let pr_universe_subst = let pr_universe_level_subst = LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ()) -(* Dumping constraints to a file *) - -let dump_universes output g = - let dump_arc u = function - | Canonical {univ=u; lt=lt; le=le} -> - let u_str = Level.to_string u in - List.iter (fun v -> output Lt (Level.to_string v) u_str) lt; - List.iter (fun v -> output Le (Level.to_string v) u_str) le - | Equiv v -> - output Eq (Level.to_string u) (Level.to_string v) - in - UMap.iter dump_arc g - module Huniverse_set = Hashcons.Make( struct @@ -2078,26 +1267,3 @@ let subst_instance_constraints = let key = Profile.declare_profile "subst_instance_constraints" in Profile.profile2 key subst_instance_constraints else subst_instance_constraints - -let merge_constraints = - if Flags.profile then - let key = Profile.declare_profile "merge_constraints" in - Profile.profile2 key merge_constraints - else merge_constraints -let check_constraints = - if Flags.profile then - let key = Profile.declare_profile "check_constraints" in - Profile.profile2 key check_constraints - else check_constraints - -let check_eq = - if Flags.profile then - let check_eq_key = Profile.declare_profile "check_eq" in - Profile.profile3 check_eq_key check_eq - else check_eq - -let check_leq = - if Flags.profile then - let check_leq_key = Profile.declare_profile "check_leq" in - Profile.profile3 check_leq_key check_leq - else check_leq diff --git a/kernel/univ.mli b/kernel/univ.mli index 4cc8a2528f..dbbc832625 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -40,6 +40,9 @@ sig val pr : t -> Pp.std_ppcmds (** Pretty-printing *) + val to_string : t -> string + (** Debug printing *) + val var : int -> t val var_index : t -> int option @@ -115,6 +118,9 @@ sig val type1 : t (** the universe of the type of Prop/Set *) + + val exists : (Level.t * int -> bool) -> t -> bool + val for_all : (Level.t * int -> bool) -> t -> bool end type universe = Universe.t @@ -148,31 +154,6 @@ val univ_level_mem : universe_level -> universe -> bool val univ_level_rem : universe_level -> universe -> universe -> universe -(** {6 Graphs of universes. } *) - -type universes - -type 'a check_function = universes -> 'a -> 'a -> bool -val check_leq : universe check_function -val check_eq : universe check_function - -(** The empty graph of universes *) -val empty_universes : universes - -(** The initial graph of universes: Prop < Set *) -val initial_universes : universes - -val is_initial_universes : universes -> bool - -val sort_universes : universes -> universes - -(** Adds a universe to the graph, ensuring it is >= or > Set. - @raises AlreadyDeclared if the level is already declared in the graph. *) - -exception AlreadyDeclared - -val add_universe : universe_level -> bool -> universes -> universes - (** {6 Constraints. } *) type constraint_type = Lt | Le | Eq @@ -203,12 +184,6 @@ val enforce_leq : universe constraint_function val enforce_eq_level : universe_level constraint_function val enforce_leq_level : universe_level constraint_function -(** {6 ... } *) -(** Merge of constraints in a universes graph. - The function [merge_constraints] merges a set of constraints in a given - universes graph. It raises the exception [UniverseInconsistency] if the - constraints are not satisfiable. *) - (** Type explanation is used to decorate error messages to provide useful explanation why a given constraint is rejected. It is composed of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means @@ -226,14 +201,6 @@ type univ_inconsistency = constraint_type * universe * universe * explanation op exception UniverseInconsistency of univ_inconsistency -val enforce_constraint : univ_constraint -> universes -> universes -val merge_constraints : constraints -> universes -> universes - -val constraints_of_universes : universes -> constraints - -val check_constraint : universes -> univ_constraint -> bool -val check_constraints : constraints -> universes -> bool - (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) @@ -309,8 +276,6 @@ sig val levels : t -> LSet.t (** The set of levels in the instance *) - val check_eq : t check_function - (** Check equality of instances w.r.t. a universe graph *) end type universe_instance = Instance.t @@ -424,7 +389,6 @@ val instantiate_univ_constraints : universe_instance -> universe_context -> cons (** {6 Pretty-printing of universes. } *) -val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds val pr_constraint_type : constraint_type -> Pp.std_ppcmds val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds @@ -435,12 +399,6 @@ val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) -> val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds val pr_universe_subst : universe_subst -> Pp.std_ppcmds -(** {6 Dumping to a file } *) - -val dump_universes : - (constraint_type -> string -> string -> unit) -> - universes -> unit - (** {6 Hash-consing } *) val hcons_univ : universe -> universe diff --git a/library/global.mli b/library/global.mli index ac231f7fd8..455751d416 100644 --- a/library/global.mli +++ b/library/global.mli @@ -19,7 +19,7 @@ val env : unit -> Environ.env val env_is_initial : unit -> bool -val universes : unit -> Univ.universes +val universes : unit -> UGraph.t val named_context_val : unit -> Environ.named_context_val val named_context : unit -> Context.named_context diff --git a/library/universes.ml b/library/universes.ml index bc42cc044c..067558c8a6 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -113,7 +113,7 @@ let to_constraints g s = | _, ULe, Some l' -> enforce_leq x y acc | _, ULub, _ -> acc | _, d, _ -> - let f = if d == ULe then check_leq else check_eq in + let f = if d == ULe then UGraph.check_leq else UGraph.check_eq in if f g x y then acc else raise (Invalid_argument "to_constraints: non-trivial algebraic constraint between universes") @@ -123,12 +123,12 @@ let eq_constr_univs_infer univs m n = if m == n then true, Constraints.empty else let cstrs = ref Constraints.empty in - let eq_universes strict = Univ.Instance.check_eq univs in + let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true + if UGraph.check_eq univs u1 u2 then true else (cstrs := Constraints.add (u1, UEq, u2) !cstrs; true) @@ -149,12 +149,12 @@ let eq_constr_univs_infer_with kind1 kind2 univs m n = [kind1,kind2], because [kind1] and [kind2] may be different, typically evaluating [m] and [n] in different evar maps. *) let cstrs = ref Constraints.empty in - let eq_universes strict = Univ.Instance.check_eq univs in + let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true + if UGraph.check_eq univs u1 u2 then true else (cstrs := Constraints.add (u1, UEq, u2) !cstrs; true) @@ -169,12 +169,12 @@ let leq_constr_univs_infer univs m n = if m == n then true, Constraints.empty else let cstrs = ref Constraints.empty in - let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in + let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true + if UGraph.check_eq univs u1 u2 then true else (cstrs := Constraints.add (u1, UEq, u2) !cstrs; true) in @@ -182,7 +182,7 @@ let leq_constr_univs_infer univs m n = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_leq univs u1 u2 then + if UGraph.check_leq univs u1 u2 then ((if Univ.is_small_univ u1 then cstrs := Constraints.add (u1, ULe, u2) !cstrs); true) @@ -845,27 +845,27 @@ let normalize_context_set ctx us algs = let csts = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) - let g = Univ.LSet.fold (fun v g -> Univ.add_universe v false g) - ctx Univ.empty_universes + let g = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) + ctx UGraph.empty_universes in let g = Univ.Constraint.fold (fun (l, d, r) g -> let g = if not (Level.is_small l || LSet.mem l ctx) then - try Univ.add_universe l false g - with Univ.AlreadyDeclared -> g + try UGraph.add_universe l false g + with UGraph.AlreadyDeclared -> g else g in let g = if not (Level.is_small r || LSet.mem r ctx) then - try Univ.add_universe r false g - with Univ.AlreadyDeclared -> g + try UGraph.add_universe r false g + with UGraph.AlreadyDeclared -> g else g in g) csts g in - let g = Univ.Constraint.fold Univ.enforce_constraint csts g in - Univ.constraints_of_universes g + let g = Univ.Constraint.fold UGraph.enforce_constraint csts g in + UGraph.constraints_of_universes g in let noneqs = Constraint.fold (fun (l,d,r as cstr) noneqs -> @@ -995,7 +995,7 @@ let refresh_constraints univs (ctx, cstrs) = Univ.Constraint.fold (fun c (cstrs', univs as acc) -> let c = translate_cstr c in if is_trivial_leq c then acc - else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs)) + else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) cstrs (Univ.Constraint.empty, univs) in ((ctx, cstrs'), univs') diff --git a/library/universes.mli b/library/universes.mli index 5527da0903..c897a88a90 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -60,11 +60,11 @@ val subst_univs_universe_constraints : universe_subst_fn -> val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function -val to_constraints : universes -> universe_constraints -> constraints +val to_constraints : UGraph.t -> universe_constraints -> constraints (** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) -val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_constrained +val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained (** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of {!eq_constr_univs_infer} taking kind-of-term functions, to expose @@ -72,12 +72,12 @@ val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_ val eq_constr_univs_infer_with : (constr -> (constr,types) kind_of_term) -> (constr -> (constr,types) kind_of_term) -> - Univ.universes -> constr -> constr -> bool universe_constrained + UGraph.t -> constr -> constr -> bool universe_constrained (** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) -val leq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_constrained +val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) @@ -212,7 +212,7 @@ val restrict_universe_context : universe_context_set -> universe_set -> universe val simplify_universe_context : universe_context_set -> universe_context_set * universe_level_subst -val refresh_constraints : universes -> universe_context_set -> universe_context_set * universes +val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_set * UGraph.t (** Pretty-printing *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 2efd8fe413..6373e60791 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -111,7 +111,7 @@ let interp_universe_level_name evd s = let level = Univ.Level.make dp num in let evd = try Evd.add_global_univ evd level - with Univ.AlreadyDeclared -> evd + with UGraph.AlreadyDeclared -> evd in evd, level else try diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 1df2a73b2e..5e1c467c82 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -251,7 +251,7 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val sort_cmp : env -> conv_pb -> sorts -> sorts -> universes -> unit +val sort_cmp : env -> conv_pb -> sorts -> sorts -> UGraph.t -> unit val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index c07c756c01..229f3acfdd 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -347,7 +347,7 @@ let dump_universes_gen g s = end in try - Univ.dump_universes output_constraint g; + UGraph.dump_universes output_constraint g; close (); msg_info (str "Universes written to file \"" ++ str s ++ str "\".") with reraise -> @@ -357,7 +357,7 @@ let dump_universes_gen g s = let dump_universes sorted s = let g = Global.universes () in - let g = if sorted then Univ.sort_universes g else g in + let g = if sorted then UGraph.sort_universes g else g in dump_universes_gen g s (*********************) @@ -1640,12 +1640,12 @@ let vernac_print = function | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ()) | PrintUniverses (b, None) -> let univ = Global.universes () in - let univ = if b then Univ.sort_universes univ else univ in + let univ = if b then UGraph.sort_universes univ else univ in let pr_remaining = if Global.is_joined_environment () then mt () else str"There may remain asynchronous universe constraints" in - msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) + msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) | PrintUniverses (b, Some s) -> dump_universes b s | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) -- cgit v1.2.3 From d37aab528dca587127b9f9944e1521e4fc3d9cc7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 7 Oct 2015 13:11:52 +0200 Subject: Univs: add Strict Universe Declaration option (on by default) This option disallows "declare at first use" semantics for universe variables (in @{}), forcing the declaration of _all_ universes appearing in a definition when introducing it with syntax Definition/Inductive foo@{i j k} .. The bound universes at the end of a definition/inductive must be exactly those ones, no extras allowed currently. Test-suite files using the old semantics just disable the option. --- intf/misctypes.mli | 4 ++-- parsing/g_constr.ml4 | 8 ++++---- pretyping/detyping.ml | 4 ++-- pretyping/evd.ml | 6 ------ pretyping/miscops.ml | 2 +- pretyping/pretyping.ml | 26 ++++++++++++++++++++++---- printing/ppconstr.ml | 6 +++--- test-suite/bugs/closed/3330.v | 1 + test-suite/bugs/closed/3352.v | 1 + test-suite/bugs/closed/3386.v | 1 + test-suite/bugs/closed/3387.v | 1 + test-suite/bugs/closed/3559.v | 1 + test-suite/bugs/closed/3566.v | 1 + test-suite/bugs/closed/3666.v | 1 + test-suite/bugs/closed/3690.v | 1 + test-suite/bugs/closed/3777.v | 1 + test-suite/bugs/closed/3779.v | 1 + test-suite/bugs/closed/3808.v | 1 + test-suite/bugs/closed/3821.v | 1 + test-suite/bugs/closed/3922.v | 1 + test-suite/bugs/closed/4089.v | 1 + test-suite/bugs/closed/4121.v | 1 + test-suite/bugs/closed/4287.v | 1 + test-suite/bugs/closed/4299.v | 12 ++++++++++++ test-suite/bugs/closed/4301.v | 1 + test-suite/bugs/closed/HoTT_coq_007.v | 1 + test-suite/bugs/closed/HoTT_coq_036.v | 1 + test-suite/bugs/closed/HoTT_coq_062.v | 1 + test-suite/bugs/closed/HoTT_coq_093.v | 1 + test-suite/bugs/opened/3754.v | 1 + test-suite/success/namedunivs.v | 2 ++ test-suite/success/polymorphism.v | 2 ++ test-suite/success/univnames.v | 26 ++++++++++++++++++++++++++ theories/Classes/CMorphisms.v | 5 +++-- toplevel/command.ml | 5 +++-- 35 files changed, 104 insertions(+), 26 deletions(-) create mode 100644 test-suite/bugs/closed/4299.v create mode 100644 test-suite/success/univnames.v diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 74e136904d..5c11119ed8 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -44,8 +44,8 @@ type 'id move_location = (** Sorts *) type 'a glob_sort_gen = GProp | GSet | GType of 'a -type sort_info = string list -type level_info = string option +type sort_info = string Loc.located list +type level_info = string Loc.located option type glob_sort = sort_info glob_sort_gen type glob_level = level_info glob_sort_gen diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index e47e3fb1e6..9fe3022341 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -153,12 +153,12 @@ GEXTEND Gram [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType [] - | "Type"; "@{"; u = universe; "}" -> GType (List.map Id.to_string u) + | "Type"; "@{"; u = universe; "}" -> GType (List.map (fun (loc,x) -> (loc, Id.to_string x)) u) ] ] ; universe: - [ [ IDENT "max"; "("; ids = LIST1 ident SEP ","; ")" -> ids - | id = ident -> [id] + [ [ IDENT "max"; "("; ids = LIST1 identref SEP ","; ")" -> ids + | id = identref -> [id] ] ] ; lconstr: @@ -302,7 +302,7 @@ GEXTEND Gram [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType None - | id = ident -> GType (Some (Id.to_string id)) + | id = identref -> GType (Some (fst id, Id.to_string (snd id))) ] ] ; fix_constr: diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 8bd57290b0..a1213e72be 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -401,7 +401,7 @@ let detype_sort sigma = function | Type u -> GType (if !print_universes - then [Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)] + then [dl, Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)] else []) type binder_kind = BProd | BLambda | BLetIn @@ -413,7 +413,7 @@ let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = - GType (Some (Pp.string_of_ppcmds (Evd.pr_evd_level sigma l))) + GType (Some (dl, Pp.string_of_ppcmds (Evd.pr_evd_level sigma l))) let detype_instance sigma l = if Univ.Instance.is_empty l then None diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 4e0b6f75e7..4372668fcf 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1074,12 +1074,6 @@ let uctx_new_univ_variable rigid name predicative uctx_univ_algebraic = Univ.LSet.add u avars}, false else {uctx with uctx_univ_variables = uvars'}, false in - (* let ctx' = *) - (* if pred then *) - (* Univ.ContextSet.add_constraints *) - (* (Univ.Constraint.singleton (Univ.Level.set, Univ.Le, u)) ctx' *) - (* else ctx' *) - (* in *) let names = match name with | Some n -> add_uctx_names n u uctx.uctx_names diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index 0926e7a299..a0ec1baae2 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -30,7 +30,7 @@ let smartmap_cast_type f c = let glob_sort_eq g1 g2 = match g1, g2 with | GProp, GProp -> true | GSet, GSet -> true -| GType l1, GType l2 -> List.equal CString.equal l1 l2 +| GType l1, GType l2 -> List.equal (fun x y -> CString.equal (snd x) (snd y)) l1 l2 | _ -> false let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 2efd8fe413..dec23328f4 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -99,8 +99,22 @@ let search_guard loc env possible_indexes fixdefs = let ((constr_in : constr -> Dyn.t), (constr_out : Dyn.t -> constr)) = Dyn.create "constr" +(* To force universe name declaration before use *) + +let strict_universe_declarations = ref true +let is_strict_universe_declarations () = !strict_universe_declarations + +let _ = + Goptions.(declare_bool_option + { optsync = true; + optdepr = false; + optname = "strict universe declaration"; + optkey = ["Strict";"Universe";"Declaration"]; + optread = is_strict_universe_declarations; + optwrite = (:=) strict_universe_declarations }) + (** Miscellaneous interpretation functions *) -let interp_universe_level_name evd s = +let interp_universe_level_name evd (loc,s) = let names, _ = Universes.global_universe_names () in if CString.string_contains s "." then match List.rev (CString.split '.' s) with @@ -122,7 +136,10 @@ let interp_universe_level_name evd s = try let level = Evd.universe_of_name evd s in evd, level with Not_found -> - new_univ_level_variable ~name:s univ_rigid evd + if not (is_strict_universe_declarations ()) then + new_univ_level_variable ~name:s univ_rigid evd + else user_err_loc (loc, "interp_universe_level_name", + Pp.(str "Undeclared universe: " ++ str s)) let interp_universe evd = function | [] -> let evd, l = new_univ_level_variable univ_rigid evd in @@ -135,7 +152,7 @@ let interp_universe evd = function let interp_universe_level evd = function | None -> new_univ_level_variable univ_rigid evd - | Some s -> interp_universe_level_name evd s + | Some (loc,s) -> interp_universe_level_name evd (loc,s) let interp_sort evd = function | GProp -> evd, Prop Null @@ -357,7 +374,8 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let interp_universe_level_name evd = function +let interp_universe_level_name evd l = + match l with | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set | GType s -> interp_universe_level evd s diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 650b8f7262..ea705e335e 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -140,8 +140,8 @@ end) = struct let pr_univ l = match l with - | [x] -> str x - | l -> str"max(" ++ prlist_with_sep (fun () -> str",") str l ++ str")" + | [_,x] -> str x + | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> str (snd x)) l ++ str")" let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" @@ -174,7 +174,7 @@ end) = struct tag_type (str "Set") | GType u -> (match u with - | Some u -> str u + | Some (_,u) -> str u | None -> tag_type (str "Type")) let pr_universe_instance l = diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index 4cd7c39e88..e6a50449da 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v index b57b0a0f0b..f8113e4c78 100644 --- a/test-suite/bugs/closed/3352.v +++ b/test-suite/bugs/closed/3352.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* I'm not sure what the general rule should be; intuitively, I want [IsHProp (* Set *) Foo] to mean [IsHProp (* U >= Set *) Foo]. (I think this worked in HoTT/coq, too.) Morally, [IsHProp] has no universe level associated with it distinct from that of its argument, you should never get a universe inconsistency from unifying [IsHProp A] with [IsHProp A]. (The issue is tricker when IsHProp uses [A] elsewhere, as in: diff --git a/test-suite/bugs/closed/3386.v b/test-suite/bugs/closed/3386.v index 0e236c2172..b8bb8bce09 100644 --- a/test-suite/bugs/closed/3386.v +++ b/test-suite/bugs/closed/3386.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Set Printing Universes. Record Cat := { Obj :> Type }. diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v index ae212caa5d..cb435e7865 100644 --- a/test-suite/bugs/closed/3387.v +++ b/test-suite/bugs/closed/3387.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Set Printing Universes. Record Cat := { Obj :> Type }. diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v index 50645090fa..da12b68689 100644 --- a/test-suite/bugs/closed/3559.v +++ b/test-suite/bugs/closed/3559.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* File reduced by coq-bug-finder from original input, then from 8657 lines to 4731 lines, then from 4174 lines to 192 lines, then from 161 lines to 55 lines, then from 51 lines to 37 lines, then from 43 lines to 30 lines *) diff --git a/test-suite/bugs/closed/3566.v b/test-suite/bugs/closed/3566.v index b2aa8c3cd6..e2d7976981 100644 --- a/test-suite/bugs/closed/3566.v +++ b/test-suite/bugs/closed/3566.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Notation idmap := (fun x => x). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. Arguments idpath {A a} , [A] a. diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v index a5b0e9347d..e69ec10976 100644 --- a/test-suite/bugs/closed/3666.v +++ b/test-suite/bugs/closed/3666.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *) (* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index 4069e38075..df9f5f4761 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Printing Universes. Set Universe Polymorphism. Definition foo (a := Type) (b := Type) (c := Type) := Type. diff --git a/test-suite/bugs/closed/3777.v b/test-suite/bugs/closed/3777.v index b9b2dd6b3e..e203528fcc 100644 --- a/test-suite/bugs/closed/3777.v +++ b/test-suite/bugs/closed/3777.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Module WithoutPoly. Unset Universe Polymorphism. Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. diff --git a/test-suite/bugs/closed/3779.v b/test-suite/bugs/closed/3779.v index eb0d206c5c..2b44e225e8 100644 --- a/test-suite/bugs/closed/3779.v +++ b/test-suite/bugs/closed/3779.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Record UnitSubuniverse := { a : Type@{sm} ; x : (Type@{sm} : Type@{lg}) ; inO_internal : Type@{lg} -> Type@{lg} }. Class In (O : UnitSubuniverse@{sm lg}) (T : Type@{lg}) := in_inO_internal : inO_internal O T. diff --git a/test-suite/bugs/closed/3808.v b/test-suite/bugs/closed/3808.v index 6e19ddf8dc..a5c84e6856 100644 --- a/test-suite/bugs/closed/3808.v +++ b/test-suite/bugs/closed/3808.v @@ -1,2 +1,3 @@ +Unset Strict Universe Declaration. Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) := foo : Foo. \ No newline at end of file diff --git a/test-suite/bugs/closed/3821.v b/test-suite/bugs/closed/3821.v index 8da4f73626..30261ed266 100644 --- a/test-suite/bugs/closed/3821.v +++ b/test-suite/bugs/closed/3821.v @@ -1,2 +1,3 @@ +Unset Strict Universe Declaration. Inductive quotient {A : Type@{i}} {B : Type@{j}} : Type@{max(i, j)} := . diff --git a/test-suite/bugs/closed/3922.v b/test-suite/bugs/closed/3922.v index 0ccc92067d..5013bc6ac1 100644 --- a/test-suite/bugs/closed/3922.v +++ b/test-suite/bugs/closed/3922.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. Set Universe Polymorphism. Notation Type0 := Set. diff --git a/test-suite/bugs/closed/4089.v b/test-suite/bugs/closed/4089.v index c6cb9c35e6..e4d76732a3 100644 --- a/test-suite/bugs/closed/4089.v +++ b/test-suite/bugs/closed/4089.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from original input, then from 6522 lines to 318 lines, then from 1139 lines to 361 lines *) diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v index 5f8c411ca8..d34a2b8b1b 100644 --- a/test-suite/bugs/closed/4121.v +++ b/test-suite/bugs/closed/4121.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* -*- coq-prog-args: ("-emacs" "-nois") -*- *) (* File reduced by coq-bug-finder from original input, then from 830 lines to 47 lines, then from 25 lines to 11 lines *) (* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0 diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index e139c5b6c9..0623cf5b84 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Universe b. diff --git a/test-suite/bugs/closed/4299.v b/test-suite/bugs/closed/4299.v new file mode 100644 index 0000000000..955c3017d7 --- /dev/null +++ b/test-suite/bugs/closed/4299.v @@ -0,0 +1,12 @@ +Unset Strict Universe Declaration. +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type : Type. + Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type : Type. + Definition U := let X := Type in Type. + Definition eq : Type = U := eq_refl. +Fail End M. \ No newline at end of file diff --git a/test-suite/bugs/closed/4301.v b/test-suite/bugs/closed/4301.v index 3b00efb213..b4e17c2231 100644 --- a/test-suite/bugs/closed/4301.v +++ b/test-suite/bugs/closed/4301.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Module Type Foo. diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v index 0b8bb23534..844ff87566 100644 --- a/test-suite/bugs/closed/HoTT_coq_007.v +++ b/test-suite/bugs/closed/HoTT_coq_007.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. Module Comment1. Set Implicit Arguments. diff --git a/test-suite/bugs/closed/HoTT_coq_036.v b/test-suite/bugs/closed/HoTT_coq_036.v index 4c3e078a50..7a84531a77 100644 --- a/test-suite/bugs/closed/HoTT_coq_036.v +++ b/test-suite/bugs/closed/HoTT_coq_036.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Module Version1. Set Implicit Arguments. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v index b7db22a69e..90d1d18306 100644 --- a/test-suite/bugs/closed/HoTT_coq_062.v +++ b/test-suite/bugs/closed/HoTT_coq_062.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *) diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v index f382dac976..4f8868d538 100644 --- a/test-suite/bugs/closed/HoTT_coq_093.v +++ b/test-suite/bugs/closed/HoTT_coq_093.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (** It would be nice if we had more lax constraint checking of inductive types, and had variance annotations on their universes *) Set Printing All. Set Printing Implicit. diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v index 9b3f94d917..a717bbe735 100644 --- a/test-suite/bugs/opened/3754.v +++ b/test-suite/bugs/opened/3754.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) (* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 diff --git a/test-suite/success/namedunivs.v b/test-suite/success/namedunivs.v index 059462fac3..f9154ef576 100644 --- a/test-suite/success/namedunivs.v +++ b/test-suite/success/namedunivs.v @@ -4,6 +4,8 @@ (* Fail exact H. *) (* Section . *) +Unset Strict Universe Declaration. + Section lift_strict. Polymorphic Definition liftlt := let t := Type@{i} : Type@{k} in diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 957612ef1d..d6bbfe29ac 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -1,3 +1,5 @@ +Unset Strict Universe Declaration. + Module withoutpoly. Inductive empty :=. diff --git a/test-suite/success/univnames.v b/test-suite/success/univnames.v new file mode 100644 index 0000000000..31d264f645 --- /dev/null +++ b/test-suite/success/univnames.v @@ -0,0 +1,26 @@ +Set Universe Polymorphism. + +Definition foo@{i j} (A : Type@{i}) (B : Type@{j}) := A. + +Set Printing Universes. + +Fail Definition bar@{i} (A : Type@{i}) (B : Type) := A. + +Definition baz@{i j} (A : Type@{i}) (B : Type@{j}) := (A * B)%type. + +Fail Definition bad@{i j} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Fail Definition bad@{i} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Definition shuffle@{i j} (A : Type@{j}) (B : Type@{i}) := (A * B)%type. + +Definition nothing (A : Type) := A. + +Inductive bla@{l k} : Type@{k} := blaI : Type@{l} -> bla. + +Inductive blacopy@{k l} : Type@{k} := blacopyI : Type@{l} -> blacopy. + + +Universe g. + +Inductive blacopy'@{l} : Type@{g} := blacopy'I : Type@{l} -> blacopy'. \ No newline at end of file diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 9d3952e64a..fdedbf672a 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -266,8 +266,10 @@ Section GenericInstances. transitivity (y x0)... Qed. + Unset Strict Universe Declaration. + (** The complement of a crelation conserves its proper elements. *) - Program Definition complement_proper + Program Definition complement_proper (A : Type@{k}) (RA : crelation A) `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : Proper (RA ==> RA ==> iff) (complement@{i j Prop} R) := _. @@ -279,7 +281,6 @@ Section GenericInstances. Qed. (** The [flip] too, actually the [flip] instance is a bit more general. *) - Program Definition flip_proper `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : Proper (RB ==> RA ==> RC) (flip f) := _. diff --git a/toplevel/command.ml b/toplevel/command.ml index b65ff73feb..285baf3f97 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -500,12 +500,13 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = check_all_names_different indl; List.iter check_param paramsl; let env0 = Global.env() in - let evdref = ref Evd.(from_env env0) in + let pl = (List.hd indl).ind_univs in + let ctx = Evd.make_evar_universe_context env0 pl in + let evdref = ref Evd.(from_ctx ctx) in let _, ((env_params, ctx_params), userimpls) = interp_context_evars env0 evdref paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in - let pl = (List.hd indl).ind_univs in (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter(fun (_,b,_) -> Option.is_empty b) ctx_params in -- cgit v1.2.3 From 8a7f111ad5ce35e183016a2a968d19f29b7622c5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Oct 2015 14:32:30 +0200 Subject: Record fields accept an optional final semicolon separator. There is no such thing as the OPTSEP macro in Camlp4 so I had to expand it by hand. --- parsing/g_constr.ml4 | 22 +++++++++++++++++++--- parsing/g_vernac.ml4 | 11 +++++++++-- 2 files changed, 28 insertions(+), 5 deletions(-) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 9fe3022341..e2e6795f73 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -224,11 +224,20 @@ GEXTEND Gram ] ] ; record_declaration: - [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (!@loc, None, fs) + [ [ fs = record_fields -> CRecord (!@loc, None, fs) (* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) (* CRecord (!@loc, Some c, fs) *) ] ] ; + + record_fields: + [ [ f = record_field_declaration; ";"; fs = record_fields -> f :: fs + | f = record_field_declaration; ";" -> [f] + | f = record_field_declaration -> [f] + | -> [] + ] ] + ; + record_field_declaration: [ [ id = global; params = LIST0 identref; ":="; c = lconstr -> (id, abstract_constr_expr c (binders_of_lidents params)) ] ] @@ -356,9 +365,16 @@ GEXTEND Gram [ [ pll = LIST1 mult_pattern SEP "|"; "=>"; rhs = lconstr -> (!@loc,pll,rhs) ] ] ; - recordpattern: + record_pattern: [ [ id = global; ":="; pat = pattern -> (id, pat) ] ] ; + record_patterns: + [ [ p = record_pattern; ";"; ps = record_patterns -> p :: ps + | p = record_pattern; ";" -> [p] + | p = record_pattern-> [p] + | -> [] + ] ] + ; pattern: [ "200" RIGHTA [ ] | "100" RIGHTA @@ -382,7 +398,7 @@ GEXTEND Gram [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] | "0" [ r = Prim.reference -> CPatAtom (!@loc,Some r) - | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (!@loc, pat) + | "{|"; pat = record_patterns; "|}" -> CPatRecord (!@loc, pat) | "_" -> CPatAtom (!@loc,None) | "("; p = pattern LEVEL "200"; ")" -> (match p with diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 63850713f2..e9915fceb3 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -325,9 +325,9 @@ GEXTEND Gram | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> Constructors ((c id)::l) | id = identref ; c = constructor_type -> Constructors [ c id ] - | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> + | cstr = identref; "{"; fs = record_fields; "}" -> RecordDecl (Some cstr,fs) - | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) + | "{";fs = record_fields; "}" -> RecordDecl (None,fs) | -> Constructors [] ] ] ; (* @@ -389,6 +389,13 @@ GEXTEND Gram [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> n ]; ntn = decl_notation -> (bd,pri),ntn ] ] ; + record_fields: + [ [ f = record_field; ";"; fs = record_fields -> f :: fs + | f = record_field; ";" -> [f] + | f = record_field -> [f] + | -> [] + ] ] + ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN (!@loc) l t)) -- cgit v1.2.3 From 27492a7674587e1a3372cd7545e056e2775c69b3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Oct 2015 14:43:49 +0200 Subject: Test for record syntax parsing. --- test-suite/success/record_syntax.v | 47 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) create mode 100644 test-suite/success/record_syntax.v diff --git a/test-suite/success/record_syntax.v b/test-suite/success/record_syntax.v new file mode 100644 index 0000000000..db2bbb0dc7 --- /dev/null +++ b/test-suite/success/record_syntax.v @@ -0,0 +1,47 @@ +Module A. + +Record Foo := { foo : unit; bar : unit }. + +Definition foo_ := {| + foo := tt; + bar := tt +|}. + +Definition foo0 (p : Foo) := match p with {| |} => tt end. +Definition foo1 (p : Foo) := match p with {| foo := f |} => f end. +Definition foo2 (p : Foo) := match p with {| foo := f; |} => f end. +Definition foo3 (p : Foo) := match p with {| foo := f; bar := g |} => (f, g) end. +Definition foo4 (p : Foo) := match p with {| foo := f; bar := g; |} => (f, g) end. + +End A. + +Module B. + +Record Foo := { }. + +End B. + +Module C. + +Record Foo := { foo : unit; bar : unit; }. + +Definition foo_ := {| + foo := tt; + bar := tt; +|}. + +End C. + +Module D. + +Record Foo := { foo : unit }. +Definition foo_ := {| foo := tt |}. + +End D. + +Module E. + +Record Foo := { foo : unit; }. +Definition foo_ := {| foo := tt; |}. + +End E. -- cgit v1.2.3 From 08a0c44e3525d1f0c7303d189e826e25c3e3d914 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 7 Oct 2015 16:00:16 +0200 Subject: Univs: fix FingerTree contrib. Let merge_context_set be lenient when merging the context of side effects of an entry from solve_by_tac. --- pretyping/evd.ml | 4 ++-- pretyping/evd.mli | 2 +- toplevel/obligations.ml | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 4372668fcf..412fb92b3d 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1028,8 +1028,8 @@ let merge_uctx sideff rigid uctx ctx' = let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } -let merge_context_set rigid evd ctx' = - {evd with universes = merge_uctx false rigid evd.universes ctx'} +let merge_context_set ?(sideff=false) rigid evd ctx' = + {evd with universes = merge_uctx sideff rigid evd.universes ctx'} let merge_uctx_subst uctx s = { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 5a59c1776c..52d7d42120 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -542,7 +542,7 @@ val universes : evar_map -> Univ.universes val merge_universe_context : evar_map -> evar_universe_context -> evar_map val set_universe_context : evar_map -> evar_universe_context -> evar_map -val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map +val merge_context_set : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index b942034df7..00ea2ffb84 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -796,7 +796,7 @@ let solve_by_tac name evi t poly ctx = let entry = Term_typing.handle_entry_side_effects env entry in let body, eff = Future.force entry.Entries.const_entry_body in assert(Declareops.side_effects_is_empty eff); - let ctx' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in + let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard (Global.env ()) (fst body); (fst body), entry.Entries.const_entry_type, Evd.evar_universe_context ctx' -- cgit v1.2.3 From e26b4dbedd29acbfb9cbf2320193cc68afa60cf3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 7 Oct 2015 16:51:53 +0200 Subject: Fix bug #4069: f_equal regression. --- plugins/cc/cctac.ml | 17 ++++++++++----- test-suite/bugs/closed/4069.v | 51 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 5 deletions(-) create mode 100644 test-suite/bugs/closed/4069.v diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 6439f58d24..cbd95eaeaf 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -482,6 +482,15 @@ let congruence_tac depth l = This isn't particularly related with congruence, apart from the fact that congruence is called internally. *) + +let new_app_global_check f args k = + new_app_global f args + (fun c -> + Proofview.Goal.enter + begin fun gl -> + let evm, _ = Tacmach.New.pf_apply type_of gl c in + Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k c) + end) let f_equal = Proofview.Goal.nf_enter begin fun gl -> @@ -490,11 +499,9 @@ let f_equal = let cut_eq c1 c2 = try (* type_of can raise an exception *) let ty = (* Termops.refresh_universes *) (type_of c1) in - if eq_constr_nounivs c1 c2 then Proofview.tclUNIT () - else - Tacticals.New.tclTRY (Tacticals.New.tclTHEN - ((new_app_global _eq [|ty; c1; c2|]) Tactics.cut) - (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply))) + Tacticals.New.tclTHEN + ((new_app_global_check _eq [|ty; c1; c2|]) Tactics.cut) + (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE diff --git a/test-suite/bugs/closed/4069.v b/test-suite/bugs/closed/4069.v new file mode 100644 index 0000000000..21b03ce541 --- /dev/null +++ b/test-suite/bugs/closed/4069.v @@ -0,0 +1,51 @@ + +Lemma test1 : +forall (v : nat) (f g : nat -> nat), +f v = g v. +intros. f_equal. +(* +Goal in v8.5: f v = g v +Goal in v8.4: v = v -> f v = g v +Expected: f = g +*) +Admitted. + +Lemma test2 : +forall (v u : nat) (f g : nat -> nat), +f v = g u. +intros. f_equal. +(* +In both v8.4 And v8.5 +Goal 1: v = u -> f v = g u +Goal 2: v = u + +Expected Goal 1: f = g +Expected Goal 2: v = u +*) +Admitted. + +Lemma test3 : +forall (v : nat) (u : list nat) (f : nat -> nat) (g : list nat -> nat), +f v = g u. +intros. f_equal. +(* +In both v8.4 And v8.5, the goal is unchanged. +*) +Admitted. + +Require Import List. +Lemma foo n (l k : list nat) : k ++ skipn n l = skipn n l. +Proof. f_equal. +(* + 8.4: leaves the goal unchanged, i.e. k ++ skipn n l = skipn n l + 8.5: 2 goals, skipn n l = l -> k ++ skipn n l = skipn n l + and skipn n l = l +*) +Require Import List. +Fixpoint replicate {A} (n : nat) (x : A) : list A := + match n with 0 => nil | S n => x :: replicate n x end. +Lemma bar {A} n m (x : A) : + skipn n (replicate m x) = replicate (m - n) x -> + skipn n (replicate m x) = replicate (m - n) x. +Proof. intros. f_equal. +(* 8.5: one goal, n = m - n *) -- cgit v1.2.3 From 27d4a636cb7f1fbdbced1980808a9b947405eeb5 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 7 Oct 2015 23:08:45 +0200 Subject: Remove the "exists" overrides from Program. (Fix bug #4360) --- CHANGES | 2 ++ theories/Program/Syntax.v | 7 ------- 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/CHANGES b/CHANGES index 16d86c8ff1..cf2bb49271 100644 --- a/CHANGES +++ b/CHANGES @@ -28,6 +28,8 @@ Tactics "intros" automatically complete the introduction of its subcomponents, as the the disjunctive-conjunctive introduction patterns in non-terminal position already do. +- Importing Program no longer overrides the "exists" tactic (potential source + of incompatibilities). API diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 67e9a20cc1..892305b499 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -32,10 +32,3 @@ Require List. Export List.ListNotations. Require Import Bvector. - -(** Treating n-ary exists *) - -Tactic Notation "exists" constr(x) := exists x. -Tactic Notation "exists" constr(x) constr(y) := exists x ; exists y. -Tactic Notation "exists" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. -Tactic Notation "exists" constr(x) constr(y) constr(z) constr(w) := exists x ; exists y ; exists z ; exists w. -- cgit v1.2.3 From ce83c2b9fd1685e46049ee7f47c8716dcf66dbd1 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 6 Oct 2015 14:11:19 +0200 Subject: Goptions: new value type: optional string These options can be set to a string value, but also unset. Internal data is of type string option. --- ide/ide_slave.ml | 4 ++++ ide/interface.mli | 1 + ide/xmlprotocol.ml | 4 ++++ intf/vernacexpr.mli | 1 + library/goptions.ml | 9 +++++++++ library/goptions.mli | 2 ++ printing/ppvernac.ml | 2 ++ toplevel/vernacentries.ml | 2 ++ 8 files changed, 25 insertions(+) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 94f9c9a361..041f2f83b8 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -291,11 +291,13 @@ let export_option_value = function | Goptions.BoolValue b -> Interface.BoolValue b | Goptions.IntValue x -> Interface.IntValue x | Goptions.StringValue s -> Interface.StringValue s + | Goptions.StringOptValue s -> Interface.StringOptValue s let import_option_value = function | Interface.BoolValue b -> Goptions.BoolValue b | Interface.IntValue x -> Goptions.IntValue x | Interface.StringValue s -> Goptions.StringValue s + | Interface.StringOptValue s -> Goptions.StringOptValue s let export_option_state s = { Interface.opt_sync = s.Goptions.opt_sync; @@ -314,6 +316,8 @@ let set_options options = | BoolValue b -> Goptions.set_bool_option_value name b | IntValue i -> Goptions.set_int_option_value name i | StringValue s -> Goptions.set_string_option_value name s + | StringOptValue (Some s) -> Goptions.set_string_option_value name s + | StringOptValue None -> Goptions.unset_option_value_gen None name in List.iter iter options diff --git a/ide/interface.mli b/ide/interface.mli index 464e851f6d..767c49d2bd 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -61,6 +61,7 @@ type option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option (** Summary of an option status *) type option_state = { diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index d337a911d8..84fd8929bd 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -62,10 +62,12 @@ let of_option_value = function | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i] | BoolValue b -> constructor "option_value" "boolvalue" [of_bool b] | StringValue s -> constructor "option_value" "stringvalue" [of_string s] + | StringOptValue s -> constructor "option_value" "stringoptvalue" [of_option of_string s] let to_option_value = do_match "option_value" (fun s args -> match s with | "intvalue" -> IntValue (to_option to_int (singleton args)) | "boolvalue" -> BoolValue (to_bool (singleton args)) | "stringvalue" -> StringValue (to_string (singleton args)) + | "stringoptvalue" -> StringOptValue (to_option to_string (singleton args)) | _ -> raise Marshal_error) let of_option_state s = @@ -337,6 +339,8 @@ end = struct | IntValue None -> "none" | IntValue (Some i) -> string_of_int i | StringValue s -> s + | StringOptValue None -> "none" + | StringOptValue (Some s) -> s | BoolValue b -> if b then "true" else "false" let pr_option_state (s : option_state) = Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n" diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 37218fbf91..9248fa953c 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -155,6 +155,7 @@ type option_value = Goptions.option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option type option_ref_value = | StringRefValue of string diff --git a/library/goptions.ml b/library/goptions.ml index 4f50fbfbdd..30d195f83c 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -20,6 +20,7 @@ type option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option (** Summary of an option status *) type option_state = { @@ -293,6 +294,10 @@ let declare_string_option = declare_option (fun v -> StringValue v) (function StringValue v -> v | _ -> anomaly (Pp.str "async_option")) +let declare_stringopt_option = + declare_option + (fun v -> StringOptValue v) + (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option")) (* 3- User accessible commands *) @@ -324,11 +329,13 @@ let check_bool_value v = function let check_string_value v = function | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) | _ -> bad_type_error () let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None + | StringOptValue _ -> StringOptValue None | _ -> bad_type_error () (* Nota: For compatibility reasons, some errors are treated as @@ -359,6 +366,8 @@ let msg_option_value (name,v) = | IntValue (Some n) -> int n | IntValue None -> str "undefined" | StringValue s -> str s + | StringOptValue None -> str"undefined" + | StringOptValue (Some s) -> str s (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = diff --git a/library/goptions.mli b/library/goptions.mli index 1c44f89081..9d87c14c50 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -128,6 +128,7 @@ type 'a write_function = 'a -> unit val declare_int_option : int option option_sig -> int option write_function val declare_bool_option : bool option_sig -> bool write_function val declare_string_option: string option_sig -> string write_function +val declare_stringopt_option: string option option_sig -> string option write_function (** {6 Special functions supposed to be used only in vernacentries.ml } *) @@ -165,6 +166,7 @@ type option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option (** Summary of an option status *) type option_state = { diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 71dcd15cc7..76f97fce1e 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -166,6 +166,8 @@ module Make (* This should not happen because of the grammar *) | IntValue (Some n) -> spc() ++ int n | StringValue s -> spc() ++ str s + | StringOptValue None -> mt() + | StringOptValue (Some s) -> spc() ++ str s | BoolValue b -> mt() in pr_printoption a None ++ pr_opt_value b diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index c07c756c01..5147d81bce 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1497,6 +1497,8 @@ let vernac_set_opacity locality (v,l) = let vernac_set_option locality key = function | StringValue s -> set_string_option_value_gen locality key s + | StringOptValue (Some s) -> set_string_option_value_gen locality key s + | StringOptValue None -> unset_option_value_gen locality key | IntValue n -> set_int_option_value_gen locality key n | BoolValue b -> set_bool_option_value_gen locality key b -- cgit v1.2.3 From 0de499ab4702708ddfae162389617869b170c7d7 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 28 Sep 2015 16:33:46 +0200 Subject: STM: fix backtrace handling --- stm/stm.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/stm/stm.ml b/stm/stm.ml index 4a303f036e..ed7c234c1e 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1577,7 +1577,8 @@ end = struct (* {{{ *) vernac_interp r_for { r_what with verbose = true }; feedback ~state_id:r_for Feedback.Processed with e when Errors.noncritical e -> - let msg = string_of_ppcmds (print e) in + let e = Errors.push e in + let msg = string_of_ppcmds (iprint e) in feedback ~state_id:r_for (Feedback.ErrorMsg (Loc.ghost, msg)) let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) -- cgit v1.2.3 From 173f07a8386bf4d3d45b49d3dc01ab047b3ad4f9 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 28 Sep 2015 16:50:25 +0200 Subject: Future: make not-here/not-ready messages customizable --- lib/future.ml | 20 +++++++++++++------- lib/future.mli | 3 +++ 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/lib/future.ml b/lib/future.ml index 02d3702d77..78a158264b 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -11,21 +11,27 @@ let freeze = ref (fun () -> assert false : unit -> Dyn.t) let unfreeze = ref (fun _ -> () : Dyn.t -> unit) let set_freeze f g = freeze := f; unfreeze := g -exception NotReady of string -exception NotHere of string -let _ = Errors.register_handler (function - | NotReady name -> +let not_ready_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not ready yet. "^ "Please wait or pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ "asynchronous script processing and don't pass \"-quick\" to "^ - "coqc.") - | NotHere name -> + "coqc.")) +let not_here_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not available "^ "in this process. If you really need this, pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ "asynchronous script processing and don't pass \"-quick\" to "^ - "coqc.") + "coqc.")) + +let customize_not_ready_msg f = not_ready_msg := f +let customize_not_here_msg f = not_here_msg := f + +exception NotReady of string +exception NotHere of string +let _ = Errors.register_handler (function + | NotReady name -> !not_ready_msg name + | NotHere name -> !not_here_msg name | _ -> raise Errors.Unhandled) type fix_exn = Exninfo.iexn -> Exninfo.iexn diff --git a/lib/future.mli b/lib/future.mli index 324d5f7d10..de2282ae92 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -161,3 +161,6 @@ val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds Thy are set for the outermos layer of the system, since they have to deal with the whole system state. *) val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit + +val customize_not_ready_msg : (string -> Pp.std_ppcmds) -> unit +val customize_not_here_msg : (string -> Pp.std_ppcmds) -> unit -- cgit v1.2.3 From f7e9e6428842dd80549a0dcd20bf872c2dd7fa8c Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 30 Sep 2015 22:18:56 +0200 Subject: STM: for PIDE based UIs, edit_at requires no Reach.known_state --- stm/stm.ml | 3 ++- stm/stm.mli | 10 ++++++---- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index ed7c234c1e..d25466e089 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2342,7 +2342,8 @@ let edit_at id = VCS.delete_cluster_of id; VCS.gc (); VCS.print (); - Reach.known_state ~cache:(interactive ()) id; + if not !Flags.async_proofs_full then + Reach.known_state ~cache:(interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in try diff --git a/stm/stm.mli b/stm/stm.mli index 1d926e998e..4bad7f0a6d 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -35,7 +35,9 @@ val query : new document tip, the document between [id] and [fo.stop] has been dropped. The portion between [fo.stop] and [fo.tip] has been kept. [fo.start] is just to tell the gui where the editing zone starts, in case it wants to - graphically denote it. All subsequent [add] happen on top of [id]. *) + graphically denote it. All subsequent [add] happen on top of [id]. + If Flags.async_proofs_full is set, then [id] is not [observe]d, else it is. +*) type focus = { start : Stateid.t; stop : Stateid.t; tip : Stateid.t } val edit_at : Stateid.t -> [ `NewTip | `Focus of focus ] @@ -49,11 +51,11 @@ val stop_worker : string -> unit (* Joins the entire document. Implies finish, but also checks proofs *) val join : unit -> unit -(* Saves on the dist a .vio corresponding to the current status: - - if the worker prool is empty, all tasks are saved +(* Saves on the disk a .vio corresponding to the current status: + - if the worker pool is empty, all tasks are saved - if the worker proof is not empty, then it waits until all workers are done with their current jobs and then dumps (or fails if one - of the completed tasks is a failuere) *) + of the completed tasks is a failure) *) val snapshot_vio : DirPath.t -> string -> unit (* Empties the task queue, can be used only if the worker pool is empty (E.g. -- cgit v1.2.3 From 188ab7f76459ab46e0ea139da8b4331d958c7102 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 5 Oct 2015 18:39:06 +0200 Subject: Spawn: use each socket exclusively for writing or reading According to http://caml.inria.fr/mantis/view.php?id=5325 you can't use the same socket for both writing and reading. The result is lockups (may be fixed in 4.03). --- lib/spawn.ml | 44 ++++++++++++++++++++++++++++---------------- stm/spawned.ml | 19 ++++++++++--------- stm/spawned.mli | 2 +- toplevel/coqtop.ml | 3 ++- 4 files changed, 41 insertions(+), 27 deletions(-) diff --git a/lib/spawn.ml b/lib/spawn.ml index 9b63be70aa..851c6a2235 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -45,26 +45,38 @@ end (* Common code *) let assert_ b s = if not b then Errors.anomaly (Pp.str s) +(* According to http://caml.inria.fr/mantis/view.php?id=5325 + * you can't use the same socket for both writing and reading (may change + * in 4.03 *) let mk_socket_channel () = let open Unix in - let s = socket PF_INET SOCK_STREAM 0 in - bind s (ADDR_INET (inet_addr_loopback,0)); - listen s 1; - match getsockname s with - | ADDR_INET(host, port) -> - s, string_of_inet_addr host ^":"^ string_of_int port + let sr = socket PF_INET SOCK_STREAM 0 in + bind sr (ADDR_INET (inet_addr_loopback,0)); listen sr 1; + let sw = socket PF_INET SOCK_STREAM 0 in + bind sw (ADDR_INET (inet_addr_loopback,0)); listen sw 1; + match getsockname sr, getsockname sw with + | ADDR_INET(host, portr), ADDR_INET(_, portw) -> + (sr, sw), + string_of_inet_addr host + ^":"^ string_of_int portr ^":"^ string_of_int portw | _ -> assert false -let accept s = - let r, _, _ = Unix.select [s] [] [] accept_timeout in +let accept (sr,sw) = + let r, _, _ = Unix.select [sr] [] [] accept_timeout in if r = [] then raise (Failure (Printf.sprintf "The spawned process did not connect back in %2.1fs" accept_timeout)); - let cs, _ = Unix.accept s in - Unix.close s; - let cin, cout = Unix.in_channel_of_descr cs, Unix.out_channel_of_descr cs in + let csr, _ = Unix.accept sr in + Unix.close sr; + let cin = Unix.in_channel_of_descr csr in set_binary_mode_in cin true; + let w, _, _ = Unix.select [sw] [] [] accept_timeout in + if w = [] then raise (Failure (Printf.sprintf + "The spawned process did not connect back in %2.1fs" accept_timeout)); + let csw, _ = Unix.accept sw in + Unix.close sw; + let cout = Unix.out_channel_of_descr csw in set_binary_mode_out cout true; - cs, cin, cout + (csr, csw), cin, cout let handshake cin cout = try @@ -116,7 +128,7 @@ let spawn_pipe env prog args = let cout = Unix.out_channel_of_descr master2worker_w in set_binary_mode_in cin true; set_binary_mode_out cout true; - pid, cin, cout, worker2master_r + pid, cin, cout, (worker2master_r, master2worker_w) let filter_args args = let rec aux = function @@ -180,10 +192,10 @@ let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) = let pid, oob_resp, oob_req, cin, cout, main, is_sock = spawn_with_control prefer_sock env prog args in - Unix.set_nonblock main; + Unix.set_nonblock (fst main); let gchan = - if is_sock then ML.async_chan_of_socket main - else ML.async_chan_of_file main in + if is_sock then ML.async_chan_of_socket (fst main) + else ML.async_chan_of_file (fst main) in let alive, watch = true, None in let p = { cin; cout; gchan; pid; oob_resp; oob_req; alive; watch } in p.watch <- Some ( diff --git a/stm/spawned.ml b/stm/spawned.ml index a8372195d4..66fe07dbc4 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -11,7 +11,7 @@ open Spawn let pr_err s = Printf.eprintf "(Spawned,%d) %s\n%!" (Unix.getpid ()) s let prerr_endline s = if !Flags.debug then begin pr_err s end else () -type chandescr = AnonPipe | Socket of string * int +type chandescr = AnonPipe | Socket of string * int * int let handshake cin cout = try @@ -26,18 +26,19 @@ let handshake cin cout = | End_of_file -> pr_err "Handshake failed: End_of_file"; raise (Failure "handshake") -let open_bin_connection h p = +let open_bin_connection h pr pw = let open Unix in - let cin, cout = open_connection (ADDR_INET (inet_addr_of_string h,p)) in + let _, cout = open_connection (ADDR_INET (inet_addr_of_string h,pr)) in + let cin, _ = open_connection (ADDR_INET (inet_addr_of_string h,pw)) in set_binary_mode_in cin true; set_binary_mode_out cout true; let cin = CThread.prepare_in_channel_for_thread_friendly_io cin in cin, cout -let controller h p = +let controller h pr pw = prerr_endline "starting controller thread"; let main () = - let ic, oc = open_bin_connection h p in + let ic, oc = open_bin_connection h pr pw in let rec loop () = try match CThread.thread_friendly_input_value ic with @@ -61,8 +62,8 @@ let init_channels () = if !channels <> None then Errors.anomaly(Pp.str "init_channels called twice"); let () = match !main_channel with | None -> () - | Some (Socket(mh,mp)) -> - channels := Some (open_bin_connection mh mp); + | Some (Socket(mh,mpr,mpw)) -> + channels := Some (open_bin_connection mh mpr mpw); | Some AnonPipe -> let stdin = Unix.in_channel_of_descr (Unix.dup Unix.stdin) in let stdout = Unix.out_channel_of_descr (Unix.dup Unix.stdout) in @@ -74,8 +75,8 @@ let init_channels () = in match !control_channel with | None -> () - | Some (Socket (ch, cp)) -> - controller ch cp + | Some (Socket (ch, cpr, cpw)) -> + controller ch cpr cpw | Some AnonPipe -> Errors.anomaly (Pp.str "control channel cannot be a pipe") diff --git a/stm/spawned.mli b/stm/spawned.mli index d9e7baff3b..d0183e081d 100644 --- a/stm/spawned.mli +++ b/stm/spawned.mli @@ -8,7 +8,7 @@ (* To link this file, threads are needed *) -type chandescr = AnonPipe | Socket of string * int +type chandescr = AnonPipe | Socket of string * int * int (* Argument parsing should set these *) val main_channel : chandescr option ref diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 7562c29f70..9b5a09de0e 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -359,7 +359,8 @@ let get_int opt n = let get_host_port opt s = match CString.split ':' s with - | [host; port] -> Some (Spawned.Socket(host, int_of_string port)) + | [host; portr; portw] -> + Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) | ["stdfds"] -> Some Spawned.AnonPipe | _ -> prerr_endline ("Error: host:port or stdfds expected after option "^opt); -- cgit v1.2.3 From 27bad55f6f87af2ae3ad7921d71c02e333a853bb Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 5 Oct 2015 19:02:05 +0200 Subject: CThread: blocking read + threads now works --- lib/cThread.ml | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/lib/cThread.ml b/lib/cThread.ml index 2d1f10bf39..9cbdf5a9ea 100644 --- a/lib/cThread.ml +++ b/lib/cThread.ml @@ -8,22 +8,12 @@ type thread_ic = in_channel -let prepare_in_channel_for_thread_friendly_io ic = - Unix.set_nonblock (Unix.descr_of_in_channel ic); ic - -let safe_wait_timed_read fd time = - try Thread.wait_timed_read fd time - with Unix.Unix_error (Unix.EINTR, _, _) -> - (** On Unix, the above function may raise this exception when it is - interrupted by a signal. (It uses Unix.select internally.) *) - false +let prepare_in_channel_for_thread_friendly_io ic = ic let thread_friendly_read_fd fd s ~off ~len = let rec loop () = try Unix.read fd s off len - with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN|Unix.EINTR),_,_) -> - while not (safe_wait_timed_read fd 0.05) do Thread.yield () done; - loop () + with Unix.Unix_error(Unix.EINTR,_,_) -> loop () in loop () -- cgit v1.2.3 From 0f706b470c83a957b600496c2bca652c2cfe65e3 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 7 Oct 2015 13:36:03 +0200 Subject: term_typing: strengthen discharging code Given the way Lib.extract_hyps is coded if the const_hyps field of a constant declaration contains a named_context that does not have the same order of the one in Environment.env, discharging is broken (as in some section variables are not discharged). If const_hyps is computed by the kernel, then the order is correct by construction. If such list is provided by the user, the order is not granted. We now systematically sort the list of user provided section hyps. The code of Proof using is building the named_context in the right order, but the API was not enforcing/checking it. Now it does. --- kernel/term_typing.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 926b387942..8eb920fb78 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -204,6 +204,10 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) str " " ++ str (String.conjugate_verb_to_be n) ++ str " used but not declared:" ++ fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in + let sort evn l = + List.filter (fun (id,_,_) -> + List.exists (fun (id',_,_) -> Names.Id.equal id id') l) + (named_context env) in (* We try to postpone the computation of used section variables *) let hyps, def = let context_ids = List.map pi1 (named_context env) in @@ -233,7 +237,7 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) [], def (* Empty section context: no need to check *) | Some declared -> (* We use the declared set and chain a check of correctness *) - declared, + sort env declared, match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> -- cgit v1.2.3 From 9ea8867a0fa8f2a52df102732fdc1a931c659826 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 30 Sep 2015 22:12:25 +0200 Subject: Proof using: let-in policy, optional auto-clear, forward closure* - "Proof using p*" means: use p and any section var about p. - Simplify the grammar/parser for proof using . - Section variables with a body (let-in) are pulled in automatically since they are safe to be used (add no extra quantification) - automatic clear of "unused" section variables made optional: Set Proof Using Clear Unused. since clearing section hypotheses does not "always work" (e.g. hint databases are not really cleaned) - term_typing: trigger a "suggest proof using" message also for Let theorems. --- doc/refman/RefMan-pro.tex | 30 +++++-- intf/vernacexpr.mli | 10 +-- kernel/term_typing.ml | 35 ++++++-- kernel/term_typing.mli | 2 +- parsing/g_proofs.ml4 | 8 +- parsing/g_vernac.ml4 | 50 ++++++++---- proofs/pfedit.mli | 3 +- proofs/proof_global.ml | 28 ++++++- proofs/proof_global.mli | 6 +- proofs/proof_using.ml | 172 +++++++++++++++++++-------------------- proofs/proof_using.mli | 15 +--- stm/stm.ml | 13 ++- test-suite/success/proof_using.v | 76 +++++++++++++++++ toplevel/vernacentries.ml | 13 +-- 14 files changed, 301 insertions(+), 160 deletions(-) diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 7af87a399a..5dbf315535 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -157,6 +157,14 @@ in Section~\ref{ProofWith}. Use only section variables occurring in the statement. +\variant {\tt Proof using Type*.} + + The {\tt *} operator computes the forward transitive closure. + E.g. if the variable {\tt H} has type {\tt p < 5} then {\tt H} is + in {\tt p*} since {\tt p} occurs in the type of {\tt H}. + {\tt Type* } is the forward transitive closure of the entire set of + section variables occurring in the statement. + \variant {\tt Proof using -(} {\ident$_1$} {\ldots} {\ident$_n$} {\tt ).} Use all section variables except {\ident$_1$} {\ldots} {\ident$_n$}. @@ -164,14 +172,18 @@ in Section~\ref{ProofWith}. \variant {\tt Proof using } {\emph collection$_1$} {\tt + } {\emph collection$_2$} {\tt .} \variant {\tt Proof using } {\emph collection$_1$} {\tt - } {\emph collection$_2$} {\tt .} \variant {\tt Proof using } {\emph collection$_1$} {\tt - (} {\ident$_1$} {\ldots} {\ident$_n$} {\tt ).} +\variant {\tt Proof using } {\emph collection$_1$}{\tt* .} - Use section variables being in the set union or set difference of the two - colelctions. See Section~\ref{Collection} to know how to form a named + Use section variables being, respectively, in the set union, set difference, + set complement, set forward transitive closure. + See Section~\ref{Collection} to know how to form a named collection. + The {\tt *} operator binds stronger than {\tt +} and {\tt -}. \subsubsection{{\tt Proof using} options} -\comindex{Default Proof Using} -\comindex{Suggest Proof Using} +\optindex{Default Proof Using} +\optindex{Suggest Proof Using} +\optindex{Proof Using Clear Unused} The following options modify the behavior of {\tt Proof using}. @@ -186,11 +198,17 @@ The following options modify the behavior of {\tt Proof using}. When {\tt Qed} is performed, suggest a {\tt using} annotation if the user did not provide one. +\variant{\tt Unset Proof Using Clear Unused.} + + When {\tt Proof using a} all section variables but for {\tt a} and + the variables used in the type of {\tt a} are cleared. + This option can be used to turn off this behavior. + \subsubsection[\tt Collection]{Name a set of section hypotheses for {\tt Proof using}} \comindex{Collection}\label{Collection} The command {\tt Collection} can be used to name a set of section hypotheses, -with the purpose of making {\tt Proof using} annotations more compat. +with the purpose of making {\tt Proof using} annotations more compact. \variant {\tt Collection Some := x y z.} @@ -209,7 +227,7 @@ with the purpose of making {\tt Proof using} annotations more compat. \variant {\tt Collection Many := Fewer - (x y).} Define the collection named "Many" containing the set difference - of "Fewer" and the unamed collection {\tt x y}. + of "Fewer" and the unnamed collection {\tt x y}. \subsection[\tt Abort.]{\tt Abort.\comindex{Abort}} diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 9248fa953c..fd6e1c6ae1 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -225,12 +225,12 @@ type scheme = | EqualityScheme of reference or_by_notation type section_subset_expr = - | SsSet of lident list + | SsEmpty + | SsSingl of lident | SsCompl of section_subset_expr | SsUnion of section_subset_expr * section_subset_expr | SsSubstr of section_subset_expr * section_subset_expr - -type section_subset_descr = SsAll | SsType | SsExpr of section_subset_expr + | SsFwdClose of section_subset_expr (** Extension identifiers for the VERNAC EXTEND mechanism. *) type extend_name = @@ -336,7 +336,7 @@ type vernac_expr = class_rawexpr * class_rawexpr | VernacIdentityCoercion of obsolete_locality * lident * class_rawexpr * class_rawexpr - | VernacNameSectionHypSet of lident * section_subset_descr + | VernacNameSectionHypSet of lident * section_subset_expr (* Type classes *) | VernacInstance of @@ -441,7 +441,7 @@ type vernac_expr = | VernacEndSubproof | VernacShow of showable | VernacCheckGuard - | VernacProof of raw_tactic_expr option * section_subset_descr option + | VernacProof of raw_tactic_expr option * section_subset_expr option | VernacProofMode of string (* Toplevel control *) | VernacToplevelControl of exn diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 8eb920fb78..b6df8f454b 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -182,14 +182,17 @@ let global_vars_set_constant_type env = function (fun t c -> Id.Set.union (global_vars_set env t) c)) ctx ~init:Id.Set.empty -let record_aux env s1 s2 = +let record_aux env s_ty s_bo suggested_expr = + let in_ty = keep_hyps env s_ty in let v = String.concat " " - (List.map (fun (id, _,_) -> Id.to_string id) - (keep_hyps env (Id.Set.union s1 s2))) in - Aux_file.record_in_aux "context_used" v + (CList.map_filter (fun (id, _,_) -> + if List.exists (fun (id',_,_) -> Id.equal id id') in_ty then None + else Some (Id.to_string id)) + (keep_hyps env s_bo)) in + Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) -let suggest_proof_using = ref (fun _ _ _ _ _ -> ()) +let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = @@ -225,15 +228,17 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) (Opaqueproof.force_proof (opaque_tables env) lc) in (* we force so that cst are added to the env immediately after *) ignore(Opaqueproof.force_constraints (opaque_tables env) lc); - !suggest_proof_using kn env vars ids_typ context_ids; + let expr = + !suggest_proof_using (Constant.to_string kn) + env vars ids_typ context_ids in if !Flags.compilation_mode = Flags.BuildVo then - record_aux env ids_typ vars; + record_aux env ids_typ vars expr; vars in keep_hyps env (Idset.union ids_typ ids_def), def | None -> if !Flags.compilation_mode = Flags.BuildVo then - record_aux env Id.Set.empty Id.Set.empty; + record_aux env Id.Set.empty Id.Set.empty ""; [], def (* Empty section context: no need to check *) | Some declared -> (* We use the declared set and chain a check of correctness *) @@ -307,6 +312,20 @@ let translate_local_def env id centry = let def,typ,proj,poly,univs,inline_code,ctx = infer_declaration env None (DefinitionEntry centry) in let typ = type_of_constant_type env typ in + if ctx = None && !Flags.compilation_mode = Flags.BuildVo then begin + match def with + | Undef _ -> () + | Def _ -> () + | OpaqueDef lc -> + let context_ids = List.map pi1 (named_context env) in + let ids_typ = global_vars_set env typ in + let ids_def = global_vars_set env + (Opaqueproof.force_proof (opaque_tables env) lc) in + let expr = + !suggest_proof_using (Id.to_string id) + env ids_def ids_typ context_ids in + record_aux env ids_typ ids_def expr + end; def, typ, univs (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 1b54b1ea1e..8d92bcc68f 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -44,4 +44,4 @@ val build_constant_declaration : constant -> env -> Cooking.result -> constant_body val set_suggest_proof_using : - (constant -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> unit) -> unit + (string -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> string) -> unit diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 1e254c16ba..7f5459bfa6 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -37,12 +37,12 @@ GEXTEND Gram command: [ [ IDENT "Goal"; c = lconstr -> VernacGoal c | IDENT "Proof" -> - VernacProof (None,hint_proof_using G_vernac.section_subset_descr None) + VernacProof (None,hint_proof_using G_vernac.section_subset_expr None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Proof"; "with"; ta = tactic; - l = OPT [ "using"; l = G_vernac.section_subset_descr -> l ] -> - VernacProof (Some ta,hint_proof_using G_vernac.section_subset_descr l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_descr; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + VernacProof (Some ta,hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; ta = OPT [ "with"; ta = tactic -> ta ] -> VernacProof (ta,Some l) | IDENT "Proof"; c = lconstr -> VernacExactProof c diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index e9915fceb3..fc0a4c8c31 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -46,7 +46,7 @@ let record_field = Gram.entry_create "vernac:record_field" let of_type_with_opt_coercion = Gram.entry_create "vernac:of_type_with_opt_coercion" let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" -let section_subset_descr = Gram.entry_create "vernac:section_subset_descr" +let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" let command_entry = ref noedit_mode let set_command_entry e = command_entry := e @@ -447,20 +447,24 @@ GEXTEND Gram ; END -let only_identrefs = - Gram.Entry.of_parser "test_only_identrefs" +let only_starredidentrefs = + Gram.Entry.of_parser "test_only_starredidentrefs" (fun strm -> let rec aux n = match get_tok (Util.stream_nth n strm) with | KEYWORD "." -> () | KEYWORD ")" -> () - | IDENT _ -> aux (n+1) + | (IDENT _ | KEYWORD "Type" | KEYWORD "*") -> aux (n+1) | _ -> raise Stream.Failure in aux 0) +let starredidentreflist_to_expr l = + match l with + | [] -> SsEmpty + | x :: xs -> List.fold_right (fun i acc -> SsUnion(i,acc)) xs x (* Modules and Sections *) GEXTEND Gram - GLOBAL: gallina_ext module_expr module_type section_subset_descr; + GLOBAL: gallina_ext module_expr module_type section_subset_expr; gallina_ext: [ [ (* Interactive module declaration *) @@ -483,7 +487,7 @@ GEXTEND Gram | IDENT "End"; id = identref -> VernacEndSegment id (* Naming a set of section hyps *) - | IDENT "Collection"; id = identref; ":="; expr = section_subset_descr -> + | IDENT "Collection"; id = identref; ":="; expr = section_subset_expr -> VernacNameSectionHypSet (id, expr) (* Requiring an already compiled module *) @@ -574,22 +578,32 @@ GEXTEND Gram CMwith (!@loc,mty,decl) ] ] ; - section_subset_descr: - [ [ IDENT "All" -> SsAll - | "Type" -> SsType - | only_identrefs; l = LIST0 identref -> SsExpr (SsSet l) - | e = section_subset_expr -> SsExpr e ] ] - ; + (* Proof using *) section_subset_expr: + [ [ only_starredidentrefs; l = LIST0 starredidentref -> + starredidentreflist_to_expr l + | e = ssexpr -> e ]] + ; + starredidentref: + [ [ i = identref -> SsSingl i + | i = identref; "*" -> SsFwdClose(SsSingl i) + | "Type" -> SsSingl (!@loc, Id.of_string "Type") + | "Type"; "*" -> SsFwdClose (SsSingl (!@loc, Id.of_string "Type")) ]] + ; + ssexpr: [ "35" - [ "-"; e = section_subset_expr -> SsCompl e ] + [ "-"; e = ssexpr -> SsCompl e ] | "50" - [ e1 = section_subset_expr; "-"; e2 = section_subset_expr->SsSubstr(e1,e2) - | e1 = section_subset_expr; "+"; e2 = section_subset_expr->SsUnion(e1,e2)] + [ e1 = ssexpr; "-"; e2 = ssexpr->SsSubstr(e1,e2) + | e1 = ssexpr; "+"; e2 = ssexpr->SsUnion(e1,e2)] | "0" - [ i = identref -> SsSet [i] - | "("; only_identrefs; l = LIST0 identref; ")"-> SsSet l - | "("; e = section_subset_expr; ")"-> e ] ] + [ i = starredidentref -> i + | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"-> + starredidentreflist_to_expr l + | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"; "*" -> + SsFwdClose(starredidentreflist_to_expr l) + | "("; e = ssexpr; ")"-> e + | "("; e = ssexpr; ")"; "*" -> SsFwdClose e ] ] ; END diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 4aa3c3bfd2..b1fba132d9 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -117,7 +117,8 @@ val set_end_tac : Tacexpr.raw_tactic_expr -> unit (** {6 ... } *) (** [set_used_variables l] declares that section variables [l] will be used in the proof *) -val set_used_variables : Id.t list -> Context.section_context +val set_used_variables : + Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option (** {6 ... } *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 254aa8f783..f777e6ed7a 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -250,17 +250,43 @@ let start_dependent_proof id str goals terminator = let get_used_variables () = (cur_pstate ()).section_vars +let proof_using_auto_clear = ref true +let _ = Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Proof using Clear Unused"; + Goptions.optkey = ["Proof";"Using";"Clear";"Unused"]; + Goptions.optread = (fun () -> !proof_using_auto_clear); + Goptions.optwrite = (fun b -> proof_using_auto_clear := b) } + let set_used_variables l = let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in + let ctx_set = + List.fold_right Id.Set.add (List.map pi1 ctx) Id.Set.empty in + let vars_of = Environ.global_vars_set in + let aux env entry (ctx, all_safe, to_clear as orig) = + match entry with + | (x,None,_) -> + if Id.Set.mem x all_safe then orig + else (ctx, all_safe, (Loc.ghost,x)::to_clear) + | (x,Some bo, ty) as decl -> + if Id.Set.mem x all_safe then orig else + let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in + if Id.Set.subset vars all_safe + then (decl :: ctx, Id.Set.add x all_safe, to_clear) + else (ctx, all_safe, (Loc.ghost,x) :: to_clear) in + let ctx, _, to_clear = + Environ.fold_named_context aux env ~init:(ctx,ctx_set,[]) in + let to_clear = if !proof_using_auto_clear then to_clear else [] in match !pstates with | [] -> raise NoCurrentProof | p :: rest -> if not (Option.is_empty p.section_vars) then Errors.error "Used section variables can be declared only once"; pstates := { p with section_vars = Some ctx} :: rest; - ctx + ctx, to_clear let get_open_goals () = let gl, gll, shelf , _ , _ = Proof.proof (cur_pstate ()).proof in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index b5dd5ef85f..028116049c 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -129,8 +129,10 @@ val set_interp_tac : -> unit (** Sets the section variables assumed by the proof, returns its closure - * (w.r.t. type dependencies *) -val set_used_variables : Names.Id.t list -> Context.section_context + * (w.r.t. type dependencies and let-ins covered by it) + a list of + * ids to be cleared *) +val set_used_variables : + Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option (**********************************************************) diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index f66e965712..7eed1cb317 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -11,20 +11,15 @@ open Environ open Util open Vernacexpr -let to_string = function - | SsAll -> "All" - | SsType -> "Type" - | SsExpr(SsSet l)-> String.concat " " (List.map Id.to_string (List.map snd l)) - | SsExpr e -> - let rec aux = function - | SsSet [] -> "( )" - | SsSet [_,x] -> Id.to_string x - | SsSet l -> - "(" ^ String.concat " " (List.map Id.to_string (List.map snd l)) ^ ")" - | SsCompl e -> "-" ^ aux e^"" - | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" - | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" - in aux e +let to_string e = + let rec aux = function + | SsEmpty -> "()" + | SsSingl (_,id) -> "("^Id.to_string id^")" + | SsCompl e -> "-" ^ aux e^"" + | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" + | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" + | SsFwdClose e -> "("^aux e^")*" + in aux e let known_names = Summary.ref [] ~name:"proofusing-nameset" @@ -36,30 +31,48 @@ let in_nameset = discharge_function = (fun _ -> None) } +let rec close_fwd e s = + let s' = + List.fold_left (fun s (id,b,ty) -> + let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in + let vty = global_vars_set e ty in + let vbty = Id.Set.union vb vty in + if Id.Set.exists (fun v -> Id.Set.mem v s) vbty + then Id.Set.add id (Id.Set.union s vbty) else s) + s (named_context e) + in + if Id.Set.equal s s' then s else close_fwd e s' +;; + let rec process_expr env e ty = - match e with - | SsAll -> - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty - | SsExpr e -> - let rec aux = function - | SsSet l -> set_of_list env (List.map snd l) - | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) - | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) - | SsCompl e -> Id.Set.diff (full_set env) (aux e) - in - aux e - | SsType -> - List.fold_left (fun acc ty -> + let rec aux = function + | SsEmpty -> Id.Set.empty + | SsSingl (_,id) -> set_of_id env ty id + | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) + | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) + | SsCompl e -> Id.Set.diff (full_set env) (aux e) + | SsFwdClose e -> close_fwd env (aux e) + in + aux e + +and set_of_id env ty id = + if Id.to_string id = "Type" then + List.fold_left (fun acc ty -> Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty -and set_of_list env = function - | [x] when CList.mem_assoc_f Id.equal x !known_names -> - process_expr env (CList.assoc_f Id.equal x !known_names) [] - | l -> List.fold_right Id.Set.add l Id.Set.empty -and full_set env = set_of_list env (List.map pi1 (named_context env)) + else if Id.to_string id = "All" then + List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + else if CList.mem_assoc_f Id.equal id !known_names then + process_expr env (CList.assoc_f Id.equal id !known_names) [] + else Id.Set.singleton id + +and full_set env = + List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty let process_expr env e ty = - let s = Id.Set.union (process_expr env SsType ty) (process_expr env e []) in + let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in + let v_ty = process_expr env ty_expr ty in + let s = Id.Set.union v_ty (process_expr env e ty) in Id.Set.elements s let name_set id expr = Lib.add_anonymous_leaf (in_nameset (id,expr)) @@ -77,62 +90,49 @@ let minimize_hyps env ids = in aux ids -let minimize_unused_hyps env ids = - let all_ids = List.map pi1 (named_context env) in - let deps_of = - let cache = - List.map (fun id -> id,really_needed env (Id.Set.singleton id)) all_ids in - fun id -> List.assoc id cache in - let inv_dep_of = - let cache_sum cache id stuff = - try Id.Map.add id (Id.Set.add stuff (Id.Map.find id cache)) cache - with Not_found -> Id.Map.add id (Id.Set.singleton stuff) cache in - let cache = - List.fold_left (fun cache id -> - Id.Set.fold (fun d cache -> cache_sum cache d id) - (Id.Set.remove id (deps_of id)) cache) - Id.Map.empty all_ids in - fun id -> try Id.Map.find id cache with Not_found -> Id.Set.empty in - let rec aux s = - let s' = - Id.Set.fold (fun id s -> - if Id.Set.subset (inv_dep_of id) s then Id.Set.diff s (inv_dep_of id) - else s) - s s in - if Id.Set.equal s s' then s else aux s' in - aux ids - -let suggest_Proof_using kn env vars ids_typ context_ids = +let remove_ids_and_lets env s ids = + let not_ids id = not (Id.Set.mem id ids) in + let no_body id = named_body id env = None in + let deps id = really_needed env (Id.Set.singleton id) in + (Id.Set.filter (fun id -> + not_ids id && + (no_body id || + Id.Set.exists not_ids (Id.Set.filter no_body (deps id)))) s) + +let suggest_Proof_using name env vars ids_typ context_ids = let module S = Id.Set in let open Pp in - let used = S.union vars ids_typ in - let needed = minimize_hyps env used in - let all_needed = really_needed env needed in - let all = List.fold_right S.add context_ids S.empty in - let unneeded = minimize_unused_hyps env (S.diff all needed) in - let pr_set s = + let print x = prerr_endline (string_of_ppcmds x) in + let pr_set parens s = let wrap ppcmds = - if S.cardinal s > 1 || S.equal s (S.singleton (Id.of_string "All")) - then str "(" ++ ppcmds ++ str ")" + if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" else ppcmds in wrap (prlist_with_sep (fun _ -> str" ") Id.print (S.elements s)) in + let used = S.union vars ids_typ in + let needed = minimize_hyps env (remove_ids_and_lets env used ids_typ) in + let all_needed = really_needed env needed in + let all = List.fold_right S.add context_ids S.empty in + let fwd_typ = close_fwd env ids_typ in if !Flags.debug then begin - prerr_endline (string_of_ppcmds (str "All " ++ pr_set all)); - prerr_endline (string_of_ppcmds (str "Type" ++ pr_set ids_typ)); - prerr_endline (string_of_ppcmds (str "needed " ++ pr_set needed)); - prerr_endline (string_of_ppcmds (str "unneeded " ++ pr_set unneeded)); + print (str "All " ++ pr_set false all); + print (str "Type " ++ pr_set false ids_typ); + print (str "needed " ++ pr_set false needed); + print (str "all_needed " ++ pr_set false all_needed); + print (str "Type* " ++ pr_set false fwd_typ); end; + let valid_exprs = ref [] in + let valid e = valid_exprs := e :: !valid_exprs in + if S.is_empty needed then valid (str "Type"); + if S.equal all_needed fwd_typ then valid (str "Type*"); + if S.equal all all_needed then valid(str "All"); + valid (pr_set false needed); msg_info ( - str"The proof of "++ - Names.Constant.print kn ++ spc() ++ str "should start with:"++spc()++ - str"Proof using " ++ - if S.is_empty needed then str "." - else if S.subset needed ids_typ then str "Type." - else if S.equal all all_needed then str "All." - else - let s1 = string_of_ppcmds (str "-" ++ pr_set unneeded ++ str".") in - let s2 = string_of_ppcmds (pr_set needed ++ str".") in - if String.length s1 < String.length s2 then str s1 else str s2) + str"The proof of "++ str name ++ spc() ++ + str "should start with one of the following commands:"++spc()++ + v 0 ( + prlist_with_sep cut (fun x->str"Proof using " ++x++ str". ") !valid_exprs)); + string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) +;; let value = ref false @@ -146,13 +146,13 @@ let _ = Goptions.optwrite = (fun b -> value := b; if b then Term_typing.set_suggest_proof_using suggest_Proof_using - else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> ()) + else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> "") ) } -let value = ref "_unset_" +let value = ref None let _ = - Goptions.declare_string_option + Goptions.declare_stringopt_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "default value for Proof using"; @@ -161,6 +161,4 @@ let _ = Goptions.optwrite = (fun b -> value := b;) } -let get_default_proof_using () = - if !value = "_unset_" then None - else Some !value +let get_default_proof_using () = !value diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli index fb3497f106..dcf8a0fcd2 100644 --- a/proofs/proof_using.mli +++ b/proofs/proof_using.mli @@ -6,21 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(* [minimize_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true] - * and [keep_hyps e s1] is equal to [keep_hyps e s2]. Inefficient. *) -val minimize_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t - -(* [minimize_unused_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true] - * and s.t. calling [clear s1] would do the same as [clear s2]. Inefficient. *) -val minimize_unused_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t - val process_expr : - Environ.env -> Vernacexpr.section_subset_descr -> Constr.types list -> + Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list -> Names.Id.t list -val name_set : Names.Id.t -> Vernacexpr.section_subset_descr -> unit +val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit -val to_string : Vernacexpr.section_subset_descr -> string +val to_string : Vernacexpr.section_subset_expr -> string val get_default_proof_using : unit -> string option diff --git a/stm/stm.ml b/stm/stm.ml index d25466e089..acbb5f646d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -888,9 +888,16 @@ let set_compilation_hints file = hints := Aux_file.load_aux_file_for file let get_hint_ctx loc = let s = Aux_file.get !hints loc "context_used" in - let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") s) in - let ids = List.map (fun id -> Loc.ghost, id) ids in - SsExpr (SsSet ids) + match Str.split (Str.regexp ";") s with + | ids :: _ -> + let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") ids) in + let ids = List.map (fun id -> Loc.ghost, id) ids in + begin match ids with + | [] -> SsEmpty + | x :: xs -> + List.fold_left (fun a x -> SsUnion (SsSingl x,a)) (SsSingl x) xs + end + | _ -> raise Not_found let get_hint_bp_time proof_name = try float_of_string (Aux_file.get !hints Loc.ghost proof_name) diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index 61e73f8587..c83f45e2a4 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -117,5 +117,81 @@ End T1. Check (bla 7 : 2 = 8). +Section A. +Variable a : nat. +Variable b : nat. +Variable c : nat. +Variable H1 : a = 3. +Variable H2 : a = 3 -> b = 7. +Variable H3 : c = 3. + +Lemma foo : a = a. +Proof using Type*. +pose H1 as e1. +pose H2 as e2. +reflexivity. +Qed. + +Lemma bar : a = 3 -> b = 7. +Proof using b*. +exact H2. +Qed. + +Lemma baz : c=3. +Proof using c*. +exact H3. +Qed. + +Lemma baz2 : c=3. +Proof using c* a. +exact H3. +Qed. + +End A. + +Check (foo 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (bar 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (baz2 99 3 (refl_equal 3)). +Check (baz 3 (refl_equal 3)). + +Section Let. + +Variables a b : nat. +Let pa : a = a. Proof. reflexivity. Qed. +Unset Default Proof Using. +Set Suggest Proof Using. +Lemma test_let : a = a. +Proof using a. +exact pa. +Qed. + +Let ppa : pa = pa. Proof. reflexivity. Qed. + +Lemma test_let2 : pa = pa. +Proof using Type. +exact ppa. +Qed. + +End Let. + +Check (test_let 3). + +Section Clear. + +Variable a: nat. +Hypotheses H : a = 4. + +Set Proof Using Clear Unused. + +Lemma test_clear : a = a. +Proof using a. +Fail rewrite H. +trivial. +Qed. + +End Clear. + diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 5147d81bce..72c800f0f1 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -874,18 +874,7 @@ let vernac_set_used_variables e = errorlabstrm "vernac_set_used_variables" (str "Unknown variable: " ++ pr_id id)) l; - let closure_l = List.map pi1 (set_used_variables l) in - let closure_l = List.fold_right Id.Set.add closure_l Id.Set.empty in - let vars_of = Environ.global_vars_set in - let aux env entry (all_safe,rest as orig) = - match entry with - | (x,None,_) -> - if Id.Set.mem x all_safe then orig else (all_safe, (Loc.ghost,x)::rest) - | (x,Some bo, ty) -> - let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in - if Id.Set.subset vars all_safe then (Id.Set.add x all_safe, rest) - else (all_safe, (Loc.ghost,x) :: rest) in - let _,to_clear = Environ.fold_named_context aux env ~init:(closure_l,[]) in + let _, to_clear = set_used_variables l in vernac_solve SelectAll None Tacexpr.(TacAtom (Loc.ghost,TacClear(false,to_clear))) false -- cgit v1.2.3 From 4a0fd14dcae807e0e681cfc14daca978cb4a36e9 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 6 Oct 2015 16:43:50 +0200 Subject: aux_file: export API to ease writing of a Proof Using annotator. --- lib/aux_file.ml | 2 ++ lib/aux_file.mli | 4 ++++ toplevel/vernacentries.ml | 22 +++++++++++++++------- 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/lib/aux_file.ml b/lib/aux_file.ml index c9018c9ee9..5dedb0d0ac 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -42,6 +42,8 @@ module M = Map.Make(String) type data = string M.t type aux_file = data H.t +let contents x = x + let empty_aux_file = H.empty let get aux loc key = M.find key (H.find (Loc.unloc loc) aux) diff --git a/lib/aux_file.mli b/lib/aux_file.mli index e340fc6547..b672d3db28 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -13,6 +13,10 @@ val get : aux_file -> Loc.t -> string -> string val empty_aux_file : aux_file val set : aux_file -> Loc.t -> string -> string -> aux_file +module H : Map.S with type key = int * int +module M : Map.S with type key = string +val contents : aux_file -> string M.t H.t + val start_aux_file_for : string -> unit val stop_aux_file : unit -> unit val recording : unit -> bool diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 72c800f0f1..6f1ed85e07 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1846,8 +1846,9 @@ let vernac_load interp fname = (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands - * still parsed as the obsolete_locality grammar entry for retrocompatibility *) -let interp ?proof locality poly c = + * still parsed as the obsolete_locality grammar entry for retrocompatibility. + * loc is the Loc.t of the vernacular command being interpreted. *) +let interp ?proof ~loc locality poly c = prerr_endline ("interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); match c with (* Done later in this file *) @@ -1991,10 +1992,16 @@ let interp ?proof locality poly c = | VernacEndSubproof -> vernac_end_subproof () | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () - | VernacProof (None, None) -> () - | VernacProof (Some tac, None) -> vernac_set_end_tac tac - | VernacProof (None, Some l) -> vernac_set_used_variables l + | VernacProof (None, None) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:no" + | VernacProof (Some tac, None) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:no"; + vernac_set_end_tac tac + | VernacProof (None, Some l) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:yes"; + vernac_set_used_variables l | VernacProof (Some tac, Some l) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:yes"; vernac_set_end_tac tac; vernac_set_used_variables l | VernacProofMode mn -> Proof_global.set_proof_mode mn (* Toplevel control *) @@ -2146,8 +2153,9 @@ let interp ?(verbosely=true) ?proof (loc,c) = Obligations.set_program_mode isprogcmd; try vernac_timeout begin fun () -> - if verbosely then Flags.verbosely (interp ?proof locality poly) c - else Flags.silently (interp ?proof locality poly) c; + if verbosely + then Flags.verbosely (interp ?proof ~loc locality poly) c + else Flags.silently (interp ?proof ~loc locality poly) c; if orig_program_mode || not !Flags.program_mode || isprogcmd then Flags.program_mode := orig_program_mode end -- cgit v1.2.3 From 479d45e679e8486c65b77f2ddfa8718c24778a75 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 8 Oct 2015 11:00:22 +0200 Subject: f_equal fix continued: do a refresh_universes as before. --- plugins/cc/cctac.ml | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index cbd95eaeaf..068cb25cf2 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -483,24 +483,26 @@ let congruence_tac depth l = the fact that congruence is called internally. *) -let new_app_global_check f args k = - new_app_global f args - (fun c -> - Proofview.Goal.enter - begin fun gl -> - let evm, _ = Tacmach.New.pf_apply type_of gl c in - Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k c) +let mk_eq f c1 c2 k = + Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> + Proofview.Goal.enter begin + fun gl -> + let open Tacmach.New in + let evm, ty = pf_apply type_of gl c1 in + let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in + let term = mkApp (fc, [| ty; c1; c2 |]) in + let evm, _ = type_of (pf_env gl) evm term in + Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) + (k term) end) - + let f_equal = Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in - let type_of = Tacmach.New.pf_unsafe_type_of gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) - let ty = (* Termops.refresh_universes *) (type_of c1) in Tacticals.New.tclTHEN - ((new_app_global_check _eq [|ty; c1; c2|]) Tactics.cut) + (mk_eq _eq c1 c2 Tactics.cut) (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in -- cgit v1.2.3 From 33d153a01f2814c6e5486c07257667254b91fa0c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Oct 2015 15:08:27 +0200 Subject: Axioms now support the universe binding syntax. We artificially restrict the syntax though, because it is unclear of what the semantics of several axioms in a row is, in particular about the resolution of remaining evars. --- intf/vernacexpr.mli | 2 +- parsing/g_vernac.ml4 | 2 +- printing/ppvernac.ml | 12 +++++++----- stm/texmacspp.ml | 5 +++-- stm/vernac_classifier.ml | 2 +- toplevel/command.ml | 40 +++++++++++++++++++++++++++++++++++++++- toplevel/command.mli | 2 +- toplevel/vernacentries.ml | 2 +- 8 files changed, 54 insertions(+), 13 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index fd6e1c6ae1..f89f076b5f 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -314,7 +314,7 @@ type vernac_expr = | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * - inline * simple_binder with_coercion list + inline * (plident list * constr_expr) with_coercion list | VernacInductive of private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of locality option * (fixpoint_expr * decl_notation list) list diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index fc0a4c8c31..3bd190bb8a 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -420,7 +420,7 @@ GEXTEND Gram [ [ "("; a = simple_assum_coe; ")" -> a ] ] ; simple_assum_coe: - [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> + [ [ idl = LIST1 pidentref; oc = of_type_with_opt_coercion; c = lconstr -> (not (Option.is_empty oc),(idl,c)) ] ] ; diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 76f97fce1e..00c276bdbe 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -356,6 +356,7 @@ module Make | l -> prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l + (* prlist_with_sep pr_semicolon (pr_params pr_c) *) @@ -774,11 +775,12 @@ module Make return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) | VernacAssumption (stre,_,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in - return ( - hov 2 - (pr_assumption_token (n > 1) stre ++ spc() ++ - pr_ne_params_list pr_lconstr_expr l) - ) + let pr_params (c, (xl, t)) = + hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++ + (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) + in + let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in + return (hov 2 (pr_assumption_token (n > 1) stre ++ spc() ++ assumptions)) | VernacInductive (p,f,l) -> let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index fb41bb7bea..b912080413 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -575,10 +575,11 @@ let rec tmpp v loc = end | VernacExactProof _ as x -> xmlTODO loc x | VernacAssumption ((l, a), _, sbwcl) -> + let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in let many = - List.length (List.flatten (List.map fst (List.map snd sbwcl))) > 1 in + List.length (List.flatten (List.map fst binders)) > 1 in let exprs = - List.flatten (List.map pp_simple_binder (List.map snd sbwcl)) in + List.flatten (List.map pp_simple_binder binders) in let l = match l with Some x -> x | None -> Decl_kinds.Global in let kind = string_of_assumption_kind l a many in xmlAssumption kind loc exprs diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 8aa2a59177..a898c687be 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -141,7 +141,7 @@ let rec classify_vernac e = else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> - let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map snd l) l) in + let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> snd id) l) l) in VtSideff ids, VtLater | VernacDefinition (_,((_,id),_),DefineBody _) -> VtSideff [id], VtLater | VernacInductive (_,_,l) -> diff --git a/toplevel/command.ml b/toplevel/command.ml index 285baf3f97..e54a82c19b 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -251,7 +251,7 @@ let declare_assumptions idl is_coe k (c,ctx) imps impl_is_on nl = in List.rev refs, status -let do_assumptions (_, poly, _ as kind) nl l = +let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let env = Global.env () in let evdref = ref (Evd.from_env env) in let l = @@ -284,6 +284,44 @@ let do_assumptions (_, poly, _ as kind) nl l = in (subst'@subst, status' && status)) ([],true) l) +let do_assumptions_bound_univs coe kind nl id pl c = + let env = Global.env () in + let ctx = Evd.make_evar_universe_context env pl in + let evdref = ref (Evd.from_ctx ctx) in + let ty, impls = interp_type_evars_impls env evdref c in + let nf, subst = Evarutil.e_nf_evars_and_universes evdref in + let ty = nf ty in + let vars = Universes.universes_of_constr ty in + let evd = Evd.restrict_universe_context !evdref vars in + let uctx = Evd.universe_context ?names:pl evd in + let uctx = Univ.ContextSet.of_context uctx in + let (_, _, st) = declare_assumption coe kind (ty, uctx) impls false nl id in + st + +let do_assumptions kind nl l = match l with +| [coe, ([id, Some pl], c)] -> + let () = match kind with + | (Discharge, _, _) when Lib.sections_are_opened () -> + let loc = fst id in + let msg = Pp.str "Section variables cannot be polymorphic." in + user_err_loc (loc, "", msg) + | _ -> () + in + do_assumptions_bound_univs coe kind nl id (Some pl) c +| _ -> + let map (coe, (idl, c)) = + let map (id, univs) = match univs with + | None -> id + | Some _ -> + let loc = fst id in + let msg = Pp.str "Assumptions with bound universes can only be defined once at a time." in + user_err_loc (loc, "", msg) + in + (coe, (List.map map idl, c)) + in + let l = List.map map l in + do_assumptions_unbound_univs kind nl l + (* 3a| Elimination schemes for mutual inductive definitions *) (* 3b| Mutual inductive definitions *) diff --git a/toplevel/command.mli b/toplevel/command.mli index f4d43ec533..b1e1d7d060 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -57,7 +57,7 @@ val declare_assumption : coercion_flag -> assumption_kind -> global_reference * Univ.Instance.t * bool val do_assumptions : locality * polymorphic * assumption_object_kind -> - Vernacexpr.inline -> simple_binder with_coercion list -> bool + Vernacexpr.inline -> (plident list * constr_expr) with_coercion list -> bool (* val declare_assumptions : variable Loc.located list -> *) (* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 6f1ed85e07..820903c417 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -515,7 +515,7 @@ let vernac_assumption locality poly (local, kind) l nl = let kind = local, poly, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then - List.iter (fun lid -> + List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; let status = do_assumptions kind nl l in -- cgit v1.2.3 From d6ff0fcefa21bd2c6424627049b0f5e49ed4df12 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 8 Oct 2015 14:58:11 +0200 Subject: Univs: fix bug #4161. Retypecheck abstracted infered predicate to register the right universe constraints. --- pretyping/cases.ml | 32 ++++++++++++++++---------------- test-suite/bugs/closed/4161.v | 27 +++++++++++++++++++++++++++ 2 files changed, 43 insertions(+), 16 deletions(-) create mode 100644 test-suite/bugs/closed/4161.v diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 05e09b9686..2a4be9f31c 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1865,7 +1865,14 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon = (* We put the tycon inside the arity signature, possibly discovering dependencies. *) -let prepare_predicate_from_arsign_tycon loc tomatchs arsign c = +let context_of_arsign l = + let (x, _) = List.fold_right + (fun c (x, n) -> + (lift_rel_context n c @ x, List.length c + n)) + l ([], 0) + in x + +let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in let subst, len = List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> @@ -1905,7 +1912,9 @@ let prepare_predicate_from_arsign_tycon loc tomatchs arsign c = mkRel (n + nar)) | _ -> map_constr_with_binders succ predicate lift c - in predicate 0 c + in + let p = predicate 0 c in + fst (Typing.type_of (push_rel_context (context_of_arsign arsign) env) sigma p), p (* Builds the predicate. If the predicate is dependent, its context is @@ -1927,11 +1936,11 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = (* If the tycon is not closed w.r.t real variables, we try *) (* two different strategies *) (* First strategy: we abstract the tycon wrt to the dependencies *) - let pred1 = - prepare_predicate_from_arsign_tycon loc tomatchs arsign t in + let sigma1,pred1 = + prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in (* Second strategy: we build an "inversion" predicate *) let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in - [sigma, pred1; sigma2, pred2] + [sigma1, pred1; sigma2, pred2] | None, _ -> (* No dependent type constraint, or no constraints at all: *) (* we use two strategies *) @@ -2366,13 +2375,6 @@ let build_dependent_signature env evdref avoid tomatchs arsign = assert(Int.equal slift 0); (* we must have folded over all elements of the arity signature *) arsign'', allnames, nar, eqs, neqs, refls -let context_of_arsign l = - let (x, _) = List.fold_right - (fun c (x, n) -> - (lift_rel_context n c @ x, List.length c + n)) - l ([], 0) - in x - let compile_program_cases loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function @@ -2404,10 +2406,8 @@ let compile_program_cases loc style (typing_function, evdref) tycon env | Some t -> let pred = try - let pred = prepare_predicate_from_arsign_tycon loc tomatchs sign t in - (* The tycon may be ill-typed after abstraction. *) - let env' = push_rel_context (context_of_arsign sign) env in - ignore(Typing.sort_of env' evdref pred); pred + let evd, pred = prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t in + evdref := evd; pred with e when Errors.noncritical e -> let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in lift nar t diff --git a/test-suite/bugs/closed/4161.v b/test-suite/bugs/closed/4161.v new file mode 100644 index 0000000000..aa2b189b67 --- /dev/null +++ b/test-suite/bugs/closed/4161.v @@ -0,0 +1,27 @@ + + (* Inductive t : Type -> Type := *) + (* | Just : forall (A : Type), t A -> t A. *) + + (* Fixpoint test {A : Type} (x : t A) : t (A + unit) := *) + (* match x in t A return t (A + unit) with *) + (* | Just T x => @test T x *) + (* end. *) + + + Definition Type1 := Type. +Definition Type2 := Type. +Definition cast (x:Type2) := x:Type1. +Axiom f: Type2 -> Prop. +Definition A := + let T := fun A:Type1 => _ in + fun A':Type2 => + eq_refl : T A' = f A' :> Prop. +(* Type2 <= Type1... f A -> Type1 <= Type2 *) + +Inductive t : Type -> Type := + | Just : forall (A : Type), t A -> t A. + +Fixpoint test {A : Type} (x : t A) : t (A + unit) := + match x in t A with + | Just B x => @test B x + end. \ No newline at end of file -- cgit v1.2.3 From dbdef043ea143f871a3710bae36dfc45fd815835 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 8 Oct 2015 13:47:05 +0200 Subject: Allowing empty bound universe variables. --- parsing/g_vernac.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 3bd190bb8a..1f9f57f698 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -269,7 +269,7 @@ GEXTEND Gram | -> NoInline] ] ; pidentref: - [ [ i = identref; l = OPT [ "@{" ; l = LIST1 identref; "}" -> l ] -> (i,l) ] ] + [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] ; univ_constraint: [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; -- cgit v1.2.3 From b6edcae7b61ea6ccc0e65223cecb71cab0dd55cc Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 8 Oct 2015 16:00:06 +0200 Subject: Univs: fix bug #3807 Add a flag to disallow minimization to set --- kernel/univ.ml | 3 +++ kernel/univ.mli | 1 + library/universes.ml | 11 ++++++++++- library/universes.mli | 3 +++ pretyping/evd.ml | 3 +-- pretyping/pretyping.ml | 9 +++++++++ 6 files changed, 27 insertions(+), 3 deletions(-) diff --git a/kernel/univ.ml b/kernel/univ.ml index 34eb283d73..c0bd3bacd7 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1797,6 +1797,9 @@ struct let empty = (LSet.empty, Constraint.empty) let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst + let equal (univs, cst as x) (univs', cst' as y) = + x == y || (LSet.equal univs univs' && Constraint.equal cst cst') + let of_set s = (s, Constraint.empty) let singleton l = of_set (LSet.singleton l) let of_instance i = of_set (Instance.levels i) diff --git a/kernel/univ.mli b/kernel/univ.mli index 4cc8a2528f..cbaf7e546a 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -360,6 +360,7 @@ sig val of_instance : Instance.t -> t val of_set : universe_set -> t + val equal : t -> t -> bool val union : t -> t -> t val append : t -> t -> t diff --git a/library/universes.ml b/library/universes.ml index bc42cc044c..0656188eb5 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -26,6 +26,11 @@ let pr_with_global_universes l = try Nameops.pr_id (LMap.find l (snd !global_universes)) with Not_found -> Level.pr l +(* To disallow minimization to Set *) + +let set_minimization = ref true +let is_set_minimization () = !set_minimization + type universe_constraint_type = ULe | UEq | ULub type universe_constraint = universe * universe_constraint_type * universe @@ -832,7 +837,9 @@ let normalize_context_set ctx us algs = Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> if d == Le then if Univ.Level.is_small l then - (Constraint.add cstr smallles, noneqs) + if is_set_minimization () then + (Constraint.add cstr smallles, noneqs) + else (smallles, noneqs) else if Level.is_small r then if Level.is_prop r then raise (Univ.UniverseInconsistency @@ -872,6 +879,8 @@ let normalize_context_set ctx us algs = if d == Eq then (UF.union l r uf; noneqs) else (* We ignore the trivial Prop/Set <= i constraints. *) if d == Le && Univ.Level.is_small l then noneqs + else if Univ.Level.is_prop l && d == Lt && Univ.Level.is_set r + then noneqs else Constraint.add cstr noneqs) csts Constraint.empty in diff --git a/library/universes.mli b/library/universes.mli index 5527da0903..4ff21d45c9 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -12,6 +12,9 @@ open Term open Environ open Univ +val set_minimization : bool ref +val is_set_minimization : unit -> bool + (** Universes *) type universe_names = diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 412fb92b3d..3d912ca4ce 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1324,8 +1324,7 @@ let normalize_evar_universe_context uctx = Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic in - if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then - uctx + if Univ.ContextSet.equal us' uctx.uctx_local then uctx else let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in let uctx' = diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index dec23328f4..6306739b7a 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -112,6 +112,15 @@ let _ = optkey = ["Strict";"Universe";"Declaration"]; optread = is_strict_universe_declarations; optwrite = (:=) strict_universe_declarations }) + +let _ = + Goptions.(declare_bool_option + { optsync = true; + optdepr = false; + optname = "minimization to Set"; + optkey = ["Universe";"set";"Minimization"]; + optread = Universes.is_set_minimization; + optwrite = (:=) Universes.set_minimization }) (** Miscellaneous interpretation functions *) let interp_universe_level_name evd (loc,s) = -- cgit v1.2.3 From 73daf37ccc7a44cd29c9b67405111756c75cb26a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 9 Oct 2015 09:48:48 +0200 Subject: Remove misleading warning (Close #4365) --- proofs/proof_global.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index f777e6ed7a..3e06294e64 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -365,10 +365,6 @@ type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.ev let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in if allow_partial then begin - if Proof.is_complete proof then begin - msg_warning (str"The proof of " ++ str (Names.Id.to_string pid) ++ - str" is complete, no need to end it with Admitted"); - end; let proofs = Proof.partial_proof proof in let _,_,_,_, evd = Proof.proof proof in let eff = Evd.eval_side_effects evd in -- cgit v1.2.3 From b2007e86b4a28570eee52439ad8b9fee603443b8 Mon Sep 17 00:00:00 2001 From: Alec Faithfull Date: Tue, 6 Oct 2015 13:50:59 +0200 Subject: STM: Pass exception information to unreachable_state_hook functions This lets hooks treat different exceptions in different ways; in particular, user interrupts can now be safely ignored --- stm/stm.ml | 4 ++-- stm/stm.mli | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index acbb5f646d..e96c396bae 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -51,7 +51,7 @@ let execution_error, execution_error_hook = Hook.make feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) () let unreachable_state, unreachable_state_hook = Hook.make - ~default:(fun _ -> ()) () + ~default:(fun _ _ -> ()) () include Hook @@ -736,7 +736,7 @@ end = struct (* {{{ *) let good_id = !cur_id in cur_id := Stateid.dummy; VCS.reached id false; - Hooks.(call unreachable_state id); + Hooks.(call unreachable_state id (e, info)); match Stateid.get info, safe_id with | None, None -> iraise (exn_on id ~valid:good_id (e, info)) | None, Some good_id -> iraise (exn_on id ~valid:good_id (e, info)) diff --git a/stm/stm.mli b/stm/stm.mli index 4bad7f0a6d..2453f258c5 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -100,7 +100,7 @@ val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t val parse_error_hook : (Feedback.edit_or_state_id -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t -val unreachable_state_hook : (Stateid.t -> unit) Hook.t +val unreachable_state_hook : (Stateid.t -> Exninfo.iexn -> unit) Hook.t (* ready means that master has it at hand *) val state_ready_hook : (Stateid.t -> unit) Hook.t -- cgit v1.2.3 From ce0c536b4430711db1e30cd7ac35ae8d71d34e64 Mon Sep 17 00:00:00 2001 From: Alec Faithfull Date: Tue, 6 Oct 2015 13:58:50 +0200 Subject: STM: Added functions for saving and restoring the internal state PIDEtop needs these to implement its new transaction mechanism --- stm/stm.ml | 3 +++ stm/stm.mli | 4 ++++ 2 files changed, 7 insertions(+) diff --git a/stm/stm.ml b/stm/stm.ml index e96c396bae..c0d71dc933 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2405,6 +2405,9 @@ let edit_at id = VCS.print (); iraise (e, info) +let backup () = VCS.backup () +let restore d = VCS.restore d + (*********************** TTY API (PG, coqtop, coqc) ***************************) (******************************************************************************) diff --git a/stm/stm.mli b/stm/stm.mli index 2453f258c5..18ed6fc2e8 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -83,6 +83,10 @@ val set_compilation_hints : string -> unit (* Reorders the task queue putting forward what is in the perspective *) val set_perspective : Stateid.t list -> unit +type document +val backup : unit -> document +val restore : document -> unit + (** workers **************************************************************** **) module ProofTask : AsyncTaskQueue.Task -- cgit v1.2.3 From 56ca108e63191e90c3d4169c37a4c97017e3c6ae Mon Sep 17 00:00:00 2001 From: Alec Faithfull Date: Tue, 6 Oct 2015 14:19:34 +0200 Subject: TQueue: Expose the length of TQueues --- stm/tQueue.ml | 8 ++++++++ stm/tQueue.mli | 2 ++ 2 files changed, 10 insertions(+) diff --git a/stm/tQueue.ml b/stm/tQueue.ml index 6fef895ae8..2a43cd7d13 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -15,6 +15,7 @@ module PriorityQueue : sig val pop : ?picky:('a -> bool) -> 'a t -> 'a val push : 'a t -> 'a -> unit val clear : 'a t -> unit + val length : 'a t -> int end = struct type 'a item = int * 'a type 'a rel = 'a item -> 'a item -> int @@ -38,6 +39,7 @@ end = struct let set_rel rel ({ contents = (xs, _) } as t) = let rel (_,x) (_,y) = rel x y in t := (List.sort rel xs, rel) + let length ({ contents = (l, _) }) = List.length l end type 'a t = { @@ -92,6 +94,12 @@ let push { queue = q; lock = m; cond = c; release } x = Condition.broadcast c; Mutex.unlock m +let length { queue = q; lock = m } = + Mutex.lock m; + let n = PriorityQueue.length q in + Mutex.unlock m; + n + let clear { queue = q; lock = m; cond = c } = Mutex.lock m; PriorityQueue.clear q; diff --git a/stm/tQueue.mli b/stm/tQueue.mli index 7458de510f..f54af4df47 100644 --- a/stm/tQueue.mli +++ b/stm/tQueue.mli @@ -28,3 +28,5 @@ exception BeingDestroyed (* Threads blocked in pop can get this exception if the queue is being * destroyed *) val destroy : 'a t -> unit + +val length : 'a t -> int -- cgit v1.2.3 From f6b3704391de97ee544da9ae7316685cd2d9fae3 Mon Sep 17 00:00:00 2001 From: Alec Faithfull Date: Tue, 6 Oct 2015 14:20:22 +0200 Subject: TQueue: Allow some tasks to be saved when clearing a TQueue --- stm/tQueue.ml | 12 ++++++++++++ stm/tQueue.mli | 1 + 2 files changed, 13 insertions(+) diff --git a/stm/tQueue.ml b/stm/tQueue.ml index 2a43cd7d13..2dad962bec 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -105,6 +105,18 @@ let clear { queue = q; lock = m; cond = c } = PriorityQueue.clear q; Mutex.unlock m +let clear_saving { queue = q; lock = m; cond = c } f = + Mutex.lock m; + let saved = ref [] in + while not (PriorityQueue.is_empty q) do + let elem = PriorityQueue.pop q in + match f elem with + | Some x -> saved := x :: !saved + | None -> () + done; + Mutex.unlock m; + List.rev !saved + let is_empty { queue = q } = PriorityQueue.is_empty q let destroy tq = diff --git a/stm/tQueue.mli b/stm/tQueue.mli index f54af4df47..1df52d2523 100644 --- a/stm/tQueue.mli +++ b/stm/tQueue.mli @@ -22,6 +22,7 @@ val broadcast : 'a t -> unit val wait_until_n_are_waiting_then_snapshot : int -> 'a t -> 'a list val clear : 'a t -> unit +val clear_saving : 'a t -> ('a -> 'b option) -> 'b list val is_empty : 'a t -> bool exception BeingDestroyed -- cgit v1.2.3 From 41ac12062858d3b8b82b0ed736b3800d052f34b8 Mon Sep 17 00:00:00 2001 From: Alec Faithfull Date: Tue, 6 Oct 2015 15:23:02 +0200 Subject: STM: Work around an occasional crash in dot (debug output) The splines=ortho option seems to make dot crash sometimes, so this commit removes it from the STM debugging output --- stm/stm.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stm/stm.ml b/stm/stm.ml index c0d71dc933..5bb46fd368 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -372,7 +372,7 @@ end = struct (* {{{ *) (try let n = Hashtbl.find clus c in from::n with Not_found -> [from]); true in let oc = open_out fname_dot in - output_string oc "digraph states {\nsplines=ortho\n"; + output_string oc "digraph states {\n"; Dag.iter graph (fun from cf _ l -> let c1 = add_to_clus_or_ids from cf in List.iter (fun (dest, trans) -> -- cgit v1.2.3 From 864bcb82f84a8101fec9a8f7225a01083ebff8c4 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 9 Oct 2015 11:01:54 +0200 Subject: Fix inference of return clause raising a type error. --- pretyping/cases.ml | 54 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 30 insertions(+), 24 deletions(-) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 2a4be9f31c..47d92f5e03 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1865,17 +1865,10 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon = (* We put the tycon inside the arity signature, possibly discovering dependencies. *) -let context_of_arsign l = - let (x, _) = List.fold_right - (fun c (x, n) -> - (lift_rel_context n c @ x, List.length c + n)) - l ([], 0) - in x - let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in let subst, len = - List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> + List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in match kind_of_term tm with | Rel n when dependent tm c @@ -1886,19 +1879,21 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = (match tmtype with NotInd _ -> (subst, len - signlen) | IsInd (_, IndType(indf,realargs),_) -> - let subst = - if dependent tm c && List.for_all isRel realargs - then (n, 1) :: subst else subst - in + let subst, len = List.fold_left (fun (subst, len) arg -> match kind_of_term arg with | Rel n when dependent arg c -> ((n, len) :: subst, pred len) | _ -> (subst, pred len)) - (subst, len) realargs) + (subst, len) realargs + in + let subst = + if dependent tm c && List.for_all isRel realargs + then (n, len) :: subst else subst + in (subst, pred len)) | _ -> (subst, len - signlen)) - ([], nar) tomatchs arsign + (List.rev tomatchs) arsign ([], nar) in let rec predicate lift c = match kind_of_term c with @@ -1913,9 +1908,12 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = | _ -> map_constr_with_binders succ predicate lift c in + assert (len == 0); let p = predicate 0 c in - fst (Typing.type_of (push_rel_context (context_of_arsign arsign) env) sigma p), p - + let env' = List.fold_right push_rel_context arsign env in + try let sigma' = fst (Typing.type_of env' sigma p) in + Some (sigma', p) + with e when precatchable_exception e -> None (* Builds the predicate. If the predicate is dependent, its context is * made of 1+nrealargs assumptions for each matched term in an inductive @@ -1936,11 +1934,13 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = (* If the tycon is not closed w.r.t real variables, we try *) (* two different strategies *) (* First strategy: we abstract the tycon wrt to the dependencies *) - let sigma1,pred1 = + let p1 = prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in (* Second strategy: we build an "inversion" predicate *) let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in - [sigma1, pred1; sigma2, pred2] + (match p1 with + | Some (sigma1,pred1) -> [sigma1, pred1; sigma2, pred2] + | None -> [sigma2, pred2]) | None, _ -> (* No dependent type constraint, or no constraints at all: *) (* we use two strategies *) @@ -2375,6 +2375,13 @@ let build_dependent_signature env evdref avoid tomatchs arsign = assert(Int.equal slift 0); (* we must have folded over all elements of the arity signature *) arsign'', allnames, nar, eqs, neqs, refls +let context_of_arsign l = + let (x, _) = List.fold_right + (fun c (x, n) -> + (lift_rel_context n c @ x, List.length c + n)) + l ([], 0) + in x + let compile_program_cases loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function @@ -2405,12 +2412,11 @@ let compile_program_cases loc style (typing_function, evdref) tycon env | None -> let ev = mkExistential env evdref in ev, ev | Some t -> let pred = - try - let evd, pred = prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t in - evdref := evd; pred - with e when Errors.noncritical e -> - let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in - lift nar t + match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with + | Some (evd, pred) -> evdref := evd; pred + | None -> + let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in + lift nar t in Option.get tycon, pred in let neqs, arity = -- cgit v1.2.3 From d694c532f3f15569a204fa9f2d02f2c0ea83b424 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 9 Oct 2015 11:02:15 +0200 Subject: Fix Next Obligation to not raise an anomaly in case of mutual definitions. --- toplevel/obligations.ml | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 00ea2ffb84..665926922f 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -463,19 +463,6 @@ let map_replace k v m = ProgMap.add k (Ephemeron.create v) (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let map_cardinal m = - let i = ref 0 in - ProgMap.iter (fun _ _ -> incr i) m; - !i - -exception Found of program_info - -let map_first m = - try - ProgMap.iter (fun _ v -> raise (Found v)) m; - assert(false) - with Found x -> x - let from_prg : program_info ProgMap.t ref = Summary.ref ProgMap.empty ~name:"program-tcc-table" @@ -680,6 +667,22 @@ let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls prg_hook = hook; prg_opaque = opaque; } +let map_cardinal m = + let i = ref 0 in + ProgMap.iter (fun _ v -> + if snd (Ephemeron.get v).prg_obligations > 0 then incr i) m; + !i + +exception Found of program_info + +let map_first m = + try + ProgMap.iter (fun _ v -> + if snd (Ephemeron.get v).prg_obligations > 0 then + raise (Found v)) m; + assert(false) + with Found x -> x + let get_prog name = let prg_infos = !from_prg in match name with -- cgit v1.2.3 From f3c4dc6fb350b318ccc3af3a0e9aecb977b25744 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 9 Oct 2015 15:19:08 +0200 Subject: Fix CFGV contrib: handling of global hints introducing global universes. It was wrong, the context was readded needlessly to the local evar_map context. --- tactics/eauto.ml4 | 2 +- tactics/hints.ml | 14 ++++++++------ tactics/hints.mli | 4 ++-- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 83498cabd8..0c52968a70 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -94,7 +94,7 @@ let out_term = function | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) let prolog_tac l n gl = - let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in + let l = List.map (fun x -> out_term (pf_apply (prepare_hint false false) gl x)) l in let n = match n with | ArgArg n -> n diff --git a/tactics/hints.ml b/tactics/hints.ml index dbb2340364..e4f28b8eb2 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1052,7 +1052,7 @@ let default_prepare_hint_ident = Id.of_string "H" exception Found of constr * types -let prepare_hint check env init (sigma,c) = +let prepare_hint check poly env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in (* We re-abstract over uninstantiated evars. It is actually a bit stupid to generalize over evars since the first @@ -1082,15 +1082,17 @@ let prepare_hint check env init (sigma,c) = let c' = iter c in if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in - IsConstr (c', diff) + if poly then IsConstr (c', diff) + else (Global.push_context_set false diff; + IsConstr (c', Univ.ContextSet.empty)) let interp_hints poly = fun h -> let env = (Global.env()) in let sigma = Evd.from_env env in - let f c = + let f poly c = let evd,c = Constrintern.interp_open_constr env sigma c in - prepare_hint true (Global.env()) Evd.empty (evd,c) in + prepare_hint true poly (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in Dumpglob.add_glob (loc_of_reference r) gr; @@ -1103,7 +1105,7 @@ let interp_hints poly = | HintsReference c -> let gr = global_with_alias c in (PathHints [gr], poly, IsGlobRef gr) - | HintsConstr c -> (PathAny, poly, f c) + | HintsConstr c -> (PathAny, poly, f poly c) in let fres (pri, b, r) = let path, poly, gr = fi r in @@ -1159,7 +1161,7 @@ let expand_constructor_hints env sigma lems = (fun i -> IsConstr (mkConstructU ((ind,i+1),u), Univ.ContextSet.empty)) | _ -> - [prepare_hint false env sigma (evd,lem)]) lems + [prepare_hint false false env sigma (evd,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) diff --git a/tactics/hints.mli b/tactics/hints.mli index 5a4fb77091..b7b219e2e7 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -151,8 +151,8 @@ val interp_hints : polymorphic -> hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit -val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> - open_constr -> hint_term +val prepare_hint : bool (* Check no remaining evars *) -> bool (* polymorphic *) -> + env -> evar_map -> open_constr -> hint_term (** [make_exact_entry pri (c, ctyp)]. [c] is the term given as an exact proof to solve the goal; -- cgit v1.2.3 From 5e1296a5cae4ae0ab84ddbe7b0ec71959861af97 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 9 Oct 2015 15:41:48 +0200 Subject: Refine fix for handling of the universe contexts of hints, depending on their polymorphic status _and_ locality. --- tactics/eauto.ml4 | 2 +- tactics/hints.ml | 7 ++++--- tactics/hints.mli | 3 ++- test-suite/bugs/closed/4354.v | 3 ++- 4 files changed, 9 insertions(+), 6 deletions(-) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 0c52968a70..b6b18719c0 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -94,7 +94,7 @@ let out_term = function | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) let prolog_tac l n gl = - let l = List.map (fun x -> out_term (pf_apply (prepare_hint false false) gl x)) l in + let l = List.map (fun x -> out_term (pf_apply (prepare_hint false (false,true)) gl x)) l in let n = match n with | ArgArg n -> n diff --git a/tactics/hints.ml b/tactics/hints.ml index e4f28b8eb2..9faa96a806 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1052,7 +1052,7 @@ let default_prepare_hint_ident = Id.of_string "H" exception Found of constr * types -let prepare_hint check poly env init (sigma,c) = +let prepare_hint check (poly,local) env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in (* We re-abstract over uninstantiated evars. It is actually a bit stupid to generalize over evars since the first @@ -1083,6 +1083,7 @@ let prepare_hint check poly env init (sigma,c) = if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) + else if local then IsConstr (c', diff) else (Global.push_context_set false diff; IsConstr (c', Univ.ContextSet.empty)) @@ -1092,7 +1093,7 @@ let interp_hints poly = let sigma = Evd.from_env env in let f poly c = let evd,c = Constrintern.interp_open_constr env sigma c in - prepare_hint true poly (Global.env()) Evd.empty (evd,c) in + prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in Dumpglob.add_glob (loc_of_reference r) gr; @@ -1161,7 +1162,7 @@ let expand_constructor_hints env sigma lems = (fun i -> IsConstr (mkConstructU ((ind,i+1),u), Univ.ContextSet.empty)) | _ -> - [prepare_hint false false env sigma (evd,lem)]) lems + [prepare_hint false (false,true) env sigma (evd,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types *) diff --git a/tactics/hints.mli b/tactics/hints.mli index b7b219e2e7..e25b66b27b 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -151,7 +151,8 @@ val interp_hints : polymorphic -> hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit -val prepare_hint : bool (* Check no remaining evars *) -> bool (* polymorphic *) -> +val prepare_hint : bool (* Check no remaining evars *) -> + (bool * bool) (* polymorphic or monomorphic, local or global *) -> env -> evar_map -> open_constr -> hint_term (** [make_exact_entry pri (c, ctyp)]. diff --git a/test-suite/bugs/closed/4354.v b/test-suite/bugs/closed/4354.v index 6a2f9672d3..e71ddaf71f 100644 --- a/test-suite/bugs/closed/4354.v +++ b/test-suite/bugs/closed/4354.v @@ -3,8 +3,9 @@ Class Lift (T : Type). Axiom closed_increment : forall {T} {H : Lift T}, True. Create HintDb core. Lemma closed_monotonic T (H : Lift T) : True. +Proof. + Set Printing Universes. auto using closed_increment. Show Universes. Qed. - (* also fails with -nois, so the content of the hint database does not matter *) \ No newline at end of file -- cgit v1.2.3 From 7c82718f18afa3b317873f756a8801774ef64061 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 9 Oct 2015 13:19:20 +0200 Subject: Minor typo in universe polymorphism doc. --- dev/doc/univpoly.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/doc/univpoly.txt b/dev/doc/univpoly.txt index bad2ae36eb..9e243eead5 100644 --- a/dev/doc/univpoly.txt +++ b/dev/doc/univpoly.txt @@ -82,7 +82,7 @@ show that A's type is in cumululativity relation with id's type argument, incurring a universe constraint. To do this, one can simply call Typing.resolve_evars env evdref c which will do some infer_conv to produce the right constraints and put them in the evar_map. Of course in -some cases you might now from an invariant that no new constraint would +some cases you might know from an invariant that no new constraint would be produced and get rid of it. Anyway the kernel will tell you if you forgot some. As a temporary way out, [Universes.constr_of_global] allows you to make a constr from any non-polymorphic constant, but it will fail -- cgit v1.2.3 From c47b205206d832430fa80a3386be80149e281d33 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 9 Oct 2015 13:04:56 +0200 Subject: Code cleaning in VM (with Benjamin). Rename some functions, remove dead code related to (previously deprecated, now removed) option Set Boxed Values. --- dev/vm_printers.ml | 1 - kernel/byterun/coq_memory.c | 14 ------ kernel/byterun/coq_values.h | 13 +++--- kernel/vconv.ml | 22 +-------- kernel/vm.ml | 110 ++++++++++++-------------------------------- kernel/vm.mli | 14 ++---- pretyping/vnorm.ml | 9 +--- toplevel/coqtop.ml | 2 - toplevel/vernacentries.ml | 9 ---- 9 files changed, 41 insertions(+), 153 deletions(-) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 3d688011c2..802b0f9d80 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -61,7 +61,6 @@ and ppstack s = and ppatom a = match a with | Aid idk -> print_idkey idk - | Aiddef(idk,_) -> print_string "&";print_idkey idk | Aind((sp,i),_) -> print_string "Ind("; print_string (string_of_mind sp); print_string ","; print_int i; diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 8d03829ab0..416e5e5329 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -26,7 +26,6 @@ asize_t coq_max_stack_size = Coq_max_stack_size; value coq_global_data; -int coq_all_transp; value coq_atom_tbl; int drawinstr; @@ -117,7 +116,6 @@ value init_coq_vm(value unit) /* ML */ init_coq_global_data(Coq_global_data_Size); init_coq_atom_tbl(40); /* Initialing the interpreter */ - coq_all_transp = 0; init_coq_interpreter(); /* Some predefined pointer code */ @@ -207,18 +205,6 @@ value realloc_coq_atom_tbl(value size) /* ML */ return Val_unit; } - -value coq_set_transp_value(value transp) -{ - coq_all_transp = (transp == Val_true); - return Val_unit; -} - -value get_coq_transp_value(value unit) -{ - return Val_bool(coq_all_transp); -} - value coq_set_drawinstr(value unit) { drawinstr = 1; diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index 1590a2141d..80100da719 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -20,13 +20,12 @@ #define ATOM_ID_TAG 0 -#define ATOM_IDDEF_TAG 1 -#define ATOM_INDUCTIVE_TAG 2 -#define ATOM_PROJ_TAG 3 -#define ATOM_FIX_TAG 4 -#define ATOM_SWITCH_TAG 5 -#define ATOM_COFIX_TAG 6 -#define ATOM_COFIXEVALUATED_TAG 7 +#define ATOM_INDUCTIVE_TAG 1 +#define ATOM_PROJ_TAG 2 +#define ATOM_FIX_TAG 3 +#define ATOM_SWITCH_TAG 4 +#define ATOM_COFIX_TAG 5 +#define ATOM_COFIXEVALUATED_TAG 6 diff --git a/kernel/vconv.ml b/kernel/vconv.ml index a03a67db8b..8af2efc588 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -76,11 +76,7 @@ and conv_whd env pb k whd1 whd2 cu = | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> - conv_val env CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu - | _, Vatom_stk(Aiddef(_,v),stk) -> - conv_whd env pb k whd1 (force_whd v stk) cu - | Vatom_stk(Aiddef(_,v),stk), _ -> - conv_whd env pb k (force_whd v stk) whd2 cu + conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu | Vsort _, _ | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible @@ -97,22 +93,6 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack env k stk1 stk2 cu else raise NotConvertible - | Aiddef(ik1,v1), Aiddef(ik2,v2) -> - begin - try - if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then - conv_stack env k stk1 stk2 cu - else raise NotConvertible - with NotConvertible -> - if oracle_order Univ.out_punivs (oracle_of_infos !infos) - false ik1 ik2 then - conv_whd env pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu - else conv_whd env pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu - end - | Aiddef(ik1,v1), _ -> - conv_whd env pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu - | _, Aiddef(ik2,v2) -> - conv_whd env pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu | Aind _, _ | Aid _, _ -> raise NotConvertible and conv_stack env k stk1 stk2 cu = diff --git a/kernel/vm.ml b/kernel/vm.ml index a822f92eb3..4607ad7165 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -20,6 +20,12 @@ external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" external offset : Obj.t -> int = "coq_offset" let accu_tag = 0 +let max_atom_tag = 1 +let proj_tag = 2 +let fix_app_tag = 3 +let switch_tag = 4 +let cofix_tag = 5 +let cofix_evaluated_tag = 6 (*******************************************) (* Initalization of the abstract machine ***) @@ -29,9 +35,6 @@ external init_vm : unit -> unit = "init_coq_vm" let _ = init_vm () -external transp_values : unit -> bool = "get_coq_transp_value" -external set_transp_values : bool -> unit = "coq_set_transp_value" - (*******************************************) (* Machine code *** ************************) (*******************************************) @@ -141,7 +144,6 @@ type vswitch = { type atom = | Aid of Vars.id_key - | Aiddef of Vars.id_key * values | Aind of pinductive (* Zippers *) @@ -176,20 +178,20 @@ let rec whd_accu a stk = else Zapp (Obj.obj a) :: stk in let at = Obj.field a 1 in match Obj.tag at with - | i when i <= 2 -> + | i when i <= max_atom_tag -> Vatom_stk(Obj.magic at, stk) - | 3 (* proj tag *) -> + | i when Int.equal i proj_tag -> let zproj = Zproj (Obj.obj (Obj.field at 0)) in whd_accu (Obj.field at 1) (zproj :: stk) - | 4 (* fix_app tag *) -> + | i when Int.equal i fix_app_tag -> let fa = Obj.field at 1 in let zfix = Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in whd_accu (Obj.field at 0) (zfix :: stk) - | 5 (* switch tag *) -> + | i when Int.equal i switch_tag -> let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in whd_accu (Obj.field at 0) (zswitch :: stk) - | 6 (* cofix_tag *) -> + | i when Int.equal i cofix_tag -> let vcfx = Obj.obj (Obj.field at 0) in let to_up = Obj.obj a in begin match stk with @@ -197,7 +199,7 @@ let rec whd_accu a stk = | [Zapp args] -> Vcofix(vcfx, to_up, Some args) | _ -> assert false end - | 7 (* cofix_evaluated_tag *) -> + | i when Int.equal i cofix_evaluated_tag -> let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in begin match stk with @@ -258,6 +260,7 @@ let arg args i = ("Vm.arg size = "^(string_of_int (nargs args))^ " acces "^(string_of_int i)) +(* Apply a value to arguments contained in [vargs] *) let apply_arguments vf vargs = let n = nargs vargs in if Int.equal n 0 then vf @@ -268,13 +271,14 @@ let apply_arguments vf vargs = interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end -let apply_vstack vf vstk = - let n = Array.length vstk in +(* Apply value [vf] to an array of argument values [varray] *) +let apply_varray vf varray = + let n = Array.length varray in if Int.equal n 0 then vf else begin push_ra stop; - push_vstack vstk; + push_vstack varray; interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end @@ -360,14 +364,14 @@ external closure_arity : vfun -> int = "coq_closure_arity" let body_of_vfun k vf = let vargs = mkrel_vstack k 1 in - apply_vstack (Obj.magic vf) vargs + apply_varray (Obj.magic vf) vargs let decompose_vfun2 k vf1 vf2 = let arity = min (closure_arity vf1) (closure_arity vf2) in assert (0 < arity && arity < Sys.max_array_length); let vargs = mkrel_vstack k arity in - let v1 = apply_vstack (Obj.magic vf1) vargs in - let v2 = apply_vstack (Obj.magic vf2) vargs in + let v1 = apply_varray (Obj.magic vf1) vargs in + let v2 = apply_varray (Obj.magic vf2) vargs in arity, v1, v2 (* Functions over fixpoint *) @@ -497,7 +501,7 @@ let reduce_cofix k vcf = let self = Obj.new_block accu_tag 2 in Obj.set_field self 0 (Obj.repr accumulate); Obj.set_field self 1 (Obj.repr atom); - apply_vstack (Obj.obj e) [|Obj.obj self|] in + apply_varray (Obj.obj e) [|Obj.obj self|] in (Array.init ndef cofix_body, ftyp) @@ -550,62 +554,12 @@ let branch_of_switch k sw = in Array.map eval_branch sw.sw_annot.rtbl - - -(* Evaluation *) - -let rec whd_stack v stk = - match stk with - | [] -> whd_val v - | Zapp args :: stkt -> whd_stack (apply_arguments v args) stkt - | Zfix (f,args) :: stkt -> - let o = Obj.repr v in - if Obj.is_block o && Obj.tag o = accu_tag then - whd_accu (Obj.repr v) stk - else - let v', stkt = - match stkt with - | Zapp args' :: stkt -> - push_ra stop; - push_arguments args'; - push_val v; - push_arguments args; - let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) - (nargs args+ nargs args') in - v', stkt - | _ -> - push_ra stop; - push_val v; - push_arguments args; - let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) - (nargs args) in - v', stkt - in - whd_stack v' stkt - | Zswitch sw :: stkt -> - let o = Obj.repr v in - if Obj.is_block o && Obj.tag o = accu_tag then - if Obj.tag (Obj.field o 1) < cofix_tag then whd_accu (Obj.repr v) stk - else - let to_up = - match whd_accu (Obj.repr v) [] with - | Vcofix (_, to_up, _) -> to_up - | _ -> assert false in - whd_stack (apply_switch sw to_up) stkt - else whd_stack (apply_switch sw v) stkt - -let rec force_whd v stk = - match whd_stack v stk with - | Vatom_stk(Aiddef(_,v),stk) -> force_whd v stk - | res -> res - - -let rec eta_stack a stk v = +(* Apply the term represented by a under stack stk to argument v *) +(* t = a stk --> t v *) +let rec apply_stack a stk v = match stk with - | [] -> apply_vstack a [|v|] - | Zapp args :: stk -> eta_stack (apply_arguments a args) stk v + | [] -> apply_varray a [|v|] + | Zapp args :: stk -> apply_stack (apply_arguments a args) stk v | Zfix(f,args) :: stk -> let a,stk = match stk with @@ -626,11 +580,11 @@ let rec eta_stack a stk v = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) in a, stk in - eta_stack a stk v + apply_stack a stk v | Zswitch sw :: stk -> - eta_stack (apply_switch sw a) stk v + apply_stack (apply_switch sw a) stk v -let eta_whd k whd = +let apply_whd k whd = let v = val_of_rel k in match whd with | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false @@ -649,8 +603,4 @@ let eta_whd k whd = push_val v; interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 | Vatom_stk(a,stk) -> - eta_stack (val_of_atom a) stk v - - - - + apply_stack (val_of_atom a) stk v diff --git a/kernel/vm.mli b/kernel/vm.mli index d31448ee13..045d02333c 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -2,13 +2,10 @@ open Names open Term open Cbytecodes -(** Efficient Virtual Machine *) +(** Debug printing *) val set_drawinstr : unit -> unit -val transp_values : unit -> bool -val set_transp_values : bool -> unit - (** Machine code *) type tcode @@ -25,7 +22,6 @@ type arguments type atom = | Aid of Vars.id_key - | Aiddef of Vars.id_key * values | Aind of pinductive (** Zippers *) @@ -106,10 +102,6 @@ val case_info : vswitch -> case_info val type_of_switch : vswitch -> values val branch_of_switch : int -> vswitch -> (int * values) array -(** Evaluation *) - -val whd_stack : values -> stack -> whd -val force_whd : values -> stack -> whd - -val eta_whd : int -> whd -> values +(** Apply a value *) +val apply_whd : int -> whd -> values diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index af640d7f34..f768e4feef 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -179,8 +179,6 @@ and nf_whd env whd typ = | Vatom_stk(Aid idkey, stk) -> let c,typ = constr_type_of_idkey env idkey in nf_stk env c typ stk - | Vatom_stk(Aiddef(idkey,v), stk) -> - nf_whd env (whd_stack v stk) typ | Vatom_stk(Aind ind, stk) -> nf_stk env (mkIndU ind) (type_of_ind env ind) stk @@ -312,10 +310,5 @@ and nf_cofix env cf = mkCoFix (init,(name,cft,cfb)) let cbv_vm env c t = - let transp = transp_values () in - if not transp then set_transp_values true; let v = Vconv.val_of_constr env c in - let c = nf_val env v t in - if not transp then set_transp_values false; - c - + nf_val env v t diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 9b5a09de0e..8925bbe299 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -235,11 +235,9 @@ let compile_files () = (*s options for the virtual machine *) -let boxed_val = ref false let use_vm = ref false let set_vm_opt () = - Vm.set_transp_values (not !boxed_val); Vconv.set_use_vm !use_vm (** Options for proof general *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 820903c417..35730eea03 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1375,15 +1375,6 @@ let _ = optread = (fun () -> !Closure.share); optwrite = (fun b -> Closure.share := b) } -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "use of boxed values"; - optkey = ["Boxed";"Values"]; - optread = (fun _ -> not (Vm.transp_values ())); - optwrite = (fun b -> Vm.set_transp_values (not b)) } - (* No more undo limit in the new proof engine. The command still exists for compatibility (e.g. with ProofGeneral) *) -- cgit v1.2.3 From db06a1ddee4c79ea8f6903596284df2f2700ddac Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 9 Oct 2015 13:20:45 +0200 Subject: Complete handling of primitive projections in VM. This commit is a follow-up to a51cce369b9c634a93120092d4c7685a242d55b1 --- kernel/vm.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/kernel/vm.ml b/kernel/vm.ml index 4607ad7165..29e2ee601d 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -314,6 +314,15 @@ let val_of_str_const str = val_of_obj (obj_of_str_const str) let val_of_atom a = val_of_obj (obj_of_atom a) +let atom_of_proj kn v = + let r = Obj.new_block proj_tag 2 in + Obj.set_field r 0 (Obj.repr kn); + Obj.set_field r 1 (Obj.repr v); + ((Obj.obj r) : atom) + +let val_of_proj kn v = + val_of_atom (atom_of_proj kn v) + module IdKeyHash = struct type t = pconstant tableKey @@ -560,6 +569,7 @@ let rec apply_stack a stk v = match stk with | [] -> apply_varray a [|v|] | Zapp args :: stk -> apply_stack (apply_arguments a args) stk v + | Zproj kn :: stk -> apply_stack (val_of_proj kn a) stk v | Zfix(f,args) :: stk -> let a,stk = match stk with -- cgit v1.2.3 From cd440dbd43a632cf8f445a80d034f36e4235c63e Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 10 Oct 2015 13:02:56 +0200 Subject: Fix a few latex errors in documentation of Proof Using (e.g. \tt*). --- doc/refman/RefMan-pro.tex | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 5dbf315535..481afa8f87 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -165,14 +165,17 @@ in Section~\ref{ProofWith}. {\tt Type* } is the forward transitive closure of the entire set of section variables occurring in the statement. -\variant {\tt Proof using -(} {\ident$_1$} {\ldots} {\ident$_n$} {\tt ).} +\variant {\tt Proof using -( \ident$_1$} {\ldots} {\tt \ident$_n$ ).} Use all section variables except {\ident$_1$} {\ldots} {\ident$_n$}. -\variant {\tt Proof using } {\emph collection$_1$} {\tt + } {\emph collection$_2$} {\tt .} -\variant {\tt Proof using } {\emph collection$_1$} {\tt - } {\emph collection$_2$} {\tt .} -\variant {\tt Proof using } {\emph collection$_1$} {\tt - (} {\ident$_1$} {\ldots} {\ident$_n$} {\tt ).} -\variant {\tt Proof using } {\emph collection$_1$}{\tt* .} +\variant {\tt Proof using \nterm{collection}$_1$ + \nterm{collection}$_2$ .} + +\variant {\tt Proof using \nterm{collection}$_1$ - \nterm{collection}$_2$ .} + +\variant {\tt Proof using \nterm{collection} - ( \ident$_1$} {\ldots} {\tt \ident$_n$ ).} + +\variant {\tt Proof using \nterm{collection} * .} Use section variables being, respectively, in the set union, set difference, set complement, set forward transitive closure. -- cgit v1.2.3 From d399671f3f1a667a47540071feecb20baf115418 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 11:21:23 +0200 Subject: Constr_matching: renaming misleading name stk into ctx. --- pretyping/constr_matching.ml | 92 ++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 46 deletions(-) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index a0493777a5..585be9c720 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -80,21 +80,21 @@ let add_binders na1 na2 (names, terms as subst) = match na1, na2 with (names, terms) | _ -> subst -let rec build_lambda vars stk m = match vars with +let rec build_lambda vars ctx m = match vars with | [] -> - let len = List.length stk in + let len = List.length ctx in lift (-1 * len) m | n :: vars -> (* change [ x1 ... xn y z1 ... zm |- t ] into [ x1 ... xn z1 ... zm |- lam y. t ] *) - let len = List.length stk in + let len = List.length ctx in let init i = if i < pred n then mkRel (i + 2) else if Int.equal i (pred n) then mkRel 1 else mkRel (i + 1) in let m = substl (List.init len init) m in - let pre, suf = List.chop (pred n) stk in + let pre, suf = List.chop (pred n) ctx in match suf with | [] -> assert false | (_, na, t) :: suf -> @@ -108,21 +108,21 @@ let rec build_lambda vars stk m = match vars with let m = mkLambda (na, t, m) in build_lambda vars (pre @ suf) m -let rec extract_bound_aux k accu frels stk = match stk with +let rec extract_bound_aux k accu frels ctx = match ctx with | [] -> accu -| (na1, na2, _) :: stk -> +| (na1, na2, _) :: ctx -> if Int.Set.mem k frels then begin match na1 with | Name id -> let () = assert (match na2 with Anonymous -> false | Name _ -> true) in let () = if Id.Set.mem id accu then raise PatternMatchingFailure in - extract_bound_aux (k + 1) (Id.Set.add id accu) frels stk + extract_bound_aux (k + 1) (Id.Set.add id accu) frels ctx | Anonymous -> raise PatternMatchingFailure end - else extract_bound_aux (k + 1) accu frels stk + else extract_bound_aux (k + 1) accu frels ctx -let extract_bound_vars frels stk = - extract_bound_aux 1 Id.Set.empty frels stk +let extract_bound_vars frels ctx = + extract_bound_aux 1 Id.Set.empty frels ctx let dummy_constr = mkProp @@ -134,20 +134,20 @@ let make_renaming ids = function end | _ -> dummy_constr -let merge_binding allow_bound_rels stk n cT subst = - let c = match stk with +let merge_binding allow_bound_rels ctx n cT subst = + let c = match ctx with | [] -> (* Optimization *) ([], cT) | _ -> let frels = free_rels cT in if allow_bound_rels then - let vars = extract_bound_vars frels stk in + let vars = extract_bound_vars frels ctx in let ordered_vars = Id.Set.elements vars in let rename binding = make_renaming ordered_vars binding in - let renaming = List.map rename stk in + let renaming = List.map rename ctx in (ordered_vars, substl renaming cT) else - let depth = List.length stk in + let depth = List.length ctx in let min_elt = try Int.Set.min_elt frels with Not_found -> succ depth in if depth < min_elt then ([], lift (- depth) cT) @@ -168,7 +168,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = is_conv env sigma c' c else false) in - let rec sorec stk env subst p t = + let rec sorec ctx env subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with | PSoApp (n,args),m -> @@ -181,11 +181,11 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in let frels = free_rels cT in if Int.Set.subset frels relset then - constrain n ([], build_lambda relargs stk cT) subst + constrain n ([], build_lambda relargs ctx cT) subst else raise PatternMatchingFailure - | PMeta (Some n), m -> merge_binding allow_bound_rels stk n cT subst + | PMeta (Some n), m -> merge_binding allow_bound_rels ctx n cT subst | PMeta None, m -> subst @@ -203,10 +203,10 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = | PSort (GType _), Sort (Type _) -> subst - | PApp (p, [||]), _ -> sorec stk env subst p t + | PApp (p, [||]), _ -> sorec ctx env subst p t | PApp (PApp (h, a1), a2), _ -> - sorec stk env subst (PApp(h,Array.append a1 a2)) t + sorec ctx env subst (PApp(h,Array.append a1 a2)) t | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app -> (let diff = Array.length args2 - Array.length args1 in @@ -216,13 +216,13 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = let subst = match meta with | None -> subst - | Some n -> merge_binding allow_bound_rels stk n c subst in - Array.fold_left2 (sorec stk env) subst args1 args22 + | Some n -> merge_binding allow_bound_rels ctx n c subst in + Array.fold_left2 (sorec ctx env) subst args1 args22 else (* Might be a projection on the right *) match kind_of_term c2 with | Proj (pr, c) when not (Projection.unfolded pr) -> (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in - sorec stk env subst p term + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _ -> raise PatternMatchingFailure) @@ -233,15 +233,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = raise PatternMatchingFailure | PProj (pr1,c1), Proj (pr,c) -> if Projection.equal pr1 pr then - try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c) arg1 arg2 + try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure else raise PatternMatchingFailure | _, Proj (pr,c) when not (Projection.unfolded pr) -> (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in - sorec stk env subst p term + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _, _ -> - try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c2) arg1 arg2 + try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure) | PApp (PRef (ConstRef c1), _), Proj (pr, c2) @@ -250,37 +250,37 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = | PApp (c, args), Proj (pr, c2) -> (try let term = Retyping.expand_projection env sigma pr c2 [] in - sorec stk env subst p term + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> - sorec stk env subst c1 c2 + sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env) - (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2 + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) + (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env) - (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2 + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) + (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::stk) (Environ.push_rel (na2,Some c2,t2) env) - (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2 + sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env) + (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> - let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in - let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in - let n = rel_context_length ctx in - let n' = rel_context_length ctx' in + let ctx_b2,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in + let ctx_b2',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in + let n = rel_context_length ctx_b2 in + let n' = rel_context_length ctx_b2' in if noccur_between 1 n b2 && noccur_between 1 n' b2' then - let s = - List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx in - let s' = - List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx' in + let f l (na,_,t) = (Anonymous,na,t)::l in + let ctx_br = List.fold_left f ctx ctx_b2 in + let ctx_br' = List.fold_left f ctx ctx_b2' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in - sorec s' (Environ.push_rel_context ctx' env) - (sorec s (Environ.push_rel_context ctx env) (sorec stk env subst a1 a2) b1 b2) b1' b2' + sorec ctx_br' (Environ.push_rel_context ctx_b2' env) + (sorec ctx_br (Environ.push_rel_context ctx_b2 env) + (sorec ctx env subst a1 a2) b1 b2) b1' b2' else raise PatternMatchingFailure @@ -301,9 +301,9 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = (* (ind,j+1) is normally known to be a correct constructor and br2 a correct match over the same inductive *) assert (j < n2); - sorec stk env subst c br2.(j) + sorec ctx env subst c br2.(j) in - let chk_head = sorec stk env (sorec stk env subst a1 a2) p1 p2 in + let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in List.fold_left chk_branch chk_head br1 | PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst -- cgit v1.2.3 From 2e07ecfce221840047b2f95c93acdb79a4fe0985 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 13:42:11 +0200 Subject: Fixing obviously untested fold_glob_constr and iter_glob_constr. --- pretyping/glob_ops.ml | 51 +++++++++++++++++++++++---------------------------- 1 file changed, 23 insertions(+), 28 deletions(-) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 454d64f01b..5b02c8cd15 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -183,37 +183,32 @@ let map_glob_constr_left_to_right f = function let map_glob_constr = map_glob_constr_left_to_right -let fold_glob_constr f acc = - let rec fold acc = function +let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt + +let fold_glob_constr f acc = function | GVar _ -> acc - | GApp (_,c,args) -> List.fold_left fold (fold acc c) args + | GApp (_,c,args) -> List.fold_left f (f acc c) args | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) -> - fold (fold acc b) c + f (f acc b) c | GCases (_,_,rtntypopt,tml,pl) -> - List.fold_left fold_pattern - (List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml)) - pl - | GLetTuple (_,_,rtntyp,b,c) -> - fold (fold (fold_return_type acc rtntyp) b) c - | GIf (_,c,rtntyp,b1,b2) -> - fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2 - | GRec (_,_,_,bl,tyl,bv) -> - let acc = Array.fold_left - (List.fold_left (fun acc (na,k,bbd,bty) -> - fold (Option.fold_left fold acc bbd) bty)) acc bl in - Array.fold_left fold (Array.fold_left fold acc tyl) bv - | GCast (_,c,k) -> - let r = match k with - | CastConv t | CastVM t | CastNative t -> fold acc t | CastCoerce -> acc - in - fold r c - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc - - and fold_pattern acc (_,idl,p,c) = fold acc c - - and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt - - in fold acc + let fold_pattern acc (_,idl,p,c) = f acc c in + List.fold_left fold_pattern + (List.fold_left f (Option.fold_left f acc rtntypopt) (List.map fst tml)) + pl + | GLetTuple (_,_,rtntyp,b,c) -> + f (f (fold_return_type f acc rtntyp) b) c + | GIf (_,c,rtntyp,b1,b2) -> + f (f (f (fold_return_type f acc rtntyp) c) b1) b2 + | GRec (_,_,_,bl,tyl,bv) -> + let acc = Array.fold_left + (List.fold_left (fun acc (na,k,bbd,bty) -> + f (Option.fold_left f acc bbd) bty)) acc bl in + Array.fold_left f (Array.fold_left f acc tyl) bv + | GCast (_,c,k) -> + let acc = match k with + | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in + f acc c + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc let iter_glob_constr f = fold_glob_constr (fun () -> f) () -- cgit v1.2.3 From ae5305a4837cce3c7fd61b92ce8110ac66ec2750 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 15:05:10 +0200 Subject: Refining 0c320e79ba30 in fixing interpretation of constr under binders which was broken after it became possible to have binding names themselves bound to ltac variables (2fcc458af16b). Interpretation was corrected, but error message was damaged. --- pretyping/pretyping.ml | 4 ++-- test-suite/output/ltac.out | 2 ++ test-suite/output/ltac.v | 8 ++++++++ test-suite/success/ltac.v | 11 +++++++++++ 4 files changed, 23 insertions(+), 2 deletions(-) create mode 100644 test-suite/output/ltac.out create mode 100644 test-suite/output/ltac.v diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 6306739b7a..746b4000ee 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -322,8 +322,8 @@ let ltac_interp_name_env k0 lvar env = push_rel_context ctxt env let invert_ltac_bound_name lvar env id0 id = - let id = Id.Map.find id lvar.ltac_idents in - try mkRel (pi1 (lookup_rel_id id (rel_context env))) + let id' = Id.Map.find id lvar.ltac_idents in + try mkRel (pi1 (lookup_rel_id id' (rel_context env))) with Not_found -> errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out new file mode 100644 index 0000000000..d003c70df9 --- /dev/null +++ b/test-suite/output/ltac.out @@ -0,0 +1,2 @@ +The command has indeed failed with message: +Error: Ltac variable y depends on pattern variable name z which is not bound in current context. diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v new file mode 100644 index 0000000000..567e21edbe --- /dev/null +++ b/test-suite/output/ltac.v @@ -0,0 +1,8 @@ +(* This used to refer to b instead of z sometimes between 8.4 and 8.5beta3 *) +Goal True. +Fail let T := constr:((fun a b : nat => a+b) 1 1) in + lazymatch T with + | (fun x z => ?y) 1 1 + => pose ((fun x _ => y) 1 1) + end. +Abort. diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index f9df021dc2..6c4d4ae98f 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -306,3 +306,14 @@ let x := ipattern:y in assert (forall x y, x = y + 0). intro. destruct y. (* Check that the name is y here *) Abort. + +(* An example suggested by Jason (see #4317) showing the intended semantics *) +(* Order of binders is reverted because y is just told to depend on x *) + +Goal 1=1. +let T := constr:(fun a b : nat => a) in + lazymatch T with + | (fun x z => ?y) => pose ((fun x x => y) 2 1) + end. +exact (eq_refl n). +Qed. -- cgit v1.2.3 From e9995f6e9f9523d4738d9ee494703b6f96bf995d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 14:36:29 +0200 Subject: Fixing untimely unexpected warning "Collision between bound variables" (#4317). Collecting the bound variables is now done on the glob_constr, before interpretation, so that only variables given explicitly by the user are used for binding bound variables. --- intf/tacexpr.mli | 5 ++-- pretyping/constr_matching.ml | 46 ++++++++++++++++----------------- pretyping/constr_matching.mli | 9 ++++--- pretyping/glob_ops.ml | 60 +++++++++++++++++++++++++++++++++++++++++++ pretyping/glob_ops.mli | 1 + tactics/tacinterp.ml | 7 ++--- tactics/tactic_matching.mli | 4 +-- test-suite/output/ltac.v | 9 +++++++ 8 files changed, 108 insertions(+), 33 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 2b37c580ea..eb4e5ae7d3 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -114,6 +114,7 @@ type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr +type binding_bound_vars = Id.Set.t type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern type delayed_open_constr_with_bindings = @@ -325,7 +326,7 @@ constraint 'a = < type g_trm = glob_constr_and_expr type g_utrm = g_trm -type g_pat = glob_constr_and_expr * constr_pattern +type g_pat = glob_constr_pattern_and_expr type g_cst = evaluable_global_reference and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = Id.t located @@ -386,7 +387,7 @@ type raw_tactic_arg = type t_trm = Term.constr type t_utrm = Glob_term.closed_glob_constr -type t_pat = glob_constr_and_expr * constr_pattern +type t_pat = glob_constr_pattern_and_expr type t_cst = evaluable_global_reference and_short_name type t_ref = ltac_constant located type t_nam = Id.t diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 585be9c720..19c85c9e27 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -56,10 +56,6 @@ let warn_bound_meta name = let warn_bound_bound name = msg_warning (str "Collision between bound variables of name " ++ pr_id name) -let warn_bound_again name = - msg_warning (str "Collision between bound variable " ++ pr_id name ++ - str " and another bound variable of same name.") - let constrain n (ids, m as x) (names, terms as subst) = try let (ids', m') = Id.Map.find n terms in @@ -69,16 +65,17 @@ let constrain n (ids, m as x) (names, terms as subst) = let () = if Id.Map.mem n names then warn_bound_meta n in (names, Id.Map.add n x terms) -let add_binders na1 na2 (names, terms as subst) = match na1, na2 with -| Name id1, Name id2 -> - if Id.Map.mem id1 names then - let () = warn_bound_bound id1 in - (names, terms) - else - let names = Id.Map.add id1 id2 names in - let () = if Id.Map.mem id1 terms then warn_bound_again id1 in - (names, terms) -| _ -> subst +let add_binders na1 na2 binding_vars (names, terms as subst) = + match na1, na2 with + | Name id1, Name id2 when Id.Set.mem id1 binding_vars -> + if Id.Map.mem id1 names then + let () = warn_bound_bound id1 in + (names, terms) + else + let names = Id.Map.add id1 id2 names in + let () = if Id.Map.mem id1 terms then warn_bound_meta id1 in + (names, terms) + | _ -> subst let rec build_lambda vars ctx m = match vars with | [] -> @@ -155,7 +152,8 @@ let merge_binding allow_bound_rels ctx n cT subst = in constrain n c subst -let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = +let matches_core env sigma convert allow_partial_app allow_bound_rels + (binding_vars,pat) c = let convref ref c = match ref, kind_of_term c with | VarRef id, Var id' -> Names.id_eq id id' @@ -258,15 +256,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = | PProd (na1,c1,d1), Prod(na2,c2,d2) -> sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) - (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2 + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) - (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2 + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env) - (add_binders na1 na2 (sorec ctx env subst c1 c2)) d1 d2 + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> let ctx_b2,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in @@ -319,7 +317,8 @@ let matches_core_closed env sigma convert allow_partial_app pat c = let extended_matches env sigma = matches_core env sigma false true true -let matches env sigma pat c = snd (matches_core_closed env sigma false true pat c) +let matches env sigma pat c = + snd (matches_core_closed env sigma false true (Id.Set.empty,pat) c) let special_meta = (-1) @@ -464,10 +463,10 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let result () = aux env c (fun x -> x) lempty in IStream.thunk result -let match_subterm env sigma pat c = sub_match env sigma pat c +let match_subterm env sigma pat c = sub_match env sigma (Id.Set.empty,pat) c let match_appsubterm env sigma pat c = - sub_match ~partial_app:true env sigma pat c + sub_match ~partial_app:true env sigma (Id.Set.empty,pat) c let match_subterm_gen env sigma app pat c = sub_match ~partial_app:app env sigma pat c @@ -481,11 +480,12 @@ let is_matching_head env sigma pat c = with PatternMatchingFailure -> false let is_matching_appsubterm ?(closed=true) env sigma pat c = + let pat = (Id.Set.empty,pat) in let results = sub_match ~partial_app:true ~closed env sigma pat c in not (IStream.is_empty results) -let matches_conv env sigma c p = - snd (matches_core_closed env sigma true false c p) +let matches_conv env sigma p c = + snd (matches_core_closed env sigma true false (Id.Set.empty,p) c) let is_matching_conv env sigma pat n = try let _ = matches_conv env sigma pat n in true diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 67854a893d..b9dcb0af26 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -41,7 +41,8 @@ val matches_head : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map variables or metavariables have the same name, the metavariable, or else the rightmost bound variable, takes precedence *) val extended_matches : - env -> Evd.evar_map -> constr_pattern -> constr -> bound_ident_map * extended_patvar_map + env -> Evd.evar_map -> Tacexpr.binding_bound_vars * constr_pattern -> + constr -> bound_ident_map * extended_patvar_map (** [is_matching pat c] just tells if [c] matches against [pat] *) val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool @@ -72,8 +73,10 @@ val match_subterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_ val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t (** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) -val match_subterm_gen : env -> Evd.evar_map -> bool (** true = with app context *) -> - constr_pattern -> constr -> matching_result IStream.t +val match_subterm_gen : env -> Evd.evar_map -> + bool (** true = with app context *) -> + Tacexpr.binding_bound_vars * constr_pattern -> constr -> + matching_result IStream.t (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches against [pat] taking partial subterms into consideration *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 5b02c8cd15..3a76e8bd74 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -8,6 +8,7 @@ open Util open Names +open Nameops open Globnames open Misctypes open Glob_term @@ -323,6 +324,65 @@ let free_glob_vars = let vs = vars Id.Set.empty Id.Set.empty rt in Id.Set.elements vs +let add_and_check_ident id set = + if Id.Set.mem id set then + Pp.(msg_warning + (str "Collision between bound variables of name " ++ Id.print id)); + Id.Set.add id set + +let bound_glob_vars = + let rec vars bound = function + | GLambda (_,na,_,_,_) | GProd (_,na,_,_,_) | GLetIn (_,na,_,_) as c -> + let bound = name_fold add_and_check_ident na bound in + fold_glob_constr vars bound c + | GCases (loc,sty,rtntypopt,tml,pl) -> + let bound = vars_option bound rtntypopt in + let bound = + List.fold_left (fun bound (tm,_) -> vars bound tm) bound tml in + List.fold_left vars_pattern bound pl + | GLetTuple (loc,nal,rtntyp,b,c) -> + let bound = vars_return_type bound rtntyp in + let bound = vars bound b in + let bound = List.fold_right (name_fold add_and_check_ident) nal bound in + vars bound c + | GIf (loc,c,rtntyp,b1,b2) -> + let bound = vars_return_type bound rtntyp in + let bound = vars bound c in + let bound = vars bound b1 in + vars bound b2 + | GRec (loc,fk,idl,bl,tyl,bv) -> + let bound = Array.fold_right Id.Set.add idl bound in + let vars_fix i bound fid = + let bound = + List.fold_left + (fun bound (na,k,bbd,bty) -> + let bound = vars_option bound bbd in + let bound = vars bound bty in + name_fold add_and_check_ident na bound + ) + bound + bl.(i) + in + let bound = vars bound tyl.(i) in + vars bound bv.(i) + in + Array.fold_left_i vars_fix bound idl + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GVar _) -> bound + | GApp _ | GCast _ as c -> fold_glob_constr vars bound c + + and vars_pattern bound (loc,idl,p,c) = + let bound = List.fold_right add_and_check_ident idl bound in + vars bound c + + and vars_option bound = function None -> bound | Some p -> vars bound p + + and vars_return_type bound (na,tyopt) = + let bound = name_fold add_and_check_ident na bound in + vars_option bound tyopt + in + fun rt -> + vars Id.Set.empty rt + (** Mapping of names in binders *) (* spiwack: I used a smartmap-style kind of mapping here, because the diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index e514fd529e..25746323fb 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -38,6 +38,7 @@ val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit val occur_glob_constr : Id.t -> glob_constr -> bool val free_glob_vars : glob_constr -> Id.t list +val bound_glob_vars : glob_constr -> Id.Set.t val loc_of_glob_constr : glob_constr -> Loc.t (** [map_pattern_binders f m c] applies [f] to all the binding names diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 593e46b05c..96d0b592b8 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1038,11 +1038,12 @@ let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt (* Reads a pattern by substituting vars of lfun *) let use_types = false -let eval_pattern lfun ist env sigma (_,pat as c) = +let eval_pattern lfun ist env sigma ((glob,_),pat as c) = + let bound_names = bound_glob_vars glob in if use_types then - pi3 (interp_typed_pattern ist env sigma c) + (bound_names,pi3 (interp_typed_pattern ist env sigma c)) else - instantiate_pattern env sigma lfun pat + (bound_names,instantiate_pattern env sigma lfun pat) let read_pattern lfun ist env sigma = function | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli index abeb47c3b9..d8e6dd0ae3 100644 --- a/tactics/tactic_matching.mli +++ b/tactics/tactic_matching.mli @@ -32,7 +32,7 @@ val match_term : Environ.env -> Evd.evar_map -> Term.constr -> - (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic (** [match_goal env sigma hyps concl rules] matches the goal @@ -45,5 +45,5 @@ val match_goal: Evd.evar_map -> Context.named_context -> Term.constr -> - (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 567e21edbe..9a60afe5f6 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -6,3 +6,12 @@ Fail let T := constr:((fun a b : nat => a+b) 1 1) in => pose ((fun x _ => y) 1 1) end. Abort. + +(* This should not raise a warning (see #4317) *) +Goal True. +assert (H:= eq_refl ((fun x => x) 1)). +let HT := type of H in +lazymatch goal with +| H1 : HT |- _ => idtac "matched" +end. +Abort. -- cgit v1.2.3 From bf39345125d66d3efd9f934be91200013f57841c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 16:29:54 +0200 Subject: Documenting matching under binders. --- doc/refman/RefMan-ltac.tex | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index d388840df5..04c356e44f 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -691,6 +691,13 @@ variables of the form {\tt @?id} that occur in head position of an application. For these variables, the matching is second-order and returns a functional term. +Alternatively, when a metavariable of the form {\tt ?id} occurs under +binders, say $x_1$, \ldots, $x_n$ and the expression matches, the +metavariable is instantiated by a term which can then be used in any +context which also binds the variables $x_1$, \ldots, $x_n$ with +same types. This provides with a primitive form of matching +under context which does not require manipulating a functional term. + If the matching with {\cpattern}$_1$ succeeds, then {\tacexpr}$_1$ is evaluated into some value by substituting the pattern matching instantiations to the metavariables. If {\tacexpr}$_1$ evaluates to a -- cgit v1.2.3 From cd9a2e9e59d87801790859ddd26d225d71be7f7c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 17:26:30 +0200 Subject: Fixing test-suite --- test-suite/output/ltac.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 9a60afe5f6..7e2610c7d7 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -12,6 +12,6 @@ Goal True. assert (H:= eq_refl ((fun x => x) 1)). let HT := type of H in lazymatch goal with -| H1 : HT |- _ => idtac "matched" +| H1 : HT |- _ => idtac end. Abort. -- cgit v1.2.3 From f8658b06b98e59e7f6397c6082e4b9b399499948 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 11 Oct 2015 18:48:01 +0200 Subject: Fixing bug #4366: Conversion tactics recheck uselessly convertibility. --- tactics/tactics.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b113ed31e9..0d6a26a113 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -726,12 +726,11 @@ let reduction_clause redexp cl = let reduce redexp cl goal = let cl = concrete_clause_of (fun () -> pf_ids_of_hyps goal) cl in let redexps = reduction_clause redexp cl in + let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in let tac = tclMAP (fun (where,redexp) -> - e_reduct_option ~check:true + e_reduct_option ~check (Redexpr.reduction_of_red_expr (pf_env goal) redexp) where) redexps in - match redexp with - | Fold _ | Pattern _ -> with_check tac goal - | _ -> tac goal + if check then with_check tac goal else tac goal (* Unfolding occurrences of a constant *) -- cgit v1.2.3 From 303694c6436b36b114f4919ad7cacc9c053d11a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 11 Oct 2015 19:06:26 +0200 Subject: Adding test for bug #4366. --- test-suite/bugs/closed/4366.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 test-suite/bugs/closed/4366.v diff --git a/test-suite/bugs/closed/4366.v b/test-suite/bugs/closed/4366.v new file mode 100644 index 0000000000..6a5e9a4023 --- /dev/null +++ b/test-suite/bugs/closed/4366.v @@ -0,0 +1,15 @@ +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal True. +Proof. +pose (v := stupid 24). +Timeout 2 vm_compute in v. +exact I. +Qed. -- cgit v1.2.3 From c1ebc07204c65b4570333748b63a3ef60618b026 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 12 Oct 2015 10:51:08 +0200 Subject: Gather VM tags in Cbytecodes. --- kernel/cbytecodes.ml | 11 +++++++---- kernel/cbytecodes.mli | 10 ++++++---- kernel/vm.ml | 8 -------- 3 files changed, 13 insertions(+), 16 deletions(-) diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 891d95378b..448bf85444 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -17,13 +17,16 @@ open Term type tag = int -let id_tag = 0 -let iddef_tag = 1 -let ind_tag = 2 -let fix_tag = 3 +let accu_tag = 0 + +let max_atom_tag = 1 +let proj_tag = 2 +let fix_app_tag = 3 let switch_tag = 4 let cofix_tag = 5 let cofix_evaluated_tag = 6 + + (* It would be great if OCaml exported this value, So fixme if this happens in a new version of OCaml *) let last_variant_tag = 245 diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 8f594a45b5..03d6383057 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -13,13 +13,15 @@ open Term type tag = int -val id_tag : tag -val iddef_tag : tag -val ind_tag : tag -val fix_tag : tag +val accu_tag : tag + +val max_atom_tag : tag +val proj_tag : tag +val fix_app_tag : tag val switch_tag : tag val cofix_tag : tag val cofix_evaluated_tag : tag + val last_variant_tag : tag type structured_constant = diff --git a/kernel/vm.ml b/kernel/vm.ml index 29e2ee601d..eacd803fd4 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -19,14 +19,6 @@ external set_drawinstr : unit -> unit = "coq_set_drawinstr" external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" external offset : Obj.t -> int = "coq_offset" -let accu_tag = 0 -let max_atom_tag = 1 -let proj_tag = 2 -let fix_app_tag = 3 -let switch_tag = 4 -let cofix_tag = 5 -let cofix_evaluated_tag = 6 - (*******************************************) (* Initalization of the abstract machine ***) (*******************************************) -- cgit v1.2.3 From a479aa6e8dbd1dda1af2412f8c1e1ff40f0d5a0b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 12 Oct 2015 12:57:23 +0200 Subject: Fix rechecking of applications: it can be given ill-typed terms. Fixes math-classes. --- pretyping/evarsolve.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index a2189d5e4f..754ad8f588 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -130,6 +130,8 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = (* We retype applications to ensure the universe constraints are collected *) +exception IllTypedInstance of env * types * types + let recheck_applications conv_algo env evdref t = let rec aux env t = match kind_of_term t with @@ -146,7 +148,7 @@ let recheck_applications conv_algo env evdref t = aux (succ i) (subst1 args.(i) codom) | UnifFailure (evd, reason) -> Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) - | _ -> assert false + | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) else () in aux 0 fty | _ -> @@ -1134,8 +1136,6 @@ let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (e else raise (CannotProject (evd,ev1')) -exception IllTypedInstance of env * types * types - let check_evar_instance evd evk1 body conv_algo = let evi = Evd.find evd evk1 in let evenv = evar_env evi in -- cgit v1.2.3 From b9a3925288af0cf3023c9a0073dc1eb295270de8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 12 Oct 2015 13:12:26 +0200 Subject: Fix Definition id := Eval in by passing the right universe context to the reduction function. Fixes MapleMode. --- toplevel/command.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/toplevel/command.ml b/toplevel/command.ml index e54a82c19b..7c86d2d059 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -41,13 +41,13 @@ open Vernacexpr let do_universe l = Declare.do_universe l let do_constraint l = Declare.do_constraint l -let rec under_binders env f n c = - if Int.equal n 0 then snd (f env Evd.empty c) else +let rec under_binders env sigma f n c = + if Int.equal n 0 then snd (f env sigma c) else match kind_of_term c with | Lambda (x,t,c) -> - mkLambda (x,t,under_binders (push_rel (x,None,t) env) f (n-1) c) + mkLambda (x,t,under_binders (push_rel (x,None,t) env) sigma f (n-1) c) | LetIn (x,b,t,c) -> - mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) f (n-1) c) + mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) sigma f (n-1) c) | _ -> assert false let rec complete_conclusion a cs = function @@ -67,14 +67,14 @@ let rec complete_conclusion a cs = function (* 1| Constant definitions *) -let red_constant_entry n ce = function +let red_constant_entry n ce sigma = function | None -> ce | Some red -> let proof_out = ce.const_entry_body in let env = Global.env () in { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out (fun ((body,ctx),eff) -> - (under_binders env + (under_binders env sigma (fst (reduction_of_red_expr env red)) n body,ctx),eff) } let interp_definition pl bl p red_option c ctypopt = @@ -125,7 +125,7 @@ let interp_definition pl bl p red_option c ctypopt = definition_entry ~types:typ ~poly:p ~univs:uctx body in - red_constant_entry (rel_context_length ctx) ce red_option, !evdref, imps + red_constant_entry (rel_context_length ctx) ce !evdref red_option, !evdref, imps let check_definition (ce, evd, imps) = check_evars_are_solved (Global.env ()) evd (Evd.empty,evd); -- cgit v1.2.3 From 50183ce7200d6059b4146c0cc4933aa524178c02 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 12 Oct 2015 15:39:20 +0200 Subject: Univs: be more restrictive for template polymorphic constants: only direct aliases are ok, and indices should not be made polymorphic. Fixes NFix. --- kernel/inductive.ml | 5 +---- kernel/typeops.ml | 14 ++++++++++---- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index a02d5e2055..1f8706652f 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -165,10 +165,7 @@ let rec make_subst env = (* to be greater than the level of the argument; this is probably *) (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in - if Univ.Universe.is_levels s then - make (cons_subst u s subst) (sign, exp, args) - else (* Cannot handle substitution by i+n universes. *) - make subst (sign, exp, args) + make (cons_subst u s subst) (sign, exp, args) | (na,None,t)::sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) (* substitution (when [u] is distinct from all other universes in the *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index fe82d85d5d..8895bae5da 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -134,10 +134,16 @@ let extract_context_levels env l = let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = let params, ccl = dest_prod_assum env t in match kind_of_term ccl with - | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) -> - let param_ccls = extract_context_levels env params in - let s = { template_param_levels = param_ccls; template_level = u} in - TemplateArity (params,s) + | Sort (Type u) -> + let ind, l = decompose_app (whd_betadeltaiota env c) in + if isInd ind && List.is_empty l then + let mis = lookup_mind_specif env (fst (destInd ind)) in + let nparams = Inductive.inductive_params mis in + let paramsl = CList.lastn nparams params in + let param_ccls = extract_context_levels env paramsl in + let s = { template_param_levels = param_ccls; template_level = u} in + TemplateArity (params,s) + else RegularArity t | _ -> RegularArity t -- cgit v1.2.3 From 26974a4a2301cc7b1188a3f2f29f3d3368eccc0b Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 12 Oct 2015 16:34:33 +0200 Subject: Remove code that was already commented out. --- tactics/rewrite.ml | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 937ad2b9d4..6bd65d0a21 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -76,25 +76,6 @@ let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" let coq_all = find_global ["Init"; "Logic"] "all" let impl = find_global ["Program"; "Basics"] "impl" -(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *) - -(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *) - -(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *) -(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *) -(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *) -(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *) -(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *) -(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *) -(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *) -(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *) -(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *) - -(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *) -(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *) - - - (** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) -- cgit v1.2.3 From ed95f122f3c68becc09c653471dc2982b346d343 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 13 Oct 2015 18:30:47 +0200 Subject: Fix some typos. --- CHANGES | 2 +- INSTALL.ide | 2 +- dev/doc/univpoly.txt | 2 +- dev/v8-syntax/memo-v8.tex | 2 +- doc/faq/FAQ.tex | 16 ++++++++-------- doc/refman/Universes.tex | 6 +++--- doc/tools/Translator.tex | 2 +- ide/coq.mli | 6 +++--- ide/coqide.ml | 4 ++-- ide/utf8_convert.mll | 2 +- ide/wg_ScriptView.ml | 2 +- interp/implicit_quantifiers.mli | 2 +- kernel/nativecode.ml | 4 ++-- kernel/nativelambda.ml | 32 ++++++++++++++++---------------- lib/xml_parser.mli | 12 ++++++------ library/impargs.ml | 2 +- library/impargs.mli | 4 ++-- parsing/lexer.ml4 | 2 +- plugins/btauto/Algebra.v | 2 +- plugins/decl_mode/decl_proof_instr.ml | 2 +- plugins/extraction/CHANGES | 6 +++--- plugins/extraction/mlutil.ml | 14 +++++++------- plugins/funind/g_indfun.ml4 | 2 +- plugins/funind/glob_termops.mli | 4 ++-- plugins/funind/merge.ml | 2 +- plugins/micromega/mfourier.ml | 2 +- plugins/omega/coq_omega.ml | 6 +++--- plugins/romega/refl_omega.ml | 8 ++++---- pretyping/evarutil.ml | 2 +- pretyping/tacred.ml | 6 +++--- pretyping/termops.ml | 2 +- tactics/equality.ml | 4 ++-- tactics/equality.mli | 2 +- tactics/leminv.ml | 2 +- tactics/rewrite.ml | 2 +- test-suite/success/auto.v | 2 +- theories/Lists/List.v | 6 +++--- theories/Numbers/Cyclic/Int31/Int31.v | 2 +- theories/Numbers/NaryFunctions.v | 2 +- toplevel/vernacentries.ml | 2 +- 40 files changed, 93 insertions(+), 93 deletions(-) diff --git a/CHANGES b/CHANGES index cf2bb49271..07d129a462 100644 --- a/CHANGES +++ b/CHANGES @@ -2180,7 +2180,7 @@ Changes from V7.3.1 to V7.4 Symbolic notations - Introduction of a notion of scope gathering notations in a consistent set; - a notation sets has been developped for nat, Z and R (undocumented) + a notation sets has been developed for nat, Z and R (undocumented) - New command "Notation" for declaring notations simultaneously for parsing and printing (see chap 10 of the reference manual) - Declarations with only implicit arguments now handled (e.g. the diff --git a/INSTALL.ide b/INSTALL.ide index 13e741e340..6e41b2d051 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -119,5 +119,5 @@ TROUBLESHOOTING rid of the problem is to edit by hand your coqiderc (either /home//.config/coq/coqiderc under Linux, or C:\Documents and Settings\\.config\coq\coqiderc under Windows) - and replace any occurence of MOD4 by MOD1. + and replace any occurrence of MOD4 by MOD1. diff --git a/dev/doc/univpoly.txt b/dev/doc/univpoly.txt index 9e243eead5..6a69c57934 100644 --- a/dev/doc/univpoly.txt +++ b/dev/doc/univpoly.txt @@ -167,7 +167,7 @@ kernel/univ.ml was modified. The new API forces every universe to be declared before it is mentionned in any constraint. This forces to declare every universe to be >= Set or > Set. Every universe variable introduced during elaboration is >= Set. Every _global_ universe is now -declared explicitely > Set, _after_ typechecking the definition. In +declared explicitly > Set, _after_ typechecking the definition. In polymorphic definitions Type@{i} ranges over Set and any other universe j. However, at instantiation time for polymorphic references, one can try to instantiate a universe parameter with Prop as well, if the diff --git a/dev/v8-syntax/memo-v8.tex b/dev/v8-syntax/memo-v8.tex index 8d116de26f..ae4b569b36 100644 --- a/dev/v8-syntax/memo-v8.tex +++ b/dev/v8-syntax/memo-v8.tex @@ -253,7 +253,7 @@ became \TERM{context}. Syntax is unified with subterm matching. \subsection{Occurrences} To avoid ambiguity between a numeric literal and the optionnal -occurence numbers of this term, the occurence numbers are put after +occurrence numbers of this term, the occurrence numbers are put after the term itself. This applies to tactic \TERM{pattern} and also \TERM{unfold} \begin{transbox} diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex index fbb866e875..2eebac39ac 100644 --- a/doc/faq/FAQ.tex +++ b/doc/faq/FAQ.tex @@ -228,7 +228,7 @@ kernel is intentionally small to limit the risk of conceptual or accidental implementation bugs. \item[The Objective Caml compiler] The {\Coq} kernel is written using the Objective Caml language but it uses only the most standard features -(no object, no label ...), so that it is highly unprobable that an +(no object, no label ...), so that it is highly improbable that an Objective Caml bug breaks the consistency of {\Coq} without breaking all other kinds of features of {\Coq} or of other software compiled with Objective Caml. @@ -1497,7 +1497,7 @@ while {\assert} is. \Question{What can I do if \Coq can not infer some implicit argument ?} -You can state explicitely what this implicit argument is. See \ref{implicit}. +You can state explicitly what this implicit argument is. See \ref{implicit}. \Question{How can I explicit some implicit argument ?}\label{implicit} @@ -1632,7 +1632,7 @@ before comparing them, you risk to use a lot of time and space. On the contrary, a function for computing the greatest of two natural numbers is an algorithm which, called on two natural numbers -$n$ and $p$, determines wether $n\leq p$ or $p < n$. +$n$ and $p$, determines whether $n\leq p$ or $p < n$. Such a function is a \emph{decision procedure} for the inequality of \texttt{nat}. The possibility of writing such a procedure comes directly from de decidability of the order $\leq$ on natural numbers. @@ -1706,7 +1706,7 @@ immediate, whereas one can't wait for the result of This is normal. Your definition is a simple recursive function which returns a boolean value. Coq's \texttt{le\_lt\_dec} is a \emph{certified -function}, i.e. a complex object, able not only to tell wether $n\leq p$ +function}, i.e. a complex object, able not only to tell whether $n\leq p$ or $p/.config/coq/coqiderc| under Linux, or \\ \verb|C:\Documents and Settings\\.config\coq\coqiderc| under Windows) - and replace any occurence of \texttt{MOD4} by \texttt{MOD1}. +and replace any occurrence of \texttt{MOD4} by \texttt{MOD1}. @@ -2638,7 +2638,7 @@ existential variable which eventually got erased by some computation. You may backtrack to the faulty occurrence of {\eauto} or {\eapply} and give the missing argument an explicit value. Alternatively, you can use the commands \texttt{Show Existentials.} and -\texttt{Existential.} to display and instantiate the remainig +\texttt{Existential.} to display and instantiate the remaining existential variables. diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index 018d73908b..a03d5c7b20 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -182,8 +182,8 @@ bound if it is an atomic universe (i.e. not an algebraic max()). experimental and is likely to change in future versions. \end{flushleft} -The syntax has been extended to allow users to explicitely bind names to -universes and explicitely instantantiate polymorphic +The syntax has been extended to allow users to explicitly bind names to +universes and explicitly instantantiate polymorphic definitions. Currently, binding is implicit at the first occurrence of a universe name. For example, i and j below are introduced by the annotations attached to Types. @@ -202,7 +202,7 @@ definition, they just allow to specify locally what relations should hold. In the term and in general in proof mode, universe names introduced in the types can be refered to in terms. -Definitions can also be instantiated explicitely, giving their full instance: +Definitions can also be instantiated explicitly, giving their full instance: \begin{coq_example} Check (pidentity@{Set}). Check (le@{i j}). diff --git a/doc/tools/Translator.tex b/doc/tools/Translator.tex index 5f7b6dc951..ed1d336d9e 100644 --- a/doc/tools/Translator.tex +++ b/doc/tools/Translator.tex @@ -419,7 +419,7 @@ the hypotheses), or a comma-separated list of either hypothesis name, or {\tt (value of $H$)} or {\tt (type of $H$)}. Moreover, occurrences can be specified after every hypothesis after the {\TERM{at}} keyword. {\em concl} is either empty or \TERM{*}, and can be followed -by occurences. +by occurrences. \begin{transbox} \TRANS{in Goal}{in |- *} diff --git a/ide/coq.mli b/ide/coq.mli index a72c67b43e..2dc5ad3078 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -16,7 +16,7 @@ type coqtop Liveness management of coqtop is automatic. Whenever a coqtop dies abruptly, this module is responsible for relaunching the whole process. The reset handler set through [set_reset_handler] will be called after such an - abrupt failure. It is also called when explicitely requesting coqtop to + abrupt failure. It is also called when explicitly requesting coqtop to reset. *) type 'a task @@ -29,7 +29,7 @@ type 'a task ([is_computing] will answer [true]), and any other task submission will be rejected by [try_grab]. - Any exception occuring within the task will trigger a coqtop reset. + Any exception occurring within the task will trigger a coqtop reset. Beware, because of the GTK scheduler, you never know when a task will actually be executed. If you need to sequentialize imperative actions, you @@ -43,7 +43,7 @@ val bind : 'a task -> ('a -> 'b task) -> 'b task (** Monadic binding of tasks *) val lift : (unit -> 'a) -> 'a task -(** Return the impertative computation waiting to be processed. *) +(** Return the imperative computation waiting to be processed. *) val seq : unit task -> 'a task -> 'a task (** Sequential composition *) diff --git a/ide/coqide.ml b/ide/coqide.ml index c0e2281258..f15e5fa34a 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1125,10 +1125,10 @@ let build_ui () = ~accel:(prefs.modifier_for_navigation^"h");*) item "Previous" ~label:"_Previous" ~stock:`GO_BACK ~callback:Nav.previous_occ - ~tooltip:"Previous occurence" + ~tooltip:"Previous occurrence" ~accel:(prefs.modifier_for_navigation^"less"); item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ - ~tooltip:"Next occurence" + ~tooltip:"Next occurrence" ~accel:(prefs.modifier_for_navigation^"greater"); item "Force" ~label:"_Force" ~stock:`EXECUTE ~callback:Nav.join_document ~tooltip:"Fully check the document" diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll index 621833ddea..4ebf9a62e1 100644 --- a/ide/utf8_convert.mll +++ b/ide/utf8_convert.mll @@ -12,7 +12,7 @@ } -(* Replace all occurences of \x{iiii} and \x{iiiiiiii} by UTF-8 valid chars *) +(* Replace all occurrences of \x{iiii} and \x{iiiiiiii} by UTF-8 valid chars *) let digit = ['0'-'9''A'-'Z''a'-'z'] let short = digit digit digit digit diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 8298d9954f..ae50b28377 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -139,7 +139,7 @@ object(self) (** We don't care about atomicity. Return: 1. `OK when there was no error, `FAIL otherwise - 2. `NOOP if no write occured, `WRITE otherwise + 2. `NOOP if no write occurred, `WRITE otherwise *) method private process_action = function | Insert ins -> diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index a3721af660..eee9289892 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -28,7 +28,7 @@ val free_vars_of_binders : ?bound:Id.Set.t -> Id.t list -> local_binder list -> Id.Set.t * Id.t list (** Returns the generalizable free ids in left-to-right - order with the location of their first occurence *) + order with the location of their first occurrence *) val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t -> glob_constr -> (Id.t * Loc.t) list diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 687b740f67..98b2d6d2e9 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -481,7 +481,7 @@ and eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 = in Array.equal eq_branch br1 br2 -(* hash_mllambda gn n env t computes the hash for t ignoring occurences of gn *) +(* hash_mllambda gn n env t computes the hash for t ignoring occurrences of gn *) let rec hash_mllambda gn n env t = match t with | MLlocal ln -> combinesmall 1 (LNmap.find ln env) @@ -979,7 +979,7 @@ let compile_prim decl cond paux = let args = Array.map opt_prim_aux args in app_prim (Coq_primitive(op,None)) args (* - TODO: check if this inling was useful + TODO: check if this inlining was useful begin match op with | Int31lt -> if Sys.word_size = 64 then diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index cb08b5058f..263befd213 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -277,7 +277,7 @@ and reduce_lapp substf lids body substa largs = | [], _::_ -> simplify_app substf body substa (Array.of_list largs) -(* [occurence kind k lam]: +(* [occurrence kind k lam]: If [kind] is [true] return [true] if the variable [k] does not appear in [lam], return [false] if the variable appear one time and not under a lambda, a fixpoint, a cofixpoint; else raise Not_found. @@ -285,7 +285,7 @@ and reduce_lapp substf lids body substa largs = else raise [Not_found] *) -let rec occurence k kind lam = +let rec occurrence k kind lam = match lam with | Lrel (_,n) -> if Int.equal n k then @@ -294,35 +294,35 @@ let rec occurence k kind lam = | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind | Lprod(dom, codom) -> - occurence k (occurence k kind dom) codom + occurrence k (occurrence k kind dom) codom | Llam(ids,body) -> - let _ = occurence (k+Array.length ids) false body in kind + let _ = occurrence (k+Array.length ids) false body in kind | Llet(_,def,body) -> - occurence (k+1) (occurence k kind def) body + occurrence (k+1) (occurrence k kind def) body | Lapp(f, args) -> - occurence_args k (occurence k kind f) args + occurrence_args k (occurrence k kind f) args | Lprim(_,_,_,args) | Lmakeblock(_,_,_,args) -> - occurence_args k kind args + occurrence_args k kind args | Lcase(_,t,a,br) -> - let kind = occurence k (occurence k kind t) a in + let kind = occurrence k (occurrence k kind t) a in let r = ref kind in Array.iter (fun (_,ids,c) -> - r := occurence (k+Array.length ids) kind c && !r) br; + r := occurrence (k+Array.length ids) kind c && !r) br; !r | Lif (t, bt, bf) -> - let kind = occurence k kind t in - kind && occurence k kind bt && occurence k kind bf + let kind = occurrence k kind t in + kind && occurrence k kind bt && occurrence k kind bf | Lfix(_,(ids,ltypes,lbodies)) | Lcofix(_,(ids,ltypes,lbodies)) -> - let kind = occurence_args k kind ltypes in - let _ = occurence_args (k+Array.length ids) false lbodies in + let kind = occurrence_args k kind ltypes in + let _ = occurrence_args (k+Array.length ids) false lbodies in kind -and occurence_args k kind args = - Array.fold_left (occurence k) kind args +and occurrence_args k kind args = + Array.fold_left (occurrence k) kind args let occur_once lam = - try let _ = occurence 1 true lam in true + try let _ = occurrence 1 true lam in true with Not_found -> false (* [remove_let lam] remove let expression in [lam] if the variable is *) diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli index cefb4af897..87ef787770 100644 --- a/lib/xml_parser.mli +++ b/lib/xml_parser.mli @@ -36,10 +36,10 @@ type t (** Several exceptions can be raised when parsing an Xml document : {ul {li {!Xml.Error} is raised when an xml parsing error occurs. the - {!Xml.error_msg} tells you which error occured during parsing + {!Xml.error_msg} tells you which error occurred during parsing and the {!Xml.error_pos} can be used to retreive the document - location where the error occured at.} - {li {!Xml.File_not_found} is raised when and error occured while + location where the error occurred at.} + {li {!Xml.File_not_found} is raised when and error occurred while opening a file with the {!Xml.parse_file} function.} } *) @@ -71,13 +71,13 @@ val error : error -> string (** Get the Xml error message as a string. *) val error_msg : error_msg -> string -(** Get the line the error occured at. *) +(** Get the line the error occurred at. *) val line : error_pos -> int -(** Get the relative character range (in current line) the error occured at.*) +(** Get the relative character range (in current line) the error occurred at.*) val range : error_pos -> int * int -(** Get the absolute character range the error occured at. *) +(** Get the absolute character range the error occurred at. *) val abs_range : error_pos -> int * int val pos : Lexing.lexbuf -> error_pos diff --git a/library/impargs.ml b/library/impargs.ml index 94f53219e7..d15a02fea2 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -104,7 +104,7 @@ let set_maximality imps b = inferable following a rigid path (useful to know how to print a partial application) -- [Manual] means the argument has been explicitely set as implicit. +- [Manual] means the argument has been explicitly set as implicit. We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. diff --git a/library/impargs.mli b/library/impargs.mli index 1d3a73e94c..30f2e30f97 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -59,8 +59,8 @@ type implicit_explanation = inferable following a rigid path (useful to know how to print a partial application) *) | Manual - (** means the argument has been explicitely set as implicit. *) - + (** means the argument has been explicitly set as implicit. *) + (** We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. *) diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 8e83929619..c6d5f3b925 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -70,7 +70,7 @@ let ttree_remove ttree str = remove ttree 0 -(* Errors occuring while lexing (explained as "Lexer error: ...") *) +(* Errors occurring while lexing (explained as "Lexer error: ...") *) module Error = struct diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index bc5a390027..ee7341a4a2 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -283,7 +283,7 @@ end. (** Quotienting a polynomial by the relation X_i^2 ~ X_i *) -(* Remove the multiple occurences of monomials x_k *) +(* Remove the multiple occurrences of monomials x_k *) Fixpoint reduce_aux k p := match p with diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 714cd86341..1a90806476 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -212,7 +212,7 @@ let close_previous_case pts = Proof.is_done pts then match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occured ...") + Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occurred ...") | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus () | _ -> error "Not inside a proof per cases or induction." diff --git a/plugins/extraction/CHANGES b/plugins/extraction/CHANGES index fbcd01a15e..cf97ae3ab8 100644 --- a/plugins/extraction/CHANGES +++ b/plugins/extraction/CHANGES @@ -193,7 +193,7 @@ beginning of files. Possible clashes are dealt with. in extracted code. -* A few constants are explicitely declared to be inlined in extracted code. +* A few constants are explicitly declared to be inlined in extracted code. For the moment there are: Wf.Acc_rec Wf.Acc_rect @@ -234,12 +234,12 @@ Those two commands enable a precise control of what is inlined and what is not. Print Extraction Inline. -Sum up the current state of the table recording the custom inlings +Sum up the current state of the table recording the custom inlinings (Extraction (No)Inline). Reset Extraction Inline. -Put the table recording the custom inlings back to empty. +Put the table recording the custom inlinings back to empty. As a consequence, there is no more need for options inside the commands of extraction: diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 9fdb0205f5..6fc1195fba 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -490,8 +490,8 @@ let ast_occurs_itvl k k' t = ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false with Found -> true -(* Number of occurences of [Rel 1] in [t], with special treatment of match: - occurences in different branches aren't added, but we rather use max. *) +(* Number of occurrences of [Rel 1] in [t], with special treatment of match: + occurrences in different branches aren't added, but we rather use max. *) let nb_occur_match = let rec nb k = function @@ -851,7 +851,7 @@ let factor_branches o typ br = else Some (br_factor, br_set) end -(*s If all branches are functions, try to permut the case and the functions. *) +(*s If all branches are functions, try to permute the case and the functions. *) let rec merge_ids ids ids' = match ids,ids' with | [],l -> l @@ -1127,7 +1127,7 @@ let term_expunge s (ids,c) = MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*s [kill_dummy_args ids r t] looks for occurences of [MLrel r] in [t] and +(*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and purge the args of [MLrel r] corresponding to a [dummy_name]. It makes eta-expansion if needed. *) @@ -1351,10 +1351,10 @@ let is_not_strict t = We expand small terms with at least one non-strict variable (i.e. a variable that may not be evaluated). - Futhermore we don't expand fixpoints. + Furthermore we don't expand fixpoints. - Moreover, as mentionned by X. Leroy (bug #2241), - inling a constant from inside an opaque module might + Moreover, as mentioned by X. Leroy (bug #2241), + inlining a constant from inside an opaque module might break types. To avoid that, we require below that both [r] and its body are globally visible. This isn't fully satisfactory, since [r] might not be visible (functor), diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index bc7e6f8b09..e7732a5037 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -379,7 +379,7 @@ let find_fapp (test:constr -> bool) g : fapp_info list = (** [finduction id filter g] tries to apply functional induction on - an occurence of function [id] in the conclusion of goal [g]. If + an occurrence of function [id] in the conclusion of goal [g]. If [id]=[None] then calls to any function are selected. In any case [heuristic] is used to select the most pertinent occurrence. *) let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 0f10636f0f..179e8fe8d9 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -6,7 +6,7 @@ open Misctypes val get_pattern_id : cases_pattern -> Id.t list (* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. - [pat] must not contain occurences of anonymous pattern + [pat] must not contain occurrences of anonymous pattern *) val pattern_to_term : cases_pattern -> glob_constr @@ -64,7 +64,7 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create - a fresh variable for each occurence of the anonymous pattern. + a fresh variable for each occurrence of the anonymous pattern. Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 69e055c23b..60c58730a3 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -902,7 +902,7 @@ let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = (** [merge id1 id2 args1 args2 id] builds and declares a new inductive type called [id], representing the merged graphs of both graphs - [ind1] and [ind2]. identifiers occuring in both arrays [args1] and + [ind1] and [ind2]. identifiers occurring in both arrays [args1] and [args2] are considered linked (i.e. are the same variable) in the new graph. diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 88c1a78366..a36369d220 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -23,7 +23,7 @@ struct - None , Some v -> \]-oo,v\] - Some v, None -> \[v,+oo\[ - Some v, Some v' -> \[v,v'\] - Intervals needs to be explicitely normalised. + Intervals needs to be explicitly normalised. *) type who = Left | Right diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 710a2394d3..aac9a7d315 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -539,7 +539,7 @@ let context operation path (t : constr) = in loop 1 path t -let occurence path (t : constr) = +let occurrence path (t : constr) = let rec loop p0 t = match (p0,kind_of_term t) with | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t @@ -555,7 +555,7 @@ let occurence path (t : constr) = | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> - failwith ("occurence " ^ string_of_int(List.length p)) + failwith ("occurrence " ^ string_of_int(List.length p)) in loop path t @@ -660,7 +660,7 @@ let clever_rewrite_gen_nat p result (t,args) = let clever_rewrite p vpath t gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in - let vargs = List.map (fun p -> occurence p occ) vpath in + let vargs = List.map (fun p -> occurrence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in exact (applist(t',[mkNewMeta()])) gl diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 8156e84114..95407c5ff1 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -44,7 +44,7 @@ let occ_step_eq s1 s2 = match s1, s2 with (* chemin identifiant une proposition sous forme du nom de l'hypothèse et d'une liste de pas à partir de la racine de l'hypothèse *) -type occurence = {o_hyp : Names.Id.t; o_path : occ_path} +type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} (* \subsection{refiable formulas} *) type oformula = @@ -81,7 +81,7 @@ and oequation = { e_left: oformula; (* formule brute gauche *) e_right: oformula; (* formule brute droite *) e_trace: Term.constr; (* tactique de normalisation *) - e_origin: occurence; (* l'hypothèse dont vient le terme *) + e_origin: occurrence; (* l'hypothèse dont vient le terme *) e_negated: bool; (* vrai si apparait en position nié après normalisation *) e_depends: direction list; (* liste des points de disjonction dont @@ -111,7 +111,7 @@ type environment = { real_indices : (int,int) Hashtbl.t; mutable cnt_connectors : int; equations : (int,oequation) Hashtbl.t; - constructors : (int, occurence) Hashtbl.t + constructors : (int, occurrence) Hashtbl.t } (* \subsection{Solution tree} @@ -136,7 +136,7 @@ type solution_tree = chemins pour extraire des equations ou d'hypothèses *) type context_content = - CCHyp of occurence + CCHyp of occurrence | CCEqua of int (* \section{Specific utility functions to handle base types} *) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 8ebb037c24..d3d6901b66 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -525,7 +525,7 @@ let rec check_and_clear_in_constr env evdref err ids c = let clear_hyps_in_evi_main env evdref hyps terms ids = (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some hypothesis does not depend on a element of ids, and erases ids in - the contexts of the evars occuring in evi *) + the contexts of the evars occurring in evi *) let terms = List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in let nhyps = diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 8a5db90590..48911a5a9f 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1011,8 +1011,8 @@ let contextually byhead occs f env sigma t = snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. - * n is the number of the next occurence of name. - * ol is the occurence list to find. *) + * n is the number of the next occurrence of name. + * ol is the occurrence list to find. *) let match_constr_evaluable_ref sigma c evref = match kind_of_term c, evref with @@ -1061,7 +1061,7 @@ let is_projection env = function (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)] * Unfolds the constant name in a term c following a list of occurrences occl. - * at the occurrences of occ_list. If occ_list is empty, unfold all occurences. + * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences. * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = let unfo nowhere_except_in locs = diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 937471cf76..5a55d47fd1 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -561,7 +561,7 @@ let free_rels m = in frec 1 Int.Set.empty m -(* collects all metavar occurences, in left-to-right order, preserving +(* collects all metavar occurrences, in left-to-right order, preserving * repetitions and all. *) let collect_metas c = diff --git a/tactics/equality.ml b/tactics/equality.ml index c442178c10..5ed9ac2ba0 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -88,7 +88,7 @@ type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool type conditions = - | Naive (* Only try the first occurence of the lemma (default) *) + | Naive (* Only try the first occurrence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) @@ -1577,7 +1577,7 @@ let restrict_to_eq_and_identity eq = (* compatibility *) exception FoundHyp of (Id.t * constr * bool) -(* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *) +(* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x (id,_,c) = try let c = pf_nf_evar gl c in diff --git a/tactics/equality.mli b/tactics/equality.mli index 3e13ee570c..840ede7d9f 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -23,7 +23,7 @@ type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool type conditions = - | Naive (* Only try the first occurence of the lemma (default) *) + | Naive (* Only try the first occurrence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index efd6ded44c..42d22bc3c4 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -124,7 +124,7 @@ let rec add_prods_sign env sigma t = add_prods_sign (push_named (id,Some c1,t1) env) sigma b' | _ -> (env,t) -(* [dep_option] indicates wether the inversion lemma is dependent or not. +(* [dep_option] indicates whether the inversion lemma is dependent or not. If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) where P:(x_bar:T_bar)(H:(I x_bar))[sort]. diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 6bd65d0a21..0811708695 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1386,7 +1386,7 @@ module Strategies = end -(** The strategy for a single rewrite, dealing with occurences. *) +(** The strategy for a single rewrite, dealing with occurrences. *) (** A dummy initial clauseenv to avoid generating initial evars before even finding a first application of the rewriting lemma, in setoid_rewrite diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index db3b19af51..aaa7b3a514 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -1,6 +1,6 @@ (* Wish #2154 by E. van der Weegen *) -(* auto was not using f_equal-style lemmas with metavariables occuring +(* auto was not using f_equal-style lemmas with metavariables occurring only in the type of an evar of the concl, but not directly in the concl itself *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index e0e5d94d82..0ace6938b9 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -622,9 +622,9 @@ Section Elts. Qed. - (****************************************) - (** ** Counting occurences of a element *) - (****************************************) + (******************************************) + (** ** Counting occurrences of an element *) + (******************************************) Fixpoint count_occ (l : list A) (x : A) : nat := match l with diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 4e28b5b905..f5e936cf01 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -19,7 +19,7 @@ Require Export DoubleType. arithmetic. In fact it is more general than that. The only reason for this use of 31 is the underlying mecanism for hardware-efficient computations by A. Spiwack. Apart from this, a switch to, say, - 63-bit integers is now just a matter of replacing every occurences + 63-bit integers is now just a matter of replacing every occurrences of 31 by 63. This is actually made possible by the use of dependently-typed n-ary constructions for the inductive type [int31], its constructor [I31] and any pattern matching on it. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index 6fdf0a2a5b..376620ddcd 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -15,7 +15,7 @@ Require Import List. (** * Generic dependently-typed operators about [n]-ary functions *) (** The type of [n]-ary function: [nfun A n B] is - [A -> ... -> A -> B] with [n] occurences of [A] in this type. *) + [A -> ... -> A -> B] with [n] occurrences of [A] in this type. *) Fixpoint nfun A n B := match n with diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 35730eea03..48100aa7fd 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1359,7 +1359,7 @@ let _ = declare_int_option { optsync = true; optdepr = false; - optname = "the level of inling duging functor application"; + optname = "the level of inlining during functor application"; optkey = ["Inline";"Level"]; optread = (fun () -> Some (Flags.get_inline_level ())); optwrite = (fun o -> -- cgit v1.2.3 From f617aeef08441e83b13f839ce767b840fddbcf7d Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 14 Oct 2015 10:39:55 +0200 Subject: Fix some typos. --- doc/faq/FAQ.tex | 4 ++-- doc/refman/Universes.tex | 6 +++--- kernel/byterun/coq_interp.c | 2 +- lib/xml_parser.mli | 6 +++--- parsing/pcoq.ml4 | 6 +++--- theories/Lists/List.v | 2 +- 6 files changed, 13 insertions(+), 13 deletions(-) diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex index 2eebac39ac..48b61827d1 100644 --- a/doc/faq/FAQ.tex +++ b/doc/faq/FAQ.tex @@ -710,7 +710,7 @@ There are also ``simple enough'' propositions for which you can prove the equality without requiring any extra axioms. This is typically the case for propositions defined deterministically as a first-order inductive predicate on decidable sets. See for instance in question -\ref{le-uniqueness} an axiom-free proof of the unicity of the proofs of +\ref{le-uniqueness} an axiom-free proof of the uniqueness of the proofs of the proposition {\tt le m n} (less or equal on {\tt nat}). % It is an ongoing work of research to natively include proof @@ -1625,7 +1625,7 @@ Fail Definition max (n p : nat) := if n <= p then p else n. As \Coq~ says, the term ``~\texttt{n <= p}~'' is a proposition, i.e. a statement that belongs to the mathematical world. There are many ways to prove such a proposition, either by some computation, or using some already -proven theoremas. For instance, proving $3-2 \leq 2^{45503}$ is very easy, +proven theorems. For instance, proving $3-2 \leq 2^{45503}$ is very easy, using some theorems on arithmetical operations. If you compute both numbers before comparing them, you risk to use a lot of time and space. diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index a03d5c7b20..cd8222269d 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -183,7 +183,7 @@ bound if it is an atomic universe (i.e. not an algebraic max()). \end{flushleft} The syntax has been extended to allow users to explicitly bind names to -universes and explicitly instantantiate polymorphic +universes and explicitly instantiate polymorphic definitions. Currently, binding is implicit at the first occurrence of a universe name. For example, i and j below are introduced by the annotations attached to Types. @@ -200,7 +200,7 @@ we are using $A : Type@{i} <= Type@{j}$, hence the generated constraint. Note that the names here are not bound in the final definition, they just allow to specify locally what relations should hold. In the term and in general in proof mode, universe names -introduced in the types can be refered to in terms. +introduced in the types can be referred to in terms. Definitions can also be instantiated explicitly, giving their full instance: \begin{coq_example} @@ -209,7 +209,7 @@ Check (le@{i j}). \end{coq_example} User-named universes are considered rigid for unification and are never -miminimized. +minimized. Finally, two commands allow to name \emph{global} universes and constraints. diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 399fa843f1..1653c3b012 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -1271,7 +1271,7 @@ value coq_interprete Instruct (COMPAREINT31) { /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ - /* assumes Inudctive _ : _ := Eq | Lt | Gt */ + /* assumes Inductive _ : _ := Eq | Lt | Gt */ print_instr("COMPAREINT31"); if ((uint32_t)accu == (uint32_t)*sp) { accu = 1; /* 2*0+1 */ diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli index 87ef787770..ac2eab352f 100644 --- a/lib/xml_parser.mli +++ b/lib/xml_parser.mli @@ -37,9 +37,9 @@ type t (** Several exceptions can be raised when parsing an Xml document : {ul {li {!Xml.Error} is raised when an xml parsing error occurs. the {!Xml.error_msg} tells you which error occurred during parsing - and the {!Xml.error_pos} can be used to retreive the document + and the {!Xml.error_pos} can be used to retrieve the document location where the error occurred at.} - {li {!Xml.File_not_found} is raised when and error occurred while + {li {!Xml.File_not_found} is raised when an error occurred while opening a file with the {!Xml.parse_file} function.} } *) @@ -98,7 +98,7 @@ val make : source -> t in the original Xmllight)}. *) val check_eof : t -> bool -> unit -(** Once the parser is configurated, you can run the parser on a any kind +(** Once the parser is configured, you can run the parser on a any kind of xml document source to parse its contents into an Xml data structure. When [do_not_canonicalize] is set, the XML document is given as diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 797b031fe4..2e47e07a36 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -298,7 +298,7 @@ module Prim = struct let gec_gen x = make_gen_entry uprim x - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) (* Typically for tactic or vernac extensions *) let preident = gec_gen (rawwit wit_pre_ident) "preident" let ident = gec_gen (rawwit wit_ident) "ident" @@ -334,7 +334,7 @@ module Constr = struct let gec_constr = make_gen_entry uconstr (rawwit wit_constr) - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) let constr = gec_constr "constr" let operconstr = gec_constr "operconstr" let constr_eoi = eoi_entry constr @@ -367,7 +367,7 @@ module Tactic = (* Main entry for extensions *) let simple_tactic = Gram.entry_create "tactic:simple_tactic" - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) (* Typically for tactic user extensions *) let open_constr = make_gen_entry utactic (rawwit wit_open_constr) "open_constr" diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 0ace6938b9..fe18686e21 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -69,7 +69,7 @@ Section Facts. Variable A : Type. - (** *** Genereric facts *) + (** *** Generic facts *) (** Discrimination *) Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l. -- cgit v1.2.3 From 4a1234459472c5fbb0d0467217972f247c054832 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 14 Oct 2015 10:44:44 +0200 Subject: Remove some unused variables. --- kernel/byterun/coq_interp.c | 2 -- kernel/byterun/coq_memory.c | 2 -- kernel/byterun/coq_values.c | 1 - 3 files changed, 5 deletions(-) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 1653c3b012..33253ed93c 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -844,7 +844,6 @@ value coq_interprete } Instruct(SETFIELD1){ - int i, j, size, size_aux; print_instr("SETFIELD1"); caml_modify(&Field(accu, 1),*sp); sp++; @@ -1110,7 +1109,6 @@ value coq_interprete /* returns the sum plus one with a carry */ uint32_t s; s = (uint32_t)accu + (uint32_t)*sp++ + 1; - value block; if( (uint32_t)s <= (uint32_t)accu ) { /* carry */ Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 416e5e5329..c9bcdc32ff 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -103,7 +103,6 @@ static int coq_vm_initialized = 0; value init_coq_vm(value unit) /* ML */ { - int i; if (coq_vm_initialized == 1) { fprintf(stderr,"already open \n");fflush(stderr);} else { @@ -135,7 +134,6 @@ void realloc_coq_stack(asize_t required_space) { asize_t size; value * new_low, * new_high, * new_sp; - value * p; size = coq_stack_high - coq_stack_low; do { size *= 2; diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c index 007f61b27c..528babebfc 100644 --- a/kernel/byterun/coq_values.c +++ b/kernel/byterun/coq_values.c @@ -21,7 +21,6 @@ value coq_kind_of_closure(value v) { opcode_t * c; - int res; int is_app = 0; c = Code_val(v); if (Is_instruction(c, GRAB)) return Val_int(0); -- cgit v1.2.3 From bc1c530550e7d06655d541c21859321a2f84c260 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 14 Oct 2015 11:33:01 +0200 Subject: Make interpreter of PROJ simpler by not using the stack. --- kernel/byterun/coq_interp.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 33253ed93c..0553a5ed7e 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -883,19 +883,17 @@ value coq_interprete Instruct(PROJ){ print_instr("PROJ"); if (Is_accu (accu)) { + value block; /* Skip over the index of projected field */ pc++; - /* Save the argument on the stack */ - *--sp = accu; /* Create atom */ - Alloc_small(accu, 2, ATOM_PROJ_TAG); - Field(accu, 0) = Field(coq_global_data, *pc); - Field(accu, 1) = sp[0]; - sp[0] = accu; + Alloc_small(block, 2, ATOM_PROJ_TAG); + Field(block, 0) = Field(coq_global_data, *pc); + Field(block, 1) = accu; /* Create accumulator */ Alloc_small(accu, 2, Accu_tag); Code_val(accu) = accumulate; - Field(accu,1) = *sp++; + Field(accu, 1) = block; } else { accu = Field(accu, *pc++); } -- cgit v1.2.3 From d024277d485e3b6a70c217be965063a66aeffefe Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 14 Oct 2015 11:24:32 +0200 Subject: Fixing bug #4367: Wrong error message in unification. --- toplevel/himsg.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 7a3bcfba80..8efc36df72 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -783,7 +783,7 @@ let explain_pretype_error env sigma err = let {uj_val = c; uj_type = actty} = j in let (env, c, actty, expty), e = contract3' env c actty t e in let j = {uj_val = c; uj_type = actty} in - explain_actual_type env sigma j t (Some e) + explain_actual_type env sigma j expty (Some e) | UnifOccurCheck (ev,rhs) -> explain_occur_check env sigma ev rhs | UnsolvableImplicit (evk,exp) -> explain_unsolvable_implicit env sigma evk exp | VarNotFound id -> explain_var_not_found env id -- cgit v1.2.3 From 043d67c93111328fdbc2d7afa1a84daf3d68a5cc Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 14 Oct 2015 13:41:00 +0200 Subject: Remove unused infos structure in VM. Became unused after c47b205206d832430fa80a3386be80149e281d33. --- kernel/vconv.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 8af2efc588..2cbc102021 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -40,8 +40,6 @@ let conv_vect fconv vect1 vect2 cu = !rcu else raise NotConvertible -let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) - let rec conv_val env pb k v1 v2 cu = if v1 == v2 then cu else conv_whd env pb k (whd_val v1) (whd_val v2) cu @@ -219,7 +217,6 @@ and conv_eq_vect env vt1 vt2 cu = else raise NotConvertible let vconv pb env t1 t2 = - infos := create_clos_infos betaiotazeta env; let _cu = try conv_eq env pb t1 t2 (universes env) with NotConvertible -> -- cgit v1.2.3 From f45a88ad054b88792ec8cc6631e4d4015fa95bab Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 14 Oct 2015 13:45:06 +0200 Subject: Remove -vm flag of coqtop. Used to replace the standard conversion by the VM. Not so useful, and implemented using a bunch of references inside and outside the kernel. --- kernel/vconv.ml | 11 ----------- kernel/vconv.mli | 2 -- toplevel/coqtop.ml | 9 --------- toplevel/vernacentries.ml | 9 --------- 4 files changed, 31 deletions(-) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 2cbc102021..27e184ea3f 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -227,14 +227,3 @@ let vconv pb env t1 t2 = in () let _ = Reduction.set_vm_conv vconv - -let use_vm = ref false - -let set_use_vm b = - use_vm := b; - if b then Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> vconv cv_pb) - else Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> Reduction.conv_cmp cv_pb) - -let use_vm _ = !use_vm - - diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 096d31ac81..1a29a4d518 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -12,8 +12,6 @@ open Reduction (********************************************************************** s conversion functions *) -val use_vm : unit -> bool -val set_use_vm : bool -> unit val vconv : conv_pb -> types conversion_function val val_of_constr : env -> constr -> values diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8925bbe299..72966a4add 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -233,13 +233,6 @@ let compile_files () = compile_file vf) (List.rev l) -(*s options for the virtual machine *) - -let use_vm = ref false - -let set_vm_opt () = - Vconv.set_use_vm !use_vm - (** Options for proof general *) let set_emacs () = @@ -547,7 +540,6 @@ let parse_args arglist = |"-unicode" -> add_require "Utf8_core" |"-v"|"--version" -> Usage.version (exitcode ()) |"-verbose-compat-notations" -> verb_compat_ntn := true - |"-vm" -> use_vm := true |"-where" -> print_where := true (* Deprecated options *) @@ -607,7 +599,6 @@ let init arglist = if_verbose print_header (); inputstate (); Mltop.init_known_plugins (); - set_vm_opt (); engage (); (* Be careful to set these variables after the inputstate *) Syntax_def.set_verbose_compat_notations !verb_compat_ntn; diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 48100aa7fd..f1f87ca9b1 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1346,15 +1346,6 @@ let _ = optread = Flags.is_universe_polymorphism; optwrite = Flags.make_universe_polymorphism } -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "use of virtual machine inside the kernel"; - optkey = ["Virtual";"Machine"]; - optread = (fun () -> Vconv.use_vm ()); - optwrite = (fun b -> Vconv.set_use_vm b) } - let _ = declare_int_option { optsync = true; -- cgit v1.2.3 From 0f74b3df6e64dc069e53c4afcd6f46129b211d09 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 14 Oct 2015 13:50:55 +0200 Subject: Remove reference to default conversion function inside the kernel. --- kernel/reduction.ml | 7 +------ kernel/reduction.mli | 1 - 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index b09367dd92..68783780d3 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -738,14 +738,9 @@ let vm_conv cv_pb env t1 t2 = (* If compilation fails, fall-back to closure conversion *) fconv cv_pb false (fun _->None) env t1 t2 - -let default_conv = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None)) - -let set_default_conv f = default_conv := f - let default_conv cv_pb ?(l2r=false) env t1 t2 = try - !default_conv ~l2r cv_pb env t1 t2 + fconv cv_pb l2r (fun _ -> None) env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) fconv cv_pb false (fun _->None) env t1 t2 diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 6ced5c4985..90c008b19d 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -93,7 +93,6 @@ val set_nat_conv : (conv_pb -> Nativelambda.evars -> types conversion_function) -> unit val native_conv : conv_pb -> Nativelambda.evars -> types conversion_function -val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit val default_conv : conv_pb -> ?l2r:bool -> types conversion_function val default_conv_leq : ?l2r:bool -> types conversion_function -- cgit v1.2.3 From 4b8155591be6e20505ee25f7199edcf44a638c7e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 14 Oct 2015 14:38:22 +0200 Subject: Fixing evarmap implementation. --- pretyping/evd.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 3d912ca4ce..1107c2951e 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -750,7 +750,7 @@ let cmap f evd = { evd with metas = Metamap.map (map_clb f) evd.metas; defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; - undf_evars = EvMap.map (map_evar_info f) evd.defn_evars + undf_evars = EvMap.map (map_evar_info f) evd.undf_evars } (* spiwack: deprecated *) -- cgit v1.2.3 From 36f669f769fa23eb897adfa0450875a3c0db3476 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 14 Oct 2015 12:01:38 +0200 Subject: Exporting the original unprocessed hint in the hint running function. --- plugins/firstorder/sequent.ml | 1 + tactics/auto.ml | 1 + tactics/auto.mli | 4 ++-- tactics/class_tactics.ml | 2 ++ tactics/eauto.ml4 | 2 ++ tactics/hints.ml | 30 +++++++++++++++++------------- tactics/hints.mli | 5 +++-- 7 files changed, 28 insertions(+), 17 deletions(-) diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 96c4eb01eb..a77af03dc1 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -212,6 +212,7 @@ let extend_with_auto_hints l seq gl= match repr_hint p_a_t.code with Res_pf (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> + let (c, _, _) = c in (try let gr = global_of_constr c in let typ=(pf_unsafe_type_of gl c) in diff --git a/tactics/auto.ml b/tactics/auto.ml index e5fdf6a7c2..72c28ce323 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -93,6 +93,7 @@ let unify_resolve_gen poly = function | Some flags -> unify_resolve poly flags let exact poly (c,clenv) = + let (c, _, _) = c in let ctx, c' = if poly then let evd', subst = Evd.refresh_undefined_universes clenv.evd in diff --git a/tactics/auto.mli b/tactics/auto.mli index 8dacc13629..6e2acf7f56 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -26,9 +26,9 @@ val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> unit Proofview.tactic +val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic -val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> unit Proofview.tactic +val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic (** [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index ed5b783f6c..36b60385d8 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -141,6 +141,7 @@ let progress_evars t = let e_give_exact flags poly (c,clenv) gl = + let (c, _, _) = c in let c, gl = if poly then let clenv', subst = Clenv.refresh_undefined_univs clenv in @@ -166,6 +167,7 @@ let unify_resolve poly flags (c,clenv) gls = (Clenvtac.clenv_refine false ~with_classes:false clenv') gls let clenv_of_prods poly nprods (c, clenv) gls = + let (c, _, _) = c in if poly || Int.equal nprods 0 then Some clenv else let ty = pf_unsafe_type_of gls c in diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index b6b18719c0..09c5fa873f 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -118,6 +118,7 @@ open Unification let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) let unify_e_resolve poly flags (c,clenv) gls = + let (c, _, _) = c in let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv else clenv, Univ.empty_level_subst in let clenv' = connect_clenv gls clenv' in @@ -134,6 +135,7 @@ let hintmap_of hdc concl = (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = + let (c, _, _) = c in let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv else clenv, Univ.empty_level_subst diff --git a/tactics/hints.ml b/tactics/hints.ml index 9faa96a806..96c7d79ca5 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -97,7 +97,9 @@ type 'a with_uid = { uid : KerName.t; } -type hint = (constr * clausenv) hint_ast with_uid +type raw_hint = constr * types * Univ.universe_context_set + +type hint = (raw_hint * clausenv) hint_ast with_uid type 'a with_metadata = { pri : int; (* A number lower is higher priority *) @@ -110,7 +112,7 @@ type 'a with_metadata = { type full_hint = hint with_metadata type hint_entry = global_reference option * - (constr * types * Univ.universe_context_set) hint_ast with_uid with_metadata + raw_hint hint_ast with_uid with_metadata type import_level = [ `LAX | `WARN | `STRICT ] @@ -267,7 +269,7 @@ let strip_params env c = | _ -> c let instantiate_hint env sigma p = - let mk_clenv c cty ctx = + let mk_clenv (c, cty, ctx) = let sigma = Evd.merge_context_set univ_flexible sigma ctx in let cl = mk_clenv_from_env env sigma None (c,cty) in {cl with templval = @@ -275,11 +277,11 @@ let instantiate_hint env sigma p = env = empty_env} in let code = match p.code.obj with - | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx) - | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx) - | Res_pf_THEN_trivial_fail (c, cty, ctx) -> - Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx) - | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx) + | Res_pf c -> Res_pf (c, mk_clenv c) + | ERes_pf c -> ERes_pf (c, mk_clenv c) + | Res_pf_THEN_trivial_fail c -> + Res_pf_THEN_trivial_fail (c, mk_clenv c) + | Give_exact c -> Give_exact (c, mk_clenv c) | Unfold_nth e -> Unfold_nth e | Extern t -> Extern t in @@ -1205,12 +1207,14 @@ let make_db_list dbnames = (* Functions for printing the hints *) (**************************************************************************) +let pr_hint_elt (c, _, _) = pr_constr c + let pr_hint h = match h.obj with - | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) - | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) - | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c) - | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"apply " ++ pr_constr c ++ str" ; trivial") + | Res_pf (c, _) -> (str"apply " ++ pr_hint_elt c) + | ERes_pf (c, _) -> (str"eapply " ++ pr_hint_elt c) + | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) + | Res_pf_THEN_trivial_fail (c, _) -> + (str"apply " ++ pr_hint_elt c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = diff --git a/tactics/hints.mli b/tactics/hints.mli index e25b66b27b..af4d3d1f66 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -37,6 +37,7 @@ type 'a hint_ast = | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) type hint +type raw_hint = constr * types * Univ.universe_context_set type hints_path_atom = | PathHints of global_reference list @@ -199,11 +200,11 @@ val make_extern : -> hint_entry val run_hint : hint -> - ((constr * clausenv) hint_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic + ((raw_hint * clausenv) hint_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic (** This function is for backward compatibility only, not to use in newly written code. *) -val repr_hint : hint -> (constr * clausenv) hint_ast +val repr_hint : hint -> (raw_hint * clausenv) hint_ast val extern_intern_tac : (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t -- cgit v1.2.3 From db80daaf82a08a1475c65f7c82bffb63c7efd27a Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 14 Oct 2015 16:40:53 +0200 Subject: Temporary fix: kernel conversion needs to ignore l2r flag. Stdlib does not compile when l2r flag is actually taken into account. We should investigate... --- kernel/reduction.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 68783780d3..ccea06c761 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -740,7 +740,7 @@ let vm_conv cv_pb env t1 t2 = let default_conv cv_pb ?(l2r=false) env t1 t2 = try - fconv cv_pb l2r (fun _ -> None) env t1 t2 + fconv cv_pb false (fun _ -> None) env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) fconv cv_pb false (fun _->None) env t1 t2 -- cgit v1.2.3 From 5b67ba8e1bbd92d4ef7e2adab13bd05e7b55bfd7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 14 Oct 2015 15:57:19 +0200 Subject: Univs: inductives, remove unneeded test --- kernel/indtypes.ml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 9c065101a3..5d7a0bbf00 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -285,11 +285,7 @@ let typecheck_inductive env mie = let full_polymorphic () = let defu = Term.univ_of_sort def_level in let is_natural = - type_in_type env || (check_leq (universes env') infu defu && - not (is_type0m_univ defu && not is_unit) - (* (~ is_type0m_univ defu \/ is_unit) (\* infu <= defu && not prop or unital *\) *) - - ) + type_in_type env || (check_leq (universes env') infu defu) in let _ = (** Impredicative sort, always allow *) -- cgit v1.2.3 From 5009be2f117a5ef27733b7d6895503af91e9aa34 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 14 Oct 2015 15:57:42 +0200 Subject: When typechecking a lemma statement, try to resolve typeclasses before failing for unresolved evars (regression). --- stm/lemmas.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 5cbe152b55..c49ddfd8ec 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -439,7 +439,7 @@ let start_proof_com kind thms hook = let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in - check_evars_are_solved env !evdref (Evd.empty,!evdref); + evdref := solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref); let ids = List.map pi1 ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), -- cgit v1.2.3 From b8c681338cad546c397a1803c55183cc6526adfb Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 14 Oct 2015 16:39:09 +0200 Subject: Fix constr_matching when a match is found in the head of a case construct --- pretyping/constr_matching.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 19c85c9e27..121ab74885 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -415,8 +415,8 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = try_aux sub mk_ctx next | Case (ci,hd,c1,lc) -> let next_mk_ctx = function - | [] -> assert false - | c1 :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) + | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) + | _ -> assert false in let sub = (env, c1) :: (env, hd) :: subargs env lc in try_aux sub next_mk_ctx next -- cgit v1.2.3 From 26af31cb46c7baf92325dd22bf6ee33aaa2172d2 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 14 Oct 2015 18:17:42 +0200 Subject: Occur-check in evar_define was not strong enough. --- pretyping/evarsolve.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 754ad8f588..bbc4f1db29 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1484,7 +1484,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = if occur_meta body then raise MetaOccurInBodyInternal; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) - if occur_evar evk body then raise (OccurCheckIn (evd',body)); + if occur_evar_upto evd' evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let evd', body = refresh_universes pbty env evd' body in (* Cannot strictly type instantiations since the unification algorithm -- cgit v1.2.3 From bf0499bc507d5a39c3d5e3bf1f69191339270729 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 14 Oct 2015 18:18:01 +0200 Subject: Fix LemmaOverloading Do not normalize the type of a proof according to the final universes when keep_body_ucst_separate is true, otherwise the type might not be retypable in the initial context... --- proofs/proof_global.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3e06294e64..a0ead42ef3 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -313,7 +313,12 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = if poly || now then let make_body t (c, eff) = let open Universes in - let body = c and typ = nf t in + let body = c in + let typ = + if not (keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff)) then + nf t + else t + in let used_univs_body = Universes.universes_of_constr body in let used_univs_typ = Universes.universes_of_constr typ in if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then -- cgit v1.2.3 From a895b2c0caf8ec9c0deb04b8dea890283bd7329d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 14 Oct 2015 12:16:36 +0200 Subject: Fixing perfomance issue of auto hints induced by universes. Instead of brutally merging the whole evarmap coming from the clenv, we remember the context associated to the hint and we only merge that tiny part of constraints. We need to be careful for polymorphic hints though, as we have to refresh them beforehand. --- dev/top_printers.ml | 2 +- tactics/auto.ml | 38 ++++++++++++++++++++++++++------------ 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f9f2e1b09e..059c812ad5 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -165,7 +165,7 @@ let pp_state_t n = pp (Reductionops.pr_state n) (* proof printers *) let pr_evar ev = Pp.int (Evar.repr ev) let ppmetas metas = pp(pr_metaset metas) -let ppevm evd = pp(pr_evar_map ~with_univs:!Flags.univ_print (Some 2) evd) +let ppevm evd = pp(Evd.pr_evar_universe_context (Evd.evar_universe_context evd)) let ppevmall evd = pp(pr_evar_map ~with_univs:!Flags.univ_print None evd) let pr_existentialset evars = prlist_with_sep spc pr_evar (Evar.Set.elements evars) diff --git a/tactics/auto.ml b/tactics/auto.ml index 72c28ce323..617c491c35 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -72,21 +72,35 @@ let auto_flags_of_state st = (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta poly (c,clenv) = +let unify_resolve poly flags ((c : raw_hint), clenv) = Proofview.Goal.nf_enter begin fun gl -> - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in - let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags:auto_unif_flags clenv' gl) gl in - Clenvtac.clenv_refine false clenv'' + (** [clenv] has been generated by a hint-making function, so the only relevant + data in its evarmap is the set of metas. The [evar_reset_evd] function + below just replaces the metas of sigma by those coming from the clenv. *) + let sigma = Proofview.Goal.sigma gl in + let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in + (** Still, we need to update the universes *) + let (_, _, ctx) = c in + let clenv = + if poly then + (** Refresh the instance of the hint *) + let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in + let map c = Vars.subst_univs_level_constr subst c in + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + let clenv = { clenv with evd = evd ; env = Proofview.Goal.env gl } in + (** FIXME: We're being inefficient here because we substitute the whole + evar map instead of just its metas, which are the only ones + mentioning the old universes. *) + Clenv.map_clenv map clenv + else + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + { clenv with evd = evd ; env = Proofview.Goal.env gl } + in + let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in + Clenvtac.clenv_refine false clenv end -let unify_resolve poly flags (c,clenv) = - Proofview.Goal.nf_enter begin fun gl -> - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in - let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv' gl) gl in - Clenvtac.clenv_refine false clenv'' - end +let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h let unify_resolve_gen poly = function | None -> unify_resolve_nodelta poly -- cgit v1.2.3 From 1d6c4f135d42a008b21d86d8ecd8b329405d8d7c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 14 Oct 2015 18:51:47 +0200 Subject: Reverting modifications in dev/top_printers pushed mistakenly. --- dev/top_printers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 059c812ad5..f9f2e1b09e 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -165,7 +165,7 @@ let pp_state_t n = pp (Reductionops.pr_state n) (* proof printers *) let pr_evar ev = Pp.int (Evar.repr ev) let ppmetas metas = pp(pr_metaset metas) -let ppevm evd = pp(Evd.pr_evar_universe_context (Evd.evar_universe_context evd)) +let ppevm evd = pp(pr_evar_map ~with_univs:!Flags.univ_print (Some 2) evd) let ppevmall evd = pp(pr_evar_map ~with_univs:!Flags.univ_print None evd) let pr_existentialset evars = prlist_with_sep spc pr_evar (Evar.Set.elements evars) -- cgit v1.2.3 From 7402a7788b6a73bd5c0cb9078823d48e6f01a357 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 15 Oct 2015 08:10:05 +0200 Subject: Fix detection of ties in oracle_order. This commit has no impact, since l2r is always false in practice due to the definition of default_conv. --- kernel/conv_oracle.ml | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 3b01538b92..ec2c334b6f 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -82,12 +82,17 @@ let fold_strategy f { var_opacity; cst_opacity; } accu = let get_transp_state { var_trstate; cst_trstate } = (var_trstate, cst_trstate) (* Unfold the first constant only if it is "more transparent" than the - second one. In case of tie, expand the second one. *) + second one. In case of tie, use the recommended default. *) let oracle_order f o l2r k1 k2 = match get_strategy o f k1, get_strategy o f k2 with - | Expand, _ -> true - | Level n1, Opaque -> true - | Level n1, Level n2 -> n1 < n2 - | _ -> l2r (* use recommended default *) + | Expand, Expand -> l2r + | Expand, (Opaque | Level _) -> true + | (Opaque | Level _), Expand -> false + | Opaque, Opaque -> l2r + | Level _, Opaque -> true + | Opaque, Level _ -> false + | Level n1, Level n2 -> + if Int.equal n1 n2 then l2r + else n1 < n2 let get_strategy o = get_strategy o (fun x -> x) -- cgit v1.2.3 From 7ae876ab6246a9c9d352b7c72d3f98db47ff456c Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 14 Oct 2015 17:17:38 +0200 Subject: Remove now useless exception handler in default conversion. --- kernel/reduction.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index ccea06c761..9479e38ca8 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -739,11 +739,7 @@ let vm_conv cv_pb env t1 t2 = fconv cv_pb false (fun _->None) env t1 t2 let default_conv cv_pb ?(l2r=false) env t1 t2 = - try fconv cv_pb false (fun _ -> None) env t1 t2 - with Not_found | Invalid_argument _ -> - (* If compilation fails, fall-back to closure conversion *) - fconv cv_pb false (fun _->None) env t1 t2 let default_conv_leq = default_conv CUMUL (* -- cgit v1.2.3 From d08aa6b4f742a7162e726920810765258802c176 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 14 Oct 2015 17:23:27 +0200 Subject: Warn user when bytecode compilation fails. Previously, the kernel was silently switching back to the standard conversion. --- kernel/reduction.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 9479e38ca8..0f105b0489 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -735,8 +735,9 @@ let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> - (* If compilation fails, fall-back to closure conversion *) - fconv cv_pb false (fun _->None) env t1 t2 + (Pp.msg_warning + (Pp.str "Bytecode compilation failed, falling back to default conversion"); + fconv cv_pb false (fun _->None) env t1 t2) let default_conv cv_pb ?(l2r=false) env t1 t2 = fconv cv_pb false (fun _ -> None) env t1 t2 -- cgit v1.2.3 From 3116aeff0cdc51e6801f3e8ae4a6c0533e1a75ac Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 8 Oct 2015 18:06:55 +0200 Subject: Fix #4346 1/2: native casts were not inferring universe constraints. --- kernel/fast_typeops.ml | 2 +- kernel/nativeconv.ml | 116 +++++++++++++++++++++++++-------------------- kernel/nativeconv.mli | 4 ++ kernel/reduction.ml | 19 ++------ kernel/reduction.mli | 19 +++----- kernel/typeops.ml | 2 +- pretyping/nativenorm.ml | 20 +++++--- pretyping/nativenorm.mli | 6 ++- pretyping/pretyping.ml | 8 ++-- pretyping/reductionops.ml | 11 +++-- pretyping/reductionops.mli | 9 +++- proofs/redexpr.ml | 3 +- 12 files changed, 117 insertions(+), 102 deletions(-) diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index d22abff10c..063c9cf126 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -227,7 +227,7 @@ let judge_of_cast env c ct k expected_type = default_conv ~l2r:true CUMUL env ct expected_type | NATIVEcast -> let sigma = Nativelambda.empty_evars in - native_conv CUMUL sigma env ct expected_type + Nativeconv.native_conv CUMUL sigma env ct expected_type with NotConvertible -> error_actual_type env (make_judge c ct) expected_type diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index d0aa96fd15..fc68575cd7 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -16,21 +16,21 @@ open Nativecode (** This module implements the conversion test by compiling to OCaml code *) -let rec conv_val env pb lvl cu v1 v2 = - if v1 == v2 then () +let rec conv_val env pb lvl v1 v2 cu = + if v1 == v2 then cu else match kind_of_value v1, kind_of_value v2 with | Vfun f1, Vfun f2 -> let v = mk_rel_accu lvl in - conv_val env CONV (lvl+1) cu (f1 v) (f2 v) + conv_val env CONV (lvl+1) (f1 v) (f2 v) cu | Vfun f1, _ -> - conv_val env CONV lvl cu v1 (fun x -> v2 x) + conv_val env CONV lvl v1 (fun x -> v2 x) cu | _, Vfun f2 -> - conv_val env CONV lvl cu (fun x -> v1 x) v2 + conv_val env CONV lvl (fun x -> v1 x) v2 cu | Vaccu k1, Vaccu k2 -> - conv_accu env pb lvl cu k1 k2 + conv_accu env pb lvl k1 k2 cu | Vconst i1, Vconst i2 -> - if not (Int.equal i1 i2) then raise NotConvertible + if Int.equal i1 i2 then cu else raise NotConvertible | Vblock b1, Vblock b2 -> let n1 = block_size b1 in let n2 = block_size b2 in @@ -38,76 +38,76 @@ let rec conv_val env pb lvl cu v1 v2 = raise NotConvertible; let rec aux lvl max b1 b2 i cu = if Int.equal i max then - conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i) + conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu else - (conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i); - aux lvl max b1 b2 (i+1) cu) + let cu = conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu in + aux lvl max b1 b2 (i+1) cu in aux lvl (n1-1) b1 b2 0 cu | Vaccu _, _ | Vconst _, _ | Vblock _, _ -> raise NotConvertible -and conv_accu env pb lvl cu k1 k2 = +and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in let n2 = accu_nargs k2 in if not (Int.equal n1 n2) then raise NotConvertible; if Int.equal n1 0 then conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu else - (conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu; - List.iter2 (conv_val env CONV lvl cu) (args_of_accu k1) (args_of_accu k2)) + let cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu in + List.fold_right2 (conv_val env CONV lvl) (args_of_accu k1) (args_of_accu k2) cu and conv_atom env pb lvl a1 a2 cu = - if a1 == a2 then () + if a1 == a2 then cu else match a1, a2 with | Ameta _, _ | _, Ameta _ | Aevar _, _ | _, Aevar _ -> assert false | Arel i1, Arel i2 -> - if not (Int.equal i1 i2) then raise NotConvertible + if Int.equal i1 i2 then cu else raise NotConvertible | Aind ind1, Aind ind2 -> - if not (eq_puniverses eq_ind ind1 ind2) then raise NotConvertible + if eq_puniverses eq_ind ind1 ind2 then cu else raise NotConvertible | Aconstant c1, Aconstant c2 -> - if not (eq_puniverses eq_constant c1 c2) then raise NotConvertible + if eq_puniverses eq_constant c1 c2 then cu else raise NotConvertible | Asort s1, Asort s2 -> - check_sort_cmp_universes env pb s1 s2 cu + sort_cmp_universes env pb s1 s2 cu | Avar id1, Avar id2 -> - if not (Id.equal id1 id2) then raise NotConvertible + if Id.equal id1 id2 then cu else raise NotConvertible | Acase(a1,ac1,p1,bs1), Acase(a2,ac2,p2,bs2) -> if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible; - conv_accu env CONV lvl cu ac1 ac2; + let cu = conv_accu env CONV lvl ac1 ac2 cu in let tbl = a1.asw_reloc in let len = Array.length tbl in - if Int.equal len 0 then conv_val env CONV lvl cu p1 p2 + if Int.equal len 0 then conv_val env CONV lvl p1 p2 cu else begin - conv_val env CONV lvl cu p1 p2; - let max = len - 1 in - let rec aux i = - let tag,arity = tbl.(i) in - let ci = - if Int.equal arity 0 then mk_const tag - else mk_block tag (mk_rels_accu lvl arity) in - let bi1 = bs1 ci and bi2 = bs2 ci in - if Int.equal i max then conv_val env CONV (lvl + arity) cu bi1 bi2 - else (conv_val env CONV (lvl + arity) cu bi1 bi2; aux (i+1)) in - aux 0 + let cu = conv_val env CONV lvl p1 p2 cu in + let max = len - 1 in + let rec aux i cu = + let tag,arity = tbl.(i) in + let ci = + if Int.equal arity 0 then mk_const tag + else mk_block tag (mk_rels_accu lvl arity) in + let bi1 = bs1 ci and bi2 = bs2 ci in + if Int.equal i max then conv_val env CONV (lvl + arity) bi1 bi2 cu + else aux (i+1) (conv_val env CONV (lvl + arity) bi1 bi2 cu) in + aux 0 cu end | Afix(t1,f1,rp1,s1), Afix(t2,f2,rp2,s2) -> if not (Int.equal s1 s2) || not (Array.equal Int.equal rp1 rp2) then raise NotConvertible; - if f1 == f2 then () + if f1 == f2 then cu else conv_fix env lvl t1 f1 t2 f2 cu | (Acofix(t1,f1,s1,_) | Acofixe(t1,f1,s1,_)), (Acofix(t2,f2,s2,_) | Acofixe(t2,f2,s2,_)) -> if not (Int.equal s1 s2) then raise NotConvertible; - if f1 == f2 then () + if f1 == f2 then cu else if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible else conv_fix env lvl t1 f1 t2 f2 cu | Aprod(_,d1,c1), Aprod(_,d2,c2) -> - conv_val env CONV lvl cu d1 d2; - let v = mk_rel_accu lvl in - conv_val env pb (lvl + 1) cu (d1 v) (d2 v) + let cu = conv_val env CONV lvl d1 d2 cu in + let v = mk_rel_accu lvl in + conv_val env pb (lvl + 1) (d1 v) (d2 v) cu | Aproj(p1,ac1), Aproj(p2,ac2) -> if not (Constant.equal p1 p2) then raise NotConvertible - else conv_accu env CONV lvl cu ac1 ac2 + else conv_accu env CONV lvl ac1 ac2 cu | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ | Aproj _, _ -> raise NotConvertible @@ -118,21 +118,15 @@ and conv_fix env lvl t1 f1 t2 f2 cu = let max = len - 1 in let fargs = mk_rels_accu lvl len in let flvl = lvl + len in - let rec aux i = - conv_val env CONV lvl cu t1.(i) t2.(i); + let rec aux i cu = + let cu = conv_val env CONV lvl t1.(i) t2.(i) cu in let fi1 = napply f1.(i) fargs in let fi2 = napply f2.(i) fargs in - if Int.equal i max then conv_val env CONV flvl cu fi1 fi2 - else (conv_val env CONV flvl cu fi1 fi2; aux (i+1)) in - aux 0 + if Int.equal i max then conv_val env CONV flvl fi1 fi2 cu + else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in + aux 0 cu -let native_conv pb sigma env t1 t2 = - if Coq_config.no_native_compiler then begin - let msg = "Native compiler is disabled, falling back to VM conversion test." in - Pp.msg_warning (Pp.str msg); - vm_conv pb env t1 t2 - end - else +let native_conv_gen pb sigma env univs t1 t2 = let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code penv sigma prefix t1 t2 in @@ -146,8 +140,26 @@ let native_conv pb sigma env t1 t2 = let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Pp.msg_debug (Pp.str time_info); (* TODO change 0 when we can have deBruijn *) - conv_val env pb 0 (Environ.universes env) !rt1 !rt2 + fst (conv_val env pb 0 !rt1 !rt2 univs) end | _ -> anomaly (Pp.str "Compilation failure") -let _ = set_nat_conv native_conv +(* Wrapper for [native_conv] above *) +let native_conv cv_pb sigma env t1 t2 = + if Coq_config.no_native_compiler then begin + let msg = "Native compiler is disabled, falling back to VM conversion test." in + Pp.msg_warning (Pp.str msg); + vm_conv cv_pb env t1 t2 + end + else + let univs = Environ.universes env in + let b = + if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 + else Constr.eq_constr_univs univs t1 t2 + in + let univs = (univs, checked_universes) in + if not b then begin + let t1 = Term.it_mkLambda_or_LetIn t1 (Environ.rel_context env) in + let t2 = Term.it_mkLambda_or_LetIn t2 (Environ.rel_context env) in + let _ = native_conv_gen cv_pb sigma env univs t1 t2 in () + end diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli index 318a7d830b..21f0b2e9e5 100644 --- a/kernel/nativeconv.mli +++ b/kernel/nativeconv.mli @@ -12,3 +12,7 @@ open Nativelambda (** This module implements the conversion test by compiling to OCaml code *) val native_conv : conv_pb -> evars -> types conversion_function + +(** A conversion function parametrized by a universe comparator. Used outside of + the kernel. *) +val native_conv_gen : conv_pb -> evars -> (constr, 'a) generic_conversion_function diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 0f105b0489..b6c97b11d3 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -637,7 +637,7 @@ let infer_cmp_universes env pb s0 s1 univs = let infer_convert_instances flex u u' (univs,cstrs) = (univs, Univ.enforce_eq_instances u u' cstrs) -let infered_universes : (Univ.universes * Univ.Constraint.t) universe_compare = +let inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } @@ -685,7 +685,7 @@ let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = v1 v2 -let generic_conv cv_pb l2r evars reds env univs t1 t2 = +let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = let (s, _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in s @@ -697,7 +697,7 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = in if b then cstrs else - let univs = ((univs, Univ.Constraint.empty), infered_universes) in + let univs = ((univs, Univ.Constraint.empty), inferred_universes) in let ((_,cstrs), _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in cstrs @@ -716,19 +716,6 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 -(* option for conversion *) -let nat_conv = ref (fun cv_pb sigma -> - fconv cv_pb false (sigma.Nativelambda.evars_val)) -let set_nat_conv f = nat_conv := f - -let native_conv cv_pb sigma env t1 t2 = - if eq_constr t1 t2 then () - else begin - let t1 = (it_mkLambda_or_LetIn t1 (rel_context env)) in - let t2 = (it_mkLambda_or_LetIn t2 (rel_context env)) in - !nat_conv cv_pb sigma env t1 t2 - end - let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None)) let set_vm_conv f = vm_conv := f let vm_conv cv_pb env t1 t2 = diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 90c008b19d..b71356d033 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -49,14 +49,11 @@ type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints -val check_sort_cmp_universes : - env -> conv_pb -> sorts -> sorts -> Univ.universes -> unit +val sort_cmp_universes : env -> conv_pb -> sorts -> sorts -> + 'a * 'a universe_compare -> 'a * 'a universe_compare -(* val sort_cmp : *) -(* conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *) - -(* val conv_sort : sorts conversion_function *) -(* val conv_sort_leq : sorts conversion_function *) +val checked_universes : Univ.universes universe_compare +val inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function val trans_conv : @@ -77,22 +74,20 @@ val conv_leq : val conv_leq_vecti : ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function +(** These conversion functions are used by module subtyping, which needs to infer + universe constraints inside the kernel *) val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:Names.transparent_state -> constr infer_conversion_function val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:Names.transparent_state -> types infer_conversion_function -val generic_conv : conv_pb -> bool -> (existential->constr option) -> +val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> Names.transparent_state -> (constr,'a) generic_conversion_function (** option for conversion *) val set_vm_conv : (conv_pb -> types conversion_function) -> unit val vm_conv : conv_pb -> types conversion_function -val set_nat_conv : - (conv_pb -> Nativelambda.evars -> types conversion_function) -> unit -val native_conv : conv_pb -> Nativelambda.evars -> types conversion_function - val default_conv : conv_pb -> ?l2r:bool -> types conversion_function val default_conv_leq : ?l2r:bool -> types conversion_function diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 8895bae5da..70f6fd803c 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -310,7 +310,7 @@ let judge_of_cast env cj k tj = | NATIVEcast -> let sigma = Nativelambda.empty_evars in mkCast (cj.uj_val, k, expected_type), - native_conv CUMUL sigma env cj.uj_type expected_type + Nativeconv.native_conv CUMUL sigma env cj.uj_type expected_type in { uj_val = c; uj_type = expected_type } diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 2432b8d291..949a28a1f4 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -22,11 +22,6 @@ open Nativelambda (** This module implements normalization by evaluation to OCaml code *) -let evars_of_evar_map evd = - { evars_val = Evd.existential_opt_value evd; - evars_typ = Evd.existential_type evd; - evars_metas = Evd.meta_type evd } - exception Find_at of int let invert_tag cst tag reloc_tbl = @@ -375,11 +370,17 @@ and nf_predicate env ind mip params v pT = true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v +let evars_of_evar_map sigma = + { Nativelambda.evars_val = Evd.existential_opt_value sigma; + Nativelambda.evars_typ = Evd.existential_type sigma; + Nativelambda.evars_metas = Evd.meta_type sigma } + let native_norm env sigma c ty = if Coq_config.no_native_compiler then error "Native_compute reduction has been disabled at configure time." else - let penv = Environ.pre_env env in + let penv = Environ.pre_env env in + let sigma = evars_of_evar_map sigma in (* Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); @@ -400,3 +401,10 @@ let native_norm env sigma c ty = if !Flags.debug then Pp.msg_debug (Pp.str time_info); res | _ -> anomaly (Pp.str "Compilation failure") + +let native_conv_generic pb sigma t = + Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t + +let native_infer_conv ?(pb=Reduction.CUMUL) env sigma x y = + Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma) + ~catch_incon:true ~pb env sigma x y diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index c854e8c9c5..0352038385 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -12,6 +12,8 @@ open Nativelambda (** This module implements normalization by evaluation to OCaml code *) -val evars_of_evar_map : evar_map -> evars +val native_norm : env -> evar_map -> constr -> types -> constr -val native_norm : env -> evars -> constr -> types -> constr +(** Conversion with inference of universe constraints *) +val native_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map * bool diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 746b4000ee..e1e8982e1e 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -942,12 +942,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in - let evars = Nativenorm.evars_of_evar_map !evdref in - let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in begin - try - ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj - with Reduction.NotConvertible -> + let (evd,b) = Nativenorm.native_infer_conv env !evdref cty tval in + if b then (evdref := evd; cj) + else error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) end diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index dc70f36ccf..a24773b6e6 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1295,8 +1295,8 @@ let sigma_univ_state = { Reduction.compare = sigma_compare_sorts; Reduction.compare_instances = sigma_compare_instances } -let infer_conv ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) - env sigma x y = +let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) + ?(ts=full_transparent_state) env sigma x y = try let b, sigma = let b, cstrs = @@ -1313,14 +1313,17 @@ let infer_conv ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_s if b then sigma, true else let sigma' = - Reduction.generic_conv pb false (safe_evar_value sigma) ts + conv_fun pb ~l2r:false sigma ts env (sigma, sigma_univ_state) x y in sigma', true with | Reduction.NotConvertible -> sigma, false | Univ.UniverseInconsistency _ when catch_incon -> sigma, false | e when is_anomaly e -> error "Conversion test raised an anomaly" - + +let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> + Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 1df2a73b2e..b179dbc95e 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -266,7 +266,7 @@ val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr *) val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool -(** [infer_fconv] Adds necessary universe constraints to the evar map. +(** [infer_conv] Adds necessary universe constraints to the evar map. pb defaults to CUMUL and ts to a full transparent state. @raises UniverseInconsistency iff catch_incon is set to false, otherwise returns false in that case. @@ -274,6 +274,13 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> con val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> evar_map * bool +(** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a +conversion function. Used to pretype vm and native casts. *) +val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> + (constr, evar_map) Reduction.generic_conversion_function) -> + ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> + evar_map -> constr -> constr -> evar_map * bool + (** {6 Special-Purpose Reduction Functions } *) val whd_meta : evar_map -> constr -> constr diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index f172bbdd1a..be92f2b04c 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -35,8 +35,7 @@ let cbv_native env sigma c = cbv_vm env sigma c else let ctyp = Retyping.get_type_of env sigma c in - let evars = Nativenorm.evars_of_evar_map sigma in - Nativenorm.native_norm env evars c ctyp + Nativenorm.native_norm env sigma c ctyp let whd_cbn flags env sigma t = let (state,_) = -- cgit v1.2.3 From 44817bf722eacb0379bebc7e435bfafa503d574f Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 15 Oct 2015 14:21:45 +0200 Subject: Fix #4346 2/2: VM casts were not inferring universe constraints. --- kernel/nativeconv.ml | 5 ++- kernel/nativeconv.mli | 2 +- kernel/reduction.ml | 2 +- kernel/typeops.ml | 2 +- kernel/vconv.ml | 88 ++++++++++++---------------------------------- kernel/vconv.mli | 8 +++-- pretyping/nativenorm.ml | 4 +-- pretyping/pretyping.ml | 11 +++--- pretyping/reductionops.ml | 3 -- pretyping/reductionops.mli | 2 -- pretyping/vnorm.ml | 4 +++ pretyping/vnorm.mli | 4 +++ 12 files changed, 48 insertions(+), 87 deletions(-) diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index fc68575cd7..7ae66c485a 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -157,9 +157,8 @@ let native_conv cv_pb sigma env t1 t2 = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 else Constr.eq_constr_univs univs t1 t2 in - let univs = (univs, checked_universes) in - if not b then begin + if not b then + let univs = (univs, checked_universes) in let t1 = Term.it_mkLambda_or_LetIn t1 (Environ.rel_context env) in let t2 = Term.it_mkLambda_or_LetIn t2 (Environ.rel_context env) in let _ = native_conv_gen cv_pb sigma env univs t1 t2 in () - end diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli index 21f0b2e9e5..4dddb9fd30 100644 --- a/kernel/nativeconv.mli +++ b/kernel/nativeconv.mli @@ -15,4 +15,4 @@ val native_conv : conv_pb -> evars -> types conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) -val native_conv_gen : conv_pb -> evars -> (constr, 'a) generic_conversion_function +val native_conv_gen : conv_pb -> evars -> (types, 'a) generic_conversion_function diff --git a/kernel/reduction.ml b/kernel/reduction.ml index b6c97b11d3..c2ab22e995 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -670,7 +670,7 @@ let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv_universes reds CUMUL l2r evars -let fconv = trans_fconv (Id.Pred.full, Cpred.full) +let fconv = trans_fconv full_transparent_state let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 70f6fd803c..09299f31d7 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -300,7 +300,7 @@ let judge_of_cast env cj k tj = match k with | VMcast -> mkCast (cj.uj_val, k, expected_type), - vm_conv CUMUL env cj.uj_type expected_type + Reduction.vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> mkCast (cj.uj_val, k, expected_type), default_conv ~l2r:false CUMUL env cj.uj_type expected_type diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 27e184ea3f..2f6be06011 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -46,7 +46,7 @@ let rec conv_val env pb k v1 v2 cu = and conv_whd env pb k whd1 whd2 cu = match whd1, whd2 with - | Vsort s1, Vsort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu + | Vsort s1, Vsort s2 -> sort_cmp_universes env pb s1 s2 cu | Vprod p1, Vprod p2 -> let cu = conv_val env CONV k (dom p1) (dom p2) cu in conv_fun env pb k (codom p1) (codom p2) cu @@ -163,67 +163,25 @@ let rec eq_puniverses f (x,l1) (y,l2) cu = and conv_universes l1 l2 cu = if Univ.Instance.equal l1 l2 then cu else raise NotConvertible -let rec conv_eq env pb t1 t2 cu = - if t1 == t2 then cu - else - match kind_of_term t1, kind_of_term t2 with - | Rel n1, Rel n2 -> - if Int.equal n1 n2 then cu else raise NotConvertible - | Meta m1, Meta m2 -> - if Int.equal m1 m2 then cu else raise NotConvertible - | Var id1, Var id2 -> - if Id.equal id1 id2 then cu else raise NotConvertible - | Sort s1, Sort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu - | Cast (c1,_,_), _ -> conv_eq env pb c1 t2 cu - | _, Cast (c2,_,_) -> conv_eq env pb t1 c2 cu - | Prod (_,t1,c1), Prod (_,t2,c2) -> - conv_eq env pb c1 c2 (conv_eq env CONV t1 t2 cu) - | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq env CONV c1 c2 cu - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> - conv_eq env pb c1 c2 (conv_eq env CONV b1 b2 cu) - | App (c1,l1), App (c2,l2) -> - conv_eq_vect env l1 l2 (conv_eq env CONV c1 c2 cu) - | Evar (e1,l1), Evar (e2,l2) -> - if Evar.equal e1 e2 then conv_eq_vect env l1 l2 cu - else raise NotConvertible - | Const c1, Const c2 -> eq_puniverses eq_constant c1 c2 cu - | Proj (p1,c1), Proj (p2,c2) -> - if eq_constant (Projection.constant p1) (Projection.constant p2) then - conv_eq env pb c1 c2 cu - else raise NotConvertible - | Ind c1, Ind c2 -> - eq_puniverses eq_ind c1 c2 cu - | Construct c1, Construct c2 -> - eq_puniverses eq_constructor c1 c2 cu - | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - let pcu = conv_eq env CONV p1 p2 cu in - let ccu = conv_eq env CONV c1 c2 pcu in - conv_eq_vect env bl1 bl2 ccu - | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> - if Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu) - else raise NotConvertible - | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - if Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu) - else raise NotConvertible - | _ -> raise NotConvertible - -and conv_eq_vect env vt1 vt2 cu = - let len = Array.length vt1 in - if Int.equal len (Array.length vt2) then - let rcu = ref cu in - for i = 0 to len-1 do - rcu := conv_eq env CONV vt1.(i) vt2.(i) !rcu - done; !rcu - else raise NotConvertible - -let vconv pb env t1 t2 = - let _cu = - try conv_eq env pb t1 t2 (universes env) - with NotConvertible -> - let v1 = val_of_constr env t1 in - let v2 = val_of_constr env t2 in - let cu = conv_val env pb (nb_rel env) v1 v2 (universes env) in - cu - in () - -let _ = Reduction.set_vm_conv vconv +let vm_conv_gen cv_pb env univs t1 t2 = + try + let v1 = val_of_constr env t1 in + let v2 = val_of_constr env t2 in + fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) + with Not_found | Invalid_argument _ -> + (Pp.msg_warning + (Pp.str "Bytecode compilation failed, falling back to default conversion"); + Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) + full_transparent_state env univs t1 t2) + +let vm_conv cv_pb env t1 t2 = + let univs = Environ.universes env in + let b = + if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 + else Constr.eq_constr_univs univs t1 t2 + in + if not b then + let univs = (univs, checked_universes) in + let _ = vm_conv_gen cv_pb env univs t1 t2 in () + +let _ = Reduction.set_vm_conv vm_conv diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 1a29a4d518..49e5d23e63 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -12,7 +12,11 @@ open Reduction (********************************************************************** s conversion functions *) -val vconv : conv_pb -> types conversion_function +val vm_conv : conv_pb -> types conversion_function -val val_of_constr : env -> constr -> values +(** A conversion function parametrized by a universe comparator. Used outside of + the kernel. *) +val vm_conv_gen : conv_pb -> (types, 'a) generic_conversion_function +(** Precompute a VM value from a constr *) +val val_of_constr : env -> constr -> values diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 949a28a1f4..dafe88d8db 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -405,6 +405,6 @@ let native_norm env sigma c ty = let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t -let native_infer_conv ?(pb=Reduction.CUMUL) env sigma x y = +let native_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma) - ~catch_incon:true ~pb env sigma x y + ~catch_incon:true ~pb env sigma t1 t2 diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index e1e8982e1e..f6c1867285 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -929,14 +929,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in if not (occur_existential cty || occur_existential tval) then - begin - try - let env = Environ.push_context_set (Evd.universe_context_set !evdref) env in - ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval + let (evd,b) = Vnorm.vm_infer_conv env !evdref cty tval in + if b then (evdref := evd; cj) + else + error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) - end else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index a24773b6e6..d25e273a3e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1251,9 +1251,6 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let sort_cmp cv_pb s1 s2 u = - Reduction.check_sort_cmp_universes cv_pb s1 s2 u - let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index b179dbc95e..42c2c9c6e6 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -251,8 +251,6 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val sort_cmp : env -> conv_pb -> sorts -> sorts -> universes -> unit - val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool val is_fconv : conv_pb -> env -> evar_map -> constr -> constr -> bool diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index f768e4feef..2c6ac7a292 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -312,3 +312,7 @@ and nf_cofix env cf = let cbv_vm env c t = let v = Vconv.val_of_constr env c in nf_val env v t + +let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = + Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb) + ~catch_incon:true ~pb env sigma t1 t2 diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 7dabbc6cb0..99856a8d9a 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -8,7 +8,11 @@ open Term open Environ +open Evd (** {6 Reduction functions } *) val cbv_vm : env -> constr -> types -> constr +(** Conversion with inference of universe constraints *) +val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map * bool -- cgit v1.2.3 From ba8dd1c47bcbbcd2678eca78783db7f5c95f37e7 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 15 Oct 2015 14:38:57 +0200 Subject: Test file for #4346: Set is no longer of type Type --- test-suite/bugs/closed/4346.v | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 test-suite/bugs/closed/4346.v diff --git a/test-suite/bugs/closed/4346.v b/test-suite/bugs/closed/4346.v new file mode 100644 index 0000000000..b50dff2411 --- /dev/null +++ b/test-suite/bugs/closed/4346.v @@ -0,0 +1,2 @@ +Check (Set <: Type). +Check (Set <<: Type). -- cgit v1.2.3 From 048b87502eced0a46a654f3f95de8f1968004db1 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 15 Oct 2015 18:15:21 +0200 Subject: Avoid dependency of the pretyper on C code. Using the same hack as in the kernel: VM conversion is a reference to a function, updated when modules using C code are actually linked. This hack should one day go away, but always linking C code may produce some other trouble (with the OCaml debugger for instance), so better be safe for now. --- kernel/reduction.ml | 1 + pretyping/pretyping.ml | 2 +- pretyping/reductionops.ml | 6 ++++++ pretyping/reductionops.mli | 7 +++++++ pretyping/vnorm.ml | 2 ++ pretyping/vnorm.mli | 4 ---- 6 files changed, 17 insertions(+), 5 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index c2ab22e995..c1f0008e63 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -716,6 +716,7 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 +(* This reference avoids always having to link C code with the kernel *) let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None)) let set_vm_conv f = vm_conv := f let vm_conv cv_pb env t1 t2 = diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f6c1867285..d484df69c1 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -929,7 +929,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in if not (occur_existential cty || occur_existential tval) then - let (evd,b) = Vnorm.vm_infer_conv env !evdref cty tval in + let (evd,b) = Reductionops.vm_infer_conv env !evdref cty tval in if b then (evdref := evd; cj) else error_actual_type_loc loc env !evdref cj tval diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index d25e273a3e..bb1bc7d2ea 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1321,6 +1321,12 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) +(* This reference avoids always having to link C code with the kernel *) +let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:full_transparent_state) +let set_vm_infer_conv f = vm_infer_conv := f +let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = + !vm_infer_conv ~pb env t1 t2 + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 42c2c9c6e6..d5a844847c 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -272,6 +272,13 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> con val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> evar_map * bool +(** Conversion with inference of universe constraints *) +val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map * bool) -> unit +val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map * bool + + (** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a conversion function. Used to pretype vm and native casts. *) val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 2c6ac7a292..46af784dda 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -316,3 +316,5 @@ let cbv_vm env c t = let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb) ~catch_incon:true ~pb env sigma t1 t2 + +let _ = Reductionops.set_vm_infer_conv vm_infer_conv diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 99856a8d9a..9421b2d859 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -12,7 +12,3 @@ open Evd (** {6 Reduction functions } *) val cbv_vm : env -> constr -> types -> constr - -(** Conversion with inference of universe constraints *) -val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> - evar_map * bool -- cgit v1.2.3 From 4dd61c9459a7388078bbd2e1b6f07959c4c72001 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 16 Oct 2015 07:45:19 +0200 Subject: Merge hint lists instead of appending them. (Fix bug #3199) --- tactics/hints.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/tactics/hints.ml b/tactics/hints.ml index 96c7d79ca5..2755ed9cb0 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -458,7 +458,9 @@ module Hint_db = struct else List.exists (matches_mode args) modes let merge_entry db nopat pat = - let h = Sort.merge pri_order (List.map snd db.hintdb_nopat @ nopat) pat in + let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in + let h = List.merge pri_order_int h nopat in + let h = List.merge pri_order_int h pat in List.map realize_tac h let map_none db = @@ -562,7 +564,9 @@ module Hint_db = struct let remove_one gr db = remove_list [gr] db - let get_entry se = List.map realize_tac (se.sentry_nopat @ se.sentry_pat) + let get_entry se = + let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in + List.map realize_tac h let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in -- cgit v1.2.3 From d1ce79ce293c9b77f2c6a9d0b9a8b4f84ea617e5 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 16 Oct 2015 13:20:19 +0200 Subject: Remove left2right reference from the kernel. Was introduced by seemingly unrelated commit fd62149f9bf40b3f309ebbfd7497ef7c185436d5. The currently policy is to avoid exposing global references in the kernel interface when easily doable. --- kernel/reduction.ml | 6 +----- kernel/reduction.mli | 2 -- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index c1f0008e63..2c111a55b5 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -26,8 +26,6 @@ open Environ open Closure open Esubst -let left2right = ref false - let rec is_empty_stack = function [] -> true | Zupdate _::s -> is_empty_stack s @@ -210,9 +208,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let cu1 = cmp_rec s1 s2 cuniv in (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> - if !left2right then - Array.fold_left2 (fun cu x y -> f x y cu) cu1 a1 a2 - else Array.fold_right2 f a1 a2 cu1 + Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> if not (eq_constant c1 c2) then raise NotConvertible diff --git a/kernel/reduction.mli b/kernel/reduction.mli index b71356d033..c3cc7b2b69 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -10,8 +10,6 @@ open Term open Context open Environ -val left2right : bool ref - (*********************************************************************** s Reduction functions *) -- cgit v1.2.3 From 56925d60207f940ebb88d56981f8cdff41c58247 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 25 Jun 2015 13:56:14 +0200 Subject: Exporting a purely functional interface to bytecode patching. --- kernel/cemitcodes.ml | 10 +++++++++- kernel/cemitcodes.mli | 4 +--- kernel/csymtable.ml | 16 +++++----------- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 9b275cb6c3..37794b5ea6 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -29,11 +29,19 @@ let patch_char4 buff pos c1 c2 c3 c4 = String.unsafe_set buff (pos + 2) c3; String.unsafe_set buff (pos + 3) c4 -let patch_int buff pos n = +let patch buff (pos, n) = patch_char4 buff pos (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16)) (Char.unsafe_chr (n asr 24)) +let patch_int buff patches = + (* copy code *before* patching because of nested evaluations: + the code we are patching might be called (and thus "concurrently" patched) + and results in wrong results. Side-effects... *) + let buff = String.copy buff in + let () = List.iter (fun p -> patch buff p) patches in + buff + (* Buffering of bytecode *) let out_buffer = ref(String.create 1024) diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 54b92b9121..398b60eca5 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -13,11 +13,9 @@ val subst_patch : Mod_subst.substitution -> patch -> patch type emitcodes -val copy : emitcodes -> emitcodes - val length : emitcodes -> int -val patch_int : emitcodes -> (*pos*)int -> int -> unit +val patch_int : emitcodes -> ((*pos*)int * int) list -> emitcodes type to_patch = emitcodes * (patch list) * fv diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index b3f0ba5b58..e242449b12 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -199,19 +199,13 @@ and slot_for_fv env fv = end and eval_to_patch env (buff,pl,fv) = - (* copy code *before* patching because of nested evaluations: - the code we are patching might be called (and thus "concurrently" patched) - and results in wrong results. Side-effects... *) - let buff = Cemitcodes.copy buff in let patch = function - | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a) - | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc) - | Reloc_getglobal kn, pos -> -(* Pp.msgnl (str"patching global: "++str(debug_string_of_con kn));*) - patch_int buff pos (slot_for_getglobal env kn); -(* Pp.msgnl (str"patch done: "++str(debug_string_of_con kn))*) + | Reloc_annot a, pos -> (pos, slot_for_annot a) + | Reloc_const sc, pos -> (pos, slot_for_str_cst sc) + | Reloc_getglobal kn, pos -> (pos, slot_for_getglobal env kn) in - List.iter patch pl; + let patches = List.map_left patch pl in + let buff = patch_int buff patches in let vm_env = Array.map (slot_for_fv env) fv in let tc = tcode_of_code buff (length buff) in (*Pp.msgnl (str"execute code");*) -- cgit v1.2.3 From 8cb3a606f7c72c32298fe028c9f98e44ea0d378b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 25 Jun 2015 13:48:44 +0200 Subject: Hashcons bytecode generated by the VM. --- kernel/cemitcodes.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 37794b5ea6..4e64ed6976 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -374,6 +374,8 @@ let to_memory (init_code, fun_code, fv) = emit fun_code; let code = String.create !out_position in String.unsafe_blit !out_buffer 0 code 0 !out_position; + (** Later uses of this string are all purely functional *) + let code = CString.hcons code in let reloc = List.rev !reloc_info in Array.iter (fun lbl -> (match lbl with -- cgit v1.2.3 From 5f9a9641c72b35650f62df43beb6f43f9f3a72e5 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 16 Oct 2015 16:41:58 +0200 Subject: Generalize fix for auto from PMP to eauto and typeclasses eauto. --- tactics/auto.ml | 16 +++++++++------- tactics/auto.mli | 3 +++ tactics/class_tactics.ml | 42 +++++++++++++++++++++--------------------- tactics/eauto.ml4 | 24 +++++++++++++----------- 4 files changed, 46 insertions(+), 39 deletions(-) diff --git a/tactics/auto.ml b/tactics/auto.ml index 617c491c35..a6b53d76cc 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -72,16 +72,14 @@ let auto_flags_of_state st = (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve poly flags ((c : raw_hint), clenv) = - Proofview.Goal.nf_enter begin fun gl -> +let connect_hint_clenv poly (c, _, ctx) clenv gl = (** [clenv] has been generated by a hint-making function, so the only relevant data in its evarmap is the set of metas. The [evar_reset_evd] function below just replaces the metas of sigma by those coming from the clenv. *) let sigma = Proofview.Goal.sigma gl in let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in (** Still, we need to update the universes *) - let (_, _, ctx) = c in - let clenv = + let clenv, c = if poly then (** Refresh the instance of the hint *) let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in @@ -91,11 +89,15 @@ let unify_resolve poly flags ((c : raw_hint), clenv) = (** FIXME: We're being inefficient here because we substitute the whole evar map instead of just its metas, which are the only ones mentioning the old universes. *) - Clenv.map_clenv map clenv + Clenv.map_clenv map clenv, map c else let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - { clenv with evd = evd ; env = Proofview.Goal.env gl } - in + { clenv with evd = evd ; env = Proofview.Goal.env gl }, c + in clenv, c + +let unify_resolve poly flags ((c : raw_hint), clenv) = + Proofview.Goal.nf_enter begin fun gl -> + let clenv, c = connect_hint_clenv poly c clenv gl in let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in Clenvtac.clenv_refine false clenv end diff --git a/tactics/auto.mli b/tactics/auto.mli index 6e2acf7f56..cae180ce76 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -25,6 +25,9 @@ val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags +val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> + [ `NF ] Proofview.Goal.t -> clausenv * constr + (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 36b60385d8..f3a4863444 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -154,33 +154,31 @@ let e_give_exact flags poly (c,clenv) gl = tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl let unify_e_resolve poly flags (c,clenv) gls = - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = connect_clenv gls clenv' in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - Proofview.V82.of_tactic (Clenvtac.clenv_refine true ~with_classes:false clenv') gls + let clenv', c = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine true ~with_classes:false clenv' let unify_resolve poly flags (c,clenv) gls = - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = connect_clenv gls clenv' in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - Proofview.V82.of_tactic - (Clenvtac.clenv_refine false ~with_classes:false clenv') gls + let clenv', _ = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine false ~with_classes:false clenv' -let clenv_of_prods poly nprods (c, clenv) gls = +let clenv_of_prods poly nprods (c, clenv) gl = let (c, _, _) = c in if poly || Int.equal nprods 0 then Some clenv else - let ty = pf_unsafe_type_of gls c in + let ty = Tacmach.New.pf_unsafe_type_of gl c in let diff = nb_prod ty - nprods in if Pervasives.(>=) diff 0 then (* Was Some clenv... *) - Some (mk_clenv_from_n gls (Some diff) (c,ty)) + Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) else None -let with_prods nprods poly (c, clenv) f gls = - match clenv_of_prods poly nprods (c, clenv) gls with - | None -> tclFAIL 0 (str"Not enough premisses") gls - | Some clenv' -> f (c, clenv') gls +let with_prods nprods poly (c, clenv) f = + Proofview.Goal.nf_enter (fun gl -> + match clenv_of_prods poly nprods (c, clenv) gl with + | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") + | Some clenv' -> f (c, clenv') gl) (** Hack to properly solve dependent evars that are typeclasses *) @@ -224,12 +222,13 @@ and e_my_find_search db_list local_db hdc complete sigma concl = let tac_of_hint = fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> let tac = function - | Res_pf (term,cl) -> Proofview.V82.tactic (with_prods nprods poly (term,cl) (unify_resolve poly flags)) - | ERes_pf (term,cl) -> Proofview.V82.tactic (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) + | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) | Res_pf_THEN_trivial_fail (term,cl) -> - Proofview.V82.tactic (tclTHEN (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) - (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) + Proofview.V82.tactic (tclTHEN + (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) + (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c])) | Extern tacast -> conclPattern concl p tacast in @@ -847,4 +846,5 @@ let autoapply c i gl = (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - unify_e_resolve false flags (c,ce) gl + let tac = unify_e_resolve false flags ((c,cty,Univ.ContextSet.empty),ce) in + Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 09c5fa873f..ca430ec111 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -116,15 +116,17 @@ open Unification (***************************************************************************) let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) - -let unify_e_resolve poly flags (c,clenv) gls = - let (c, _, _) = c in - let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv - else clenv, Univ.empty_level_subst in - let clenv' = connect_clenv gls clenv' in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (Proofview.V82.of_tactic (Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c))) gls + +let unify_e_resolve poly flags (c,clenv) = + Proofview.Goal.nf_enter begin + fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + Proofview.V82.tactic + (fun gls -> + let clenv' = clenv_unique_resolver ~flags clenv' gls in + tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) + end let hintmap_of hdc concl = match hdc with @@ -166,10 +168,10 @@ and e_my_find_search db_list local_db hdc concl = (b, let tac = function | Res_pf (term,cl) -> unify_resolve poly st (term,cl) - | ERes_pf (term,cl) -> Proofview.V82.tactic (unify_e_resolve poly st (term,cl)) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) | Give_exact (c,cl) -> Proofview.V82.tactic (e_exact poly st (c,cl)) | Res_pf_THEN_trivial_fail (term,cl) -> - Proofview.V82.tactic (tclTHEN (unify_e_resolve poly st (term,cl)) + Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (unify_e_resolve poly st (term,cl))) (e_trivial_fail_db db_list local_db)) | Unfold_nth c -> Proofview.V82.tactic (reduce (Unfold [AllOccurrences,c]) onConcl) | Extern tacast -> conclPattern concl p tacast -- cgit v1.2.3 From 3664fd9f0af7851ed35e1fc06d826f7fd8ee2f7a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Oct 2015 12:00:12 +0200 Subject: Test for bug #4325. --- test-suite/bugs/closed/4325.v | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 test-suite/bugs/closed/4325.v diff --git a/test-suite/bugs/closed/4325.v b/test-suite/bugs/closed/4325.v new file mode 100644 index 0000000000..af69ca04b6 --- /dev/null +++ b/test-suite/bugs/closed/4325.v @@ -0,0 +1,5 @@ +Goal (forall a b : nat, Set = (a = b)) -> Set. +Proof. + clear. + intro H. + erewrite (fun H' => H _ H'). -- cgit v1.2.3 From 28297a3994779fda9b9208cb90bd6f8f08d652c5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Oct 2015 12:35:25 +0200 Subject: Lemmas accept the Local flag. This was a trivial overlook. --- toplevel/vernacentries.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index f1f87ca9b1..d04d6c9eda 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -478,7 +478,8 @@ let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = Some (snd (interp_redexp env evc r)) in do_definition id (local,p,k) pl bl red_option c typ_opt hook) -let vernac_start_proof p kind l lettop = +let vernac_start_proof locality p kind l lettop = + let local = enforce_locality_exp locality None in if Dumpglob.dump () then List.iter (fun (id, _) -> match id with @@ -488,7 +489,7 @@ let vernac_start_proof p kind l lettop = if lettop then errorlabstrm "Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); - start_proof_and_print (Global, p, Proof kind) l no_hook + start_proof_and_print (local, p, Proof kind) l no_hook let qed_display_script = ref true @@ -1860,7 +1861,7 @@ let interp ?proof ~loc locality poly c = (* Gallina *) | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d - | VernacStartTheoremProof (k,l,top) -> vernac_start_proof poly k l top + | VernacStartTheoremProof (k,l,top) -> vernac_start_proof locality poly k l top | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl @@ -1965,7 +1966,7 @@ let interp ?proof ~loc locality poly c = | VernacBacktrack _ -> msg_warning (str "VernacBacktrack not handled by Stm") (* Proof management *) - | VernacGoal t -> vernac_start_proof poly Theorem [None,([],t,None)] false + | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () | VernacUnfocused -> vernac_unfocused () @@ -2006,7 +2007,7 @@ let check_vernac_supports_locality c l = | VernacOpenCloseScope _ | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ + | VernacAssumption _ | VernacStartTheoremProof _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ | VernacDeclareMLModule _ -- cgit v1.2.3 From 68863acca9abf4490c651df889721ef7f6a4d375 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Oct 2015 15:32:03 +0200 Subject: Dedicated file for universe unification context manipulation. This allows to remove a lot of independent code from Evd which was put into the UState module. The API is not perfect yet, but this is a first pass. Names of data structures should be thought about too because they are way too similar. --- dev/printers.mllib | 1 + engine/engine.mllib | 1 + engine/evd.ml | 528 ++++++---------------------------------------------- engine/evd.mli | 4 +- engine/uState.ml | 484 +++++++++++++++++++++++++++++++++++++++++++++++ engine/uState.mli | 83 +++++++++ 6 files changed, 624 insertions(+), 477 deletions(-) create mode 100644 engine/uState.ml create mode 100644 engine/uState.mli diff --git a/dev/printers.mllib b/dev/printers.mllib index f19edf1c80..b81fe151f7 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -117,6 +117,7 @@ Miscops Universes Termops Namegen +UState Evd Glob_ops Redops diff --git a/engine/engine.mllib b/engine/engine.mllib index dc7ff2a642..befeaa1476 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -1,5 +1,6 @@ Logic_monad Termops Namegen +UState Evd Proofview_monad diff --git a/engine/evd.ml b/engine/evd.ml index 79e73bda57..cfe9a3da40 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -259,221 +259,20 @@ let instantiate_evar_array info c args = | [] -> c | _ -> replace_vars inst c -module StringOrd = struct type t = string let compare = String.compare end -module UNameMap = struct - - include Map.Make(StringOrd) - - let union s t = - if s == t then s - else - merge (fun k l r -> - match l, r with - | Some _, _ -> l - | _, _ -> r) s t -end - -(* 2nd part used to check consistency on the fly. *) -type evar_universe_context = - { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t; - uctx_local : Univ.universe_context_set; (** The local context of variables *) - uctx_univ_variables : Universes.universe_opt_subst; - (** The local universes that are unification variables *) - uctx_univ_algebraic : Univ.universe_set; - (** The subset of unification variables that - can be instantiated with algebraic universes as they appear in types - and universe instances only. *) - uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) - uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) - } - -let empty_evar_universe_context = - { uctx_names = UNameMap.empty, Univ.LMap.empty; - uctx_local = Univ.ContextSet.empty; - uctx_univ_variables = Univ.LMap.empty; - uctx_univ_algebraic = Univ.LSet.empty; - uctx_universes = UGraph.initial_universes; - uctx_initial_universes = UGraph.initial_universes } - -let evar_universe_context_from e = - let u = universes e in - {empty_evar_universe_context with - uctx_universes = u; uctx_initial_universes = u} - -let is_empty_evar_universe_context ctx = - Univ.ContextSet.is_empty ctx.uctx_local && - Univ.LMap.is_empty ctx.uctx_univ_variables - -let union_evar_universe_context ctx ctx' = - if ctx == ctx' then ctx - else if is_empty_evar_universe_context ctx' then ctx - else - let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in - let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in - let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) - (Univ.ContextSet.levels ctx.uctx_local) in - let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in - let declarenew g = - Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g - in - let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in - { uctx_names = (names, names_rev); - uctx_local = local; - uctx_univ_variables = - Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; - uctx_univ_algebraic = - Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; - uctx_initial_universes = declarenew ctx.uctx_initial_universes; - uctx_universes = - if local == ctx.uctx_local then ctx.uctx_universes - else - let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in - UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes) } - -(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) -(* let union_evar_universe_context = *) -(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *) - +type evar_universe_context = UState.t type 'a in_evar_universe_context = 'a * evar_universe_context -let evar_universe_context_set diff ctx = - let initctx = ctx.uctx_local in - let cstrs = - Univ.LSet.fold - (fun l cstrs -> - try - match Univ.LMap.find l ctx.uctx_univ_variables with - | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs - | None -> cstrs - with Not_found | Option.IsNone -> cstrs) - (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty - in - Univ.ContextSet.add_constraints cstrs initctx - -let evar_universe_context_constraints ctx = snd ctx.uctx_local -let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local - -let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx } -let evar_universe_context_subst ctx = ctx.uctx_univ_variables - -let instantiate_variable l b v = - v := Univ.LMap.add l (Some b) !v - -exception UniversesDiffer - -let process_universe_constraints univs vars alg cstrs = - let vars = ref vars in - let normalize = Universes.normalize_universe_opt_subst vars in - let rec unify_universes fo l d r local = - let l = normalize l and r = normalize r in - if Univ.Universe.equal l r then local - else - let varinfo x = - match Univ.Universe.level x with - | None -> Inl x - | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) - in - if d == Universes.ULe then - if UGraph.check_leq univs l r then - (** Keep Prop/Set <= var around if var might be instantiated by prop or set - later. *) - if Univ.Universe.is_level l then - match Univ.Universe.level r with - | Some r -> - Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local - | _ -> local - else local - else - match Univ.Universe.level r with - | None -> error ("Algebraic universe on the right") - | Some rl -> - if Univ.Level.is_small rl then - let levels = Univ.Universe.levels l in - Univ.LSet.fold (fun l local -> - if Univ.Level.is_small l || Univ.LMap.mem l !vars then - unify_universes fo (Univ.Universe.make l) Universes.UEq r local - else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None))) - levels local - else - Univ.enforce_leq l r local - else if d == Universes.ULub then - match varinfo l, varinfo r with - | (Inr (l, true, _), Inr (r, _, _)) - | (Inr (r, _, _), Inr (l, true, _)) -> - instantiate_variable l (Univ.Universe.make r) vars; - Univ.enforce_eq_level l r local - | Inr (_, _, _), Inr (_, _, _) -> - unify_universes true l Universes.UEq r local - | _, _ -> assert false - else (* d = Universes.UEq *) - match varinfo l, varinfo r with - | Inr (l', lloc, _), Inr (r', rloc, _) -> - let () = - if lloc then - instantiate_variable l' r vars - else if rloc then - instantiate_variable r' l vars - else if not (UGraph.check_eq univs l r) then - (* Two rigid/global levels, none of them being local, - one of them being Prop/Set, disallow *) - if Univ.Level.is_small l' || Univ.Level.is_small r' then - raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) - else - if fo then - raise UniversesDiffer - in - Univ.enforce_eq_level l' r' local - | Inr (l, loc, alg), Inl r - | Inl r, Inr (l, loc, alg) -> - let inst = Univ.univ_level_rem l r r in - if alg then (instantiate_variable l inst vars; local) - else - let lu = Univ.Universe.make l in - if Univ.univ_level_mem l r then - Univ.enforce_leq inst lu local - else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) - | _, _ (* One of the two is algebraic or global *) -> - if UGraph.check_eq univs l r then local - else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) - in - let local = - Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local) - cstrs Univ.Constraint.empty - in - !vars, local - -let add_constraints_context ctx cstrs = - let univs, local = ctx.uctx_local in - let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> - let l = Univ.Universe.make l and r = Univ.Universe.make r in - let cstr' = - if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r) - else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r) - in Universes.Constraints.add cstr' acc) - cstrs Universes.Constraints.empty - in - let vars, local' = - process_universe_constraints ctx.uctx_universes - ctx.uctx_univ_variables ctx.uctx_univ_algebraic - cstrs' - in - { ctx with uctx_local = (univs, Univ.Constraint.union local local'); - uctx_univ_variables = vars; - uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } - -(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) -(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) - -let add_universe_constraints_context ctx cstrs = - let univs, local = ctx.uctx_local in - let vars, local' = - process_universe_constraints ctx.uctx_universes - ctx.uctx_univ_variables ctx.uctx_univ_algebraic - cstrs - in - { ctx with uctx_local = (univs, Univ.Constraint.union local local'); - uctx_univ_variables = vars; - uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } +let empty_evar_universe_context = UState.empty +let evar_universe_context_from = UState.from +let is_empty_evar_universe_context = UState.is_empty +let union_evar_universe_context = UState.union +let evar_universe_context_set = UState.context_set +let evar_universe_context_constraints = UState.constraints +let evar_context_universe_context = UState.context +let evar_universe_context_of = UState.of_context_set +let evar_universe_context_subst = UState.subst +let add_constraints_context = UState.add_constraints +let add_universe_constraints_context = UState.add_universe_constraints (* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) (* let add_universe_constraints_context = *) @@ -937,7 +736,7 @@ let evars_of_filtered_evar_info evi = (**********************************************************) (* Sort variables *) -type rigid = +type rigid = UState.rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -947,146 +746,32 @@ let univ_flexible_alg = UnivFlexible true let evar_universe_context d = d.universes -let universe_context_set d = d.universes.uctx_local - -let pr_uctx_level uctx = - let map, map_rev = uctx.uctx_names in - fun l -> - try str(Univ.LMap.find l map_rev) - with Not_found -> - Universes.pr_with_global_universes l - -let universe_context ?names evd = - match names with - | None -> Univ.ContextSet.to_context evd.universes.uctx_local - | Some pl -> - let levels = Univ.ContextSet.levels evd.universes.uctx_local in - let newinst, left = - List.fold_right - (fun (loc,id) (newinst, acc) -> - let l = - try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names) - with Not_found -> - user_err_loc (loc, "universe_context", - str"Universe " ++ pr_id id ++ str" is not bound anymore.") - in (l :: newinst, Univ.LSet.remove l acc)) - pl ([], levels) - in - if not (Univ.LSet.is_empty left) then - let n = Univ.LSet.cardinal left in - errorlabstrm "universe_context" - (str(CString.plural n "Universe") ++ spc () ++ - Univ.LSet.pr (pr_uctx_level evd.universes) left ++ - spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") - else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst), - Univ.ContextSet.constraints evd.universes.uctx_local) +let universe_context_set d = UState.context_set Univ.UContext.empty d.universes + +let pr_uctx_level = UState.pr_uctx_level +let universe_context ?names evd = UState.universe_context ?names evd.universes let restrict_universe_context evd vars = - let uctx = evd.universes in - let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in - { evd with universes = { uctx with uctx_local = uctx' } } - + { evd with universes = UState.restrict evd.universes vars } + let universe_subst evd = - evd.universes.uctx_univ_variables - -let merge_uctx sideff rigid uctx ctx' = - let open Univ in - let levels = ContextSet.levels ctx' in - let uctx = if sideff then uctx else - match rigid with - | UnivRigid -> uctx - | UnivFlexible b -> - let fold u accu = - if LMap.mem u accu then accu - else LMap.add u None accu - in - let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in - if b then - { uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels } - else { uctx with uctx_univ_variables = uvars' } - in - let uctx_local = - if sideff then uctx.uctx_local - else ContextSet.append ctx' uctx.uctx_local - in - let declare g = - LSet.fold (fun u g -> - try UGraph.add_universe u false g - with UGraph.AlreadyDeclared when sideff -> g) - levels g - in - let initial = declare uctx.uctx_initial_universes in - let univs = declare uctx.uctx_universes in - let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in - { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } + UState.subst evd.universes let merge_context_set ?(sideff=false) rigid evd ctx' = - {evd with universes = merge_uctx sideff rigid evd.universes ctx'} + {evd with universes = UState.merge sideff rigid evd.universes ctx'} -let merge_uctx_subst uctx s = - { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } - let merge_universe_subst evd subst = - {evd with universes = merge_uctx_subst evd.universes subst } + {evd with universes = UState.merge_subst evd.universes subst } let with_context_set rigid d (a, ctx) = (merge_context_set rigid d ctx, a) -let emit_universe_side_effects eff u = - Declareops.fold_side_effects - (fun acc eff -> - match eff with - | Declarations.SEscheme (l,s) -> - List.fold_left - (fun acc (_,_,cb,c) -> - let acc = match c with - | `Nothing -> acc - | `Opaque (s, ctx) -> merge_uctx true univ_rigid acc ctx - in if cb.Declarations.const_polymorphic then acc - else - merge_uctx true univ_rigid acc - (Univ.ContextSet.of_context cb.Declarations.const_universes)) - acc l - | Declarations.SEsubproof _ -> acc) - u eff - -let add_uctx_names s l (names, names_rev) = - (UNameMap.add s l names, Univ.LMap.add l s names_rev) - -let uctx_new_univ_variable rigid name predicative - ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = - let u = Universes.new_univ_level (Global.current_dirpath ()) in - let ctx' = Univ.ContextSet.add_universe u ctx in - let uctx', pred = - match rigid with - | UnivRigid -> uctx, true - | UnivFlexible b -> - let uvars' = Univ.LMap.add u None uvars in - if b then {uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = Univ.LSet.add u avars}, false - else {uctx with uctx_univ_variables = uvars'}, false - in - let names = - match name with - | Some n -> add_uctx_names n u uctx.uctx_names - | None -> uctx.uctx_names - in - let initial = - UGraph.add_universe u false uctx.uctx_initial_universes - in - let uctx' = - {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = UGraph.add_universe u false uctx.uctx_universes; - uctx_initial_universes = initial} - in uctx', u - let new_univ_level_variable ?name ?(predicative=true) rigid evd = - let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in + let uctx', u = UState.new_univ_variable rigid name evd.universes in ({evd with universes = uctx'}, u) let new_univ_variable ?name ?(predicative=true) rigid evd = - let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in + let uctx', u = UState.new_univ_variable rigid name evd.universes in ({evd with universes = uctx'}, Univ.Universe.make u) let new_sort_variable ?name ?(predicative=true) rigid d = @@ -1094,42 +779,12 @@ let new_sort_variable ?name ?(predicative=true) rigid d = (d', Type u) let add_global_univ d u = - let uctx = d.universes in - let initial = - UGraph.add_universe u true uctx.uctx_initial_universes - in - let univs = - UGraph.add_universe u true uctx.uctx_universes - in - { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; - uctx_initial_universes = initial; - uctx_universes = univs } } - + { d with universes = UState.add_global_univ d.universes u } + let make_flexible_variable evd b u = - let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in - let uvars' = Univ.LMap.add u None uvars in - let avars' = - if b then - let uu = Univ.Universe.make u in - let substu_not_alg u' v = - Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v - in - if not (Univ.LMap.exists substu_not_alg uvars) - then Univ.LSet.add u avars else avars - else avars - in - {evd with universes = {ctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = avars'}} - -let make_evar_universe_context e l = - let uctx = evar_universe_context_from e in - match l with - | None -> uctx - | Some us -> - List.fold_left - (fun uctx (loc,id) -> - fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx)) - uctx us + { evd with universes = UState.make_flexible_variable evd.universes b u } + +let make_evar_universe_context = UState.make (****************************************) (* Operations on constants *) @@ -1152,20 +807,11 @@ let fresh_global ?(rigid=univ_flexible) ?names env evd gr = let whd_sort_variable evd t = t -let is_sort_variable evd s = - match s with - | Type u -> - (match Univ.universe_level u with - | Some l as x -> - let uctx = evd.universes in - if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x - else None - | None -> None) - | _ -> None +let is_sort_variable evd s = UState.is_sort_variable evd.universes s let is_flexible_level evd l = let uctx = evd.universes in - Univ.LMap.mem l uctx.uctx_univ_variables + Univ.LMap.mem l (UState.subst uctx) let is_eq_sort s1 s2 = if Sorts.equal s1 s2 then None @@ -1176,12 +822,12 @@ let is_eq_sort s1 s2 = else Some (u1, u2) let normalize_universe evd = - let vars = ref evd.universes.uctx_univ_variables in + let vars = ref (UState.subst evd.universes) in let normalize = Universes.normalize_universe_opt_subst vars in normalize let normalize_universe_instance evd l = - let vars = ref evd.universes.uctx_univ_variables in + let vars = ref (UState.subst evd.universes) in let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in Univ.Instance.subst_fn normalize l @@ -1239,96 +885,28 @@ let set_leq_sort env evd s1 s2 = else evd let check_eq evd s s' = - UGraph.check_eq evd.universes.uctx_universes s s' + UGraph.check_eq (UState.ugraph evd.universes) s s' let check_leq evd s s' = - UGraph.check_leq evd.universes.uctx_universes s s' - -let subst_univs_context_with_def def usubst (ctx, cst) = - (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) + UGraph.check_leq (UState.ugraph evd.universes) s s' -let normalize_evar_universe_context_variables uctx = - let normalized_variables, undef, def, subst = - Universes.normalize_univ_variables uctx.uctx_univ_variables - in - let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in - let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in - subst, { uctx with uctx_local = ctx_local'; - uctx_univ_variables = normalized_variables; - uctx_universes = univs } +let normalize_evar_universe_context_variables = UState.normalize_variables (* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *) (* let normalize_evar_universe_context_variables = *) (* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *) -let abstract_undefined_variables uctx = - let vars' = - Univ.LMap.fold (fun u v acc -> - if v == None then Univ.LSet.remove u acc - else acc) - uctx.uctx_univ_variables uctx.uctx_univ_algebraic - in { uctx with uctx_local = Univ.ContextSet.empty; - uctx_univ_algebraic = vars' } - -let fix_undefined_variables ({ universes = uctx } as evm) = - let algs', vars' = - Univ.LMap.fold (fun u v (algs, vars as acc) -> - if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars) - else acc) - uctx.uctx_univ_variables - (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) - in - {evm with universes = - { uctx with uctx_univ_variables = vars'; - uctx_univ_algebraic = algs' } } +let abstract_undefined_variables = UState.abstract_undefined_variables - -let refresh_undefined_univ_variables uctx = - let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in - let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) - uctx.uctx_univ_algebraic Univ.LSet.empty - in - let vars = - Univ.LMap.fold - (fun u v acc -> - Univ.LMap.add (Univ.subst_univs_level_level subst u) - (Option.map (Univ.subst_univs_level_universe subst) v) acc) - uctx.uctx_univ_variables Univ.LMap.empty - in - let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) - (Univ.ContextSet.levels ctx') g in - let initial = declare uctx.uctx_initial_universes in - let univs = declare UGraph.initial_universes in - let uctx' = {uctx_names = uctx.uctx_names; - uctx_local = ctx'; - uctx_univ_variables = vars; uctx_univ_algebraic = alg; - uctx_universes = univs; - uctx_initial_universes = initial } in - uctx', subst +let fix_undefined_variables evd = + { evd with universes = UState.fix_undefined_variables evd.universes } let refresh_undefined_universes evd = - let uctx', subst = refresh_undefined_univ_variables evd.universes in + let uctx', subst = UState.refresh_undefined_univ_variables evd.universes in let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in evd', subst -let normalize_evar_universe_context uctx = - let rec fixpoint uctx = - let ((vars',algs'), us') = - Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables - uctx.uctx_univ_algebraic - in - if Univ.ContextSet.equal us' uctx.uctx_local then uctx - else - let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in - let uctx' = - { uctx_names = uctx.uctx_names; - uctx_local = us'; - uctx_univ_variables = vars'; - uctx_univ_algebraic = algs'; - uctx_universes = universes; - uctx_initial_universes = uctx.uctx_initial_universes } - in fixpoint uctx' - in fixpoint uctx +let normalize_evar_universe_context = UState.normalize let nf_univ_variables evd = let subst, uctx' = normalize_evar_universe_context_variables evd.universes in @@ -1346,14 +924,12 @@ let nf_constraints = Profile.profile1 nfconstrkey nf_constraints else nf_constraints -let universe_of_name evd s = - UNameMap.find s (fst evd.universes.uctx_names) +let universe_of_name evd s = UState.universe_of_name evd.universes s let add_universe_name evd s l = - let names' = add_uctx_names s l evd.universes.uctx_names in - {evd with universes = {evd.universes with uctx_names = names'}} + { evd with universes = UState.add_universe_name evd.universes s l } -let universes evd = evd.universes.uctx_universes +let universes evd = UState.ugraph evd.universes (* Conversion w.r.t. an evar map and its local universes. *) @@ -1362,10 +938,10 @@ let conversion_gen env evd pb t u = | Reduction.CONV -> Reduction.trans_conv_universes full_transparent_state ~evars:(existential_opt_value evd) env - evd.universes.uctx_universes t u + (UState.ugraph evd.universes) t u | Reduction.CUMUL -> Reduction.trans_conv_leq_universes full_transparent_state ~evars:(existential_opt_value evd) env - evd.universes.uctx_universes t u + (UState.ugraph evd.universes) t u (* let conversion_gen_key = Profile.declare_profile "conversion_gen" *) (* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *) @@ -1377,8 +953,10 @@ let test_conversion env d pb t u = try conversion_gen env d pb t u; true with _ -> false +exception UniversesDiffer = UState.UniversesDiffer + let eq_constr_univs evd t u = - let b, c = Universes.eq_constr_univs_infer evd.universes.uctx_universes t u in + let b, c = Universes.eq_constr_univs_infer (UState.ugraph evd.universes) t u in if b then try let evd' = add_universe_constraints evd c in evd', b with Univ.UniverseInconsistency _ | UniversesDiffer -> evd, false @@ -1393,7 +971,7 @@ let e_eq_constr_univs evdref t u = let emit_side_effects eff evd = { evd with effects = Declareops.union_side_effects eff evd.effects; - universes = emit_universe_side_effects eff evd.universes } + universes = UState.emit_side_effects eff evd.universes } let drop_side_effects evd = { evd with effects = Declareops.no_seff; } @@ -1760,11 +1338,11 @@ let pr_evar_universe_context ctx = if is_empty_evar_universe_context ctx then mt () else (str"UNIVERSES:"++brk(0,1)++ - h 0 (Univ.pr_universe_context_set prl ctx.uctx_local) ++ fnl () ++ + h 0 (Univ.pr_universe_context_set prl (evar_universe_context_set Univ.UContext.empty ctx)) ++ fnl () ++ str"ALGEBRAIC UNIVERSES:"++brk(0,1)++ - h 0 (Univ.LSet.pr prl ctx.uctx_univ_algebraic) ++ fnl() ++ + h 0 (Univ.LSet.pr prl (UState.variables ctx)) ++ fnl() ++ str"UNDEFINED UNIVERSES:"++brk(0,1)++ - h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables) ++ fnl()) + h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl()) let print_env_short env = let pr_body n = function diff --git a/engine/evd.mli b/engine/evd.mli index d659b8826e..796f503746 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -119,7 +119,7 @@ val map_evar_info : (constr -> constr) -> evar_info -> evar_info (** {6 Unification state} **) -type evar_universe_context +type evar_universe_context = UState.t (** The universe context associated to an evar map *) type evar_map @@ -464,7 +464,7 @@ val retract_coercible_metas : evar_map -> metabinding list * evar_map (** Rigid or flexible universe variables *) -type rigid = +type rigid = UState.rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) diff --git a/engine/uState.ml b/engine/uState.ml new file mode 100644 index 0000000000..2eb0519b78 --- /dev/null +++ b/engine/uState.ml @@ -0,0 +1,484 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + match l, r with + | Some _, _ -> l + | _, _ -> r) s t +end + +(* 2nd part used to check consistency on the fly. *) +type t = + { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t; + uctx_local : Univ.universe_context_set; (** The local context of variables *) + uctx_univ_variables : Universes.universe_opt_subst; + (** The local universes that are unification variables *) + uctx_univ_algebraic : Univ.universe_set; + (** The subset of unification variables that + can be instantiated with algebraic universes as they appear in types + and universe instances only. *) + uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) + uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) + } + +let empty = + { uctx_names = UNameMap.empty, Univ.LMap.empty; + uctx_local = Univ.ContextSet.empty; + uctx_univ_variables = Univ.LMap.empty; + uctx_univ_algebraic = Univ.LSet.empty; + uctx_universes = UGraph.initial_universes; + uctx_initial_universes = UGraph.initial_universes } + +let from e = + let u = Environ.universes e in + { empty with + uctx_universes = u; uctx_initial_universes = u} + +let is_empty ctx = + Univ.ContextSet.is_empty ctx.uctx_local && + Univ.LMap.is_empty ctx.uctx_univ_variables + +let union ctx ctx' = + if ctx == ctx' then ctx + else if is_empty ctx' then ctx + else + let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in + let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in + let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) + (Univ.ContextSet.levels ctx.uctx_local) in + let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in + let declarenew g = + Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) newus g + in + let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in + { uctx_names = (names, names_rev); + uctx_local = local; + uctx_univ_variables = + Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + uctx_initial_universes = declarenew ctx.uctx_initial_universes; + uctx_universes = + if local == ctx.uctx_local then ctx.uctx_universes + else + let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes) } + +let context_set diff ctx = + let initctx = ctx.uctx_local in + let cstrs = + Univ.LSet.fold + (fun l cstrs -> + try + match Univ.LMap.find l ctx.uctx_univ_variables with + | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs + | None -> cstrs + with Not_found | Option.IsNone -> cstrs) + (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty + in + Univ.ContextSet.add_constraints cstrs initctx + +let constraints ctx = snd ctx.uctx_local + +let context ctx = Univ.ContextSet.to_context ctx.uctx_local + +let of_context_set ctx = { empty with uctx_local = ctx } + +let subst ctx = ctx.uctx_univ_variables + +let ugraph ctx = ctx.uctx_universes + +let variables ctx = ctx.uctx_univ_algebraic + +let instantiate_variable l b v = + v := Univ.LMap.add l (Some b) !v + +exception UniversesDiffer + +let process_universe_constraints univs vars alg cstrs = + let vars = ref vars in + let normalize = Universes.normalize_universe_opt_subst vars in + let rec unify_universes fo l d r local = + let l = normalize l and r = normalize r in + if Univ.Universe.equal l r then local + else + let varinfo x = + match Univ.Universe.level x with + | None -> Inl x + | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) + in + if d == Universes.ULe then + if UGraph.check_leq univs l r then + (** Keep Prop/Set <= var around if var might be instantiated by prop or set + later. *) + if Univ.Universe.is_level l then + match Univ.Universe.level r with + | Some r -> + Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local + | _ -> local + else local + else + match Univ.Universe.level r with + | None -> error ("Algebraic universe on the right") + | Some rl -> + if Univ.Level.is_small rl then + let levels = Univ.Universe.levels l in + Univ.LSet.fold (fun l local -> + if Univ.Level.is_small l || Univ.LMap.mem l !vars then + unify_universes fo (Univ.Universe.make l) Universes.UEq r local + else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None))) + levels local + else + Univ.enforce_leq l r local + else if d == Universes.ULub then + match varinfo l, varinfo r with + | (Inr (l, true, _), Inr (r, _, _)) + | (Inr (r, _, _), Inr (l, true, _)) -> + instantiate_variable l (Univ.Universe.make r) vars; + Univ.enforce_eq_level l r local + | Inr (_, _, _), Inr (_, _, _) -> + unify_universes true l Universes.UEq r local + | _, _ -> assert false + else (* d = Universes.UEq *) + match varinfo l, varinfo r with + | Inr (l', lloc, _), Inr (r', rloc, _) -> + let () = + if lloc then + instantiate_variable l' r vars + else if rloc then + instantiate_variable r' l vars + else if not (UGraph.check_eq univs l r) then + (* Two rigid/global levels, none of them being local, + one of them being Prop/Set, disallow *) + if Univ.Level.is_small l' || Univ.Level.is_small r' then + raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + else + if fo then + raise UniversesDiffer + in + Univ.enforce_eq_level l' r' local + | Inr (l, loc, alg), Inl r + | Inl r, Inr (l, loc, alg) -> + let inst = Univ.univ_level_rem l r r in + if alg then (instantiate_variable l inst vars; local) + else + let lu = Univ.Universe.make l in + if Univ.univ_level_mem l r then + Univ.enforce_leq inst lu local + else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) + | _, _ (* One of the two is algebraic or global *) -> + if UGraph.check_eq univs l r then local + else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) + in + let local = + Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local) + cstrs Univ.Constraint.empty + in + !vars, local + +let add_constraints ctx cstrs = + let univs, local = ctx.uctx_local in + let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> + let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstr' = + if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r) + else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r) + in Universes.Constraints.add cstr' acc) + cstrs Universes.Constraints.empty + in + let vars, local' = + process_universe_constraints ctx.uctx_universes + ctx.uctx_univ_variables ctx.uctx_univ_algebraic + cstrs' + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_univ_variables = vars; + uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } + +(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) +(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) + +let add_universe_constraints ctx cstrs = + let univs, local = ctx.uctx_local in + let vars, local' = + process_universe_constraints ctx.uctx_universes + ctx.uctx_univ_variables ctx.uctx_univ_algebraic + cstrs + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_univ_variables = vars; + uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } + +let pr_uctx_level uctx = + let map, map_rev = uctx.uctx_names in + fun l -> + try str(Univ.LMap.find l map_rev) + with Not_found -> + Universes.pr_with_global_universes l + +let universe_context ?names ctx = + match names with + | None -> Univ.ContextSet.to_context ctx.uctx_local + | Some pl -> + let levels = Univ.ContextSet.levels ctx.uctx_local in + let newinst, left = + List.fold_right + (fun (loc,id) (newinst, acc) -> + let l = + try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) + with Not_found -> + user_err_loc (loc, "universe_context", + str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") + in (l :: newinst, Univ.LSet.remove l acc)) + pl ([], levels) + in + if not (Univ.LSet.is_empty left) then + let n = Univ.LSet.cardinal left in + errorlabstrm "universe_context" + (str(CString.plural n "Universe") ++ spc () ++ + Univ.LSet.pr (pr_uctx_level ctx) left ++ + spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") + else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst), + Univ.ContextSet.constraints ctx.uctx_local) + +let restrict ctx vars = + let uctx' = Universes.restrict_universe_context ctx.uctx_local vars in + { ctx with uctx_local = uctx' } + +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +let univ_rigid = UnivRigid +let univ_flexible = UnivFlexible false +let univ_flexible_alg = UnivFlexible true + +let merge sideff rigid uctx ctx' = + let open Univ in + let levels = ContextSet.levels ctx' in + let uctx = if sideff then uctx else + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let fold u accu = + if LMap.mem u accu then accu + else LMap.add u None accu + in + let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in + if b then + { uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels } + else { uctx with uctx_univ_variables = uvars' } + in + let uctx_local = + if sideff then uctx.uctx_local + else ContextSet.append ctx' uctx.uctx_local + in + let declare g = + LSet.fold (fun u g -> + try UGraph.add_universe u false g + with UGraph.AlreadyDeclared when sideff -> g) + levels g + in + let initial = declare uctx.uctx_initial_universes in + let univs = declare uctx.uctx_universes in + let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in + { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } + +let merge_subst uctx s = + { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } + +let emit_side_effects eff u = + Declareops.fold_side_effects + (fun acc eff -> + match eff with + | Declarations.SEscheme (l,s) -> + List.fold_left + (fun acc (_,_,cb,c) -> + let acc = match c with + | `Nothing -> acc + | `Opaque (s, ctx) -> merge true univ_rigid acc ctx + in if cb.Declarations.const_polymorphic then acc + else + merge true univ_rigid acc + (Univ.ContextSet.of_context cb.Declarations.const_universes)) + acc l + | Declarations.SEsubproof _ -> acc) + u eff + +let add_uctx_names s l (names, names_rev) = + (UNameMap.add s l names, Univ.LMap.add l s names_rev) + +let new_univ_variable rigid name + ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = + let u = Universes.new_univ_level (Global.current_dirpath ()) in + let ctx' = Univ.ContextSet.add_universe u ctx in + let uctx', pred = + match rigid with + | UnivRigid -> uctx, true + | UnivFlexible b -> + let uvars' = Univ.LMap.add u None uvars in + if b then {uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.add u avars}, false + else {uctx with uctx_univ_variables = uvars'}, false + in + let names = + match name with + | Some n -> add_uctx_names n u uctx.uctx_names + | None -> uctx.uctx_names + in + let initial = + UGraph.add_universe u false uctx.uctx_initial_universes + in + let uctx' = + {uctx' with uctx_names = names; uctx_local = ctx'; + uctx_universes = UGraph.add_universe u false uctx.uctx_universes; + uctx_initial_universes = initial} + in uctx', u + +let add_global_univ uctx u = + let initial = + UGraph.add_universe u true uctx.uctx_initial_universes + in + let univs = + UGraph.add_universe u true uctx.uctx_universes + in + { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; + uctx_initial_universes = initial; + uctx_universes = univs } + +let make_flexible_variable ctx b u = + let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} = ctx in + let uvars' = Univ.LMap.add u None uvars in + let avars' = + if b then + let uu = Univ.Universe.make u in + let substu_not_alg u' v = + Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v + in + if not (Univ.LMap.exists substu_not_alg uvars) + then Univ.LSet.add u avars else avars + else avars + in + {ctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = avars'} + +let make e l = + let uctx = from e in + match l with + | None -> uctx + | Some us -> + List.fold_left + (fun uctx (loc,id) -> + fst (new_univ_variable univ_rigid (Some (Id.to_string id)) uctx)) + uctx us + +let is_sort_variable uctx s = + match s with + | Sorts.Type u -> + (match Univ.universe_level u with + | Some l as x -> + if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x + else None + | None -> None) + | _ -> None + +let subst_univs_context_with_def def usubst (ctx, cst) = + (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) + +let normalize_variables uctx = + let normalized_variables, undef, def, subst = + Universes.normalize_univ_variables uctx.uctx_univ_variables + in + let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in + subst, { uctx with uctx_local = ctx_local'; + uctx_univ_variables = normalized_variables; + uctx_universes = univs } + +let abstract_undefined_variables uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None then Univ.LSet.remove u acc + else acc) + uctx.uctx_univ_variables uctx.uctx_univ_algebraic + in { uctx with uctx_local = Univ.ContextSet.empty; + uctx_univ_algebraic = vars' } + +let fix_undefined_variables uctx = + let algs', vars' = + Univ.LMap.fold (fun u v (algs, vars as acc) -> + if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars) + else acc) + uctx.uctx_univ_variables + (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) + in + { uctx with uctx_univ_variables = vars'; + uctx_univ_algebraic = algs' } + +let refresh_undefined_univ_variables uctx = + let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in + let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) + uctx.uctx_univ_algebraic Univ.LSet.empty + in + let vars = + Univ.LMap.fold + (fun u v acc -> + Univ.LMap.add (Univ.subst_univs_level_level subst u) + (Option.map (Univ.subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables Univ.LMap.empty + in + let declare g = Univ.LSet.fold (fun u g -> UGraph.add_universe u false g) + (Univ.ContextSet.levels ctx') g in + let initial = declare uctx.uctx_initial_universes in + let univs = declare UGraph.initial_universes in + let uctx' = {uctx_names = uctx.uctx_names; + uctx_local = ctx'; + uctx_univ_variables = vars; uctx_univ_algebraic = alg; + uctx_universes = univs; + uctx_initial_universes = initial } in + uctx', subst + +let normalize uctx = + let rec fixpoint uctx = + let ((vars',algs'), us') = + Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables + uctx.uctx_univ_algebraic + in + if Univ.ContextSet.equal us' uctx.uctx_local then uctx + else + let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in + let uctx' = + { uctx_names = uctx.uctx_names; + uctx_local = us'; + uctx_univ_variables = vars'; + uctx_univ_algebraic = algs'; + uctx_universes = universes; + uctx_initial_universes = uctx.uctx_initial_universes } + in fixpoint uctx' + in fixpoint uctx + +let universe_of_name uctx s = + UNameMap.find s (fst uctx.uctx_names) + +let add_universe_name uctx s l = + let names' = add_uctx_names s l uctx.uctx_names in + { uctx with uctx_names = names' } diff --git a/engine/uState.mli b/engine/uState.mli new file mode 100644 index 0000000000..c3b28d0a6a --- /dev/null +++ b/engine/uState.mli @@ -0,0 +1,83 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + +val make : Environ.env -> Id.t Loc.located list option -> t + +val is_empty : t -> bool + +val union : t -> t -> t + +val of_context_set : Univ.universe_context_set -> t + +(** {5 Projections} *) + +val context_set : Univ.universe_context -> t -> Univ.universe_context_set +val constraints : t -> Univ.constraints +val context : t -> Univ.universe_context +val subst : t -> Universes.universe_opt_subst +val ugraph : t -> UGraph.t +val variables : t -> Univ.LSet.t + +(** {5 Constraints handling} *) + +val add_constraints : t -> Univ.constraints -> t +val add_universe_constraints : t -> Universes.universe_constraints -> t + +(** {5 TODO: Document me} *) + +val universe_context : ?names:(Id.t Loc.located) list -> t -> Univ.universe_context + +val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds + +val restrict : t -> Univ.universe_set -> t + +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +val univ_rigid : rigid +val univ_flexible : rigid +val univ_flexible_alg : rigid + +val merge : bool -> rigid -> t -> Univ.universe_context_set -> t +val merge_subst : t -> Universes.universe_opt_subst -> t +val emit_side_effects : Declareops.side_effects -> t -> t + +val new_univ_variable : rigid -> string option -> t -> t * Univ.Level.t +val add_global_univ : t -> Univ.Level.t -> t +val make_flexible_variable : t -> bool -> Univ.Level.t -> t + +val is_sort_variable : t -> Sorts.t -> Univ.Level.t option + +val normalize_variables : t -> Univ.universe_subst * t + +val abstract_undefined_variables : t -> t + +val fix_undefined_variables : t -> t + +val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst + +val normalize : t -> t + +val universe_of_name : t -> string -> Univ.Level.t + +val add_universe_name : t -> string -> Univ.Level.t -> t -- cgit v1.2.3 From d558bf5289e87899a850dda410a3a3c4de1ce979 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Oct 2015 18:55:42 +0200 Subject: Clarifying and documenting the UState API. --- engine/evd.ml | 22 +++++++++++++------ engine/evd.mli | 4 +++- engine/uState.ml | 41 ++++++++++++----------------------- engine/uState.mli | 54 ++++++++++++++++++++++++++++++++++++----------- proofs/proof_global.ml | 11 +++++++--- stm/lemmas.ml | 2 +- tactics/extratactics.ml4 | 2 +- toplevel/command.ml | 4 ++-- toplevel/vernacentries.ml | 2 +- 9 files changed, 87 insertions(+), 55 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index cfe9a3da40..52bfc2d1d1 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -263,7 +263,6 @@ type evar_universe_context = UState.t type 'a in_evar_universe_context = 'a * evar_universe_context let empty_evar_universe_context = UState.empty -let evar_universe_context_from = UState.from let is_empty_evar_universe_context = UState.is_empty let union_evar_universe_context = UState.union let evar_universe_context_set = UState.context_set @@ -273,6 +272,7 @@ let evar_universe_context_of = UState.of_context_set let evar_universe_context_subst = UState.subst let add_constraints_context = UState.add_constraints let add_universe_constraints_context = UState.add_universe_constraints +let constrain_variables = UState.constrain_variables (* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) (* let add_universe_constraints_context = *) @@ -587,7 +587,7 @@ let empty = { } let from_env e = - { empty with universes = evar_universe_context_from e } + { empty with universes = UState.make (Environ.universes e) } let from_ctx ctx = { empty with universes = ctx } @@ -746,7 +746,7 @@ let univ_flexible_alg = UnivFlexible true let evar_universe_context d = d.universes -let universe_context_set d = UState.context_set Univ.UContext.empty d.universes +let universe_context_set d = UState.context_set d.universes let pr_uctx_level = UState.pr_uctx_level let universe_context ?names evd = UState.universe_context ?names evd.universes @@ -784,8 +784,16 @@ let add_global_univ d u = let make_flexible_variable evd b u = { evd with universes = UState.make_flexible_variable evd.universes b u } -let make_evar_universe_context = UState.make - +let make_evar_universe_context e l = + let uctx = UState.make (Environ.universes e) in + match l with + | None -> uctx + | Some us -> + List.fold_left + (fun uctx (loc,id) -> + fst (UState.new_univ_variable univ_rigid (Some (Id.to_string id)) uctx)) + uctx us + (****************************************) (* Operations on constants *) (****************************************) @@ -1338,9 +1346,9 @@ let pr_evar_universe_context ctx = if is_empty_evar_universe_context ctx then mt () else (str"UNIVERSES:"++brk(0,1)++ - h 0 (Univ.pr_universe_context_set prl (evar_universe_context_set Univ.UContext.empty ctx)) ++ fnl () ++ + h 0 (Univ.pr_universe_context_set prl (evar_universe_context_set ctx)) ++ fnl () ++ str"ALGEBRAIC UNIVERSES:"++brk(0,1)++ - h 0 (Univ.LSet.pr prl (UState.variables ctx)) ++ fnl() ++ + h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++ str"UNDEFINED UNIVERSES:"++brk(0,1)++ h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl()) diff --git a/engine/evd.mli b/engine/evd.mli index 796f503746..dc498ed42e 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -474,7 +474,7 @@ val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * evar_universe_context -val evar_universe_context_set : Univ.universe_context -> evar_universe_context -> Univ.universe_context_set +val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set val evar_universe_context_constraints : evar_universe_context -> Univ.constraints val evar_context_universe_context : evar_universe_context -> Univ.universe_context val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context @@ -482,6 +482,8 @@ val empty_evar_universe_context : evar_universe_context val union_evar_universe_context : evar_universe_context -> evar_universe_context -> evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst +val constrain_variables : Univ.LSet.t -> evar_universe_context -> Univ.constraints + val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map diff --git a/engine/uState.ml b/engine/uState.ml index 2eb0519b78..227c4ad52b 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -47,8 +47,7 @@ let empty = uctx_universes = UGraph.initial_universes; uctx_initial_universes = UGraph.initial_universes } -let from e = - let u = Environ.universes e in +let make u = { empty with uctx_universes = u; uctx_initial_universes = u} @@ -82,20 +81,8 @@ let union ctx ctx' = let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes) } -let context_set diff ctx = - let initctx = ctx.uctx_local in - let cstrs = - Univ.LSet.fold - (fun l cstrs -> - try - match Univ.LMap.find l ctx.uctx_univ_variables with - | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs - | None -> cstrs - with Not_found | Option.IsNone -> cstrs) - (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty - in - Univ.ContextSet.add_constraints cstrs initctx - +let context_set ctx = ctx.uctx_local + let constraints ctx = snd ctx.uctx_local let context ctx = Univ.ContextSet.to_context ctx.uctx_local @@ -106,7 +93,17 @@ let subst ctx = ctx.uctx_univ_variables let ugraph ctx = ctx.uctx_universes -let variables ctx = ctx.uctx_univ_algebraic +let algebraics ctx = ctx.uctx_univ_algebraic + +let constrain_variables diff ctx = + Univ.LSet.fold + (fun l cstrs -> + try + match Univ.LMap.find l ctx.uctx_univ_variables with + | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs + | None -> cstrs + with Not_found | Option.IsNone -> cstrs) + diff Univ.Constraint.empty let instantiate_variable l b v = v := Univ.LMap.add l (Some b) !v @@ -381,16 +378,6 @@ let make_flexible_variable ctx b u = {ctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = avars'} -let make e l = - let uctx = from e in - match l with - | None -> uctx - | Some us -> - List.fold_left - (fun uctx (loc,id) -> - fst (new_univ_variable univ_rigid (Some (Id.to_string id)) uctx)) - uctx us - let is_sort_variable uctx s = match s with | Sorts.Type u -> diff --git a/engine/uState.mli b/engine/uState.mli index c3b28d0a6a..56e0fe14e5 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -13,14 +13,14 @@ open Names exception UniversesDiffer type t +(** Type of universe unification states. They allow the incremental building of + universe constraints during an interactive proof. *) (** {5 Constructors} *) val empty : t -val from : Environ.env -> t - -val make : Environ.env -> Id.t Loc.located list option -> t +val make : UGraph.t -> t val is_empty : t -> bool @@ -30,23 +30,47 @@ val of_context_set : Univ.universe_context_set -> t (** {5 Projections} *) -val context_set : Univ.universe_context -> t -> Univ.universe_context_set -val constraints : t -> Univ.constraints -val context : t -> Univ.universe_context +val context_set : t -> Univ.universe_context_set +(** The local context of the state, i.e. a set of bound variables together + with their associated constraints. *) + val subst : t -> Universes.universe_opt_subst +(** The local universes that are unification variables *) + val ugraph : t -> UGraph.t -val variables : t -> Univ.LSet.t +(** The current graph extended with the local constraints *) + +val algebraics : t -> Univ.LSet.t +(** The subset of unification variables that can be instantiated with algebraic + universes as they appear in types and universe instances only. *) + +val constraints : t -> Univ.constraints +(** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *) + +val context : t -> Univ.universe_context +(** Shorthand for {!context_set} with {!Context_set.to_context}. *) (** {5 Constraints handling} *) val add_constraints : t -> Univ.constraints -> t +(** + @raise UniversesDiffer +*) + val add_universe_constraints : t -> Universes.universe_constraints -> t +(** + @raise UniversesDiffer +*) -(** {5 TODO: Document me} *) +(** {5 Names} *) -val universe_context : ?names:(Id.t Loc.located) list -> t -> Univ.universe_context +val add_universe_name : t -> string -> Univ.Level.t -> t +(** Associate a human-readable name to a local variable. *) -val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds +val universe_of_name : t -> string -> Univ.Level.t +(** Retrieve the universe associated to the name. *) + +(** {5 Unification} *) val restrict : t -> Univ.universe_set -> t @@ -70,6 +94,8 @@ val is_sort_variable : t -> Sorts.t -> Univ.Level.t option val normalize_variables : t -> Univ.universe_subst * t +val constrain_variables : Univ.LSet.t -> t -> Univ.constraints + val abstract_undefined_variables : t -> t val fix_undefined_variables : t -> t @@ -78,6 +104,10 @@ val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst val normalize : t -> t -val universe_of_name : t -> string -> Univ.Level.t +(** {5 TODO: Document me} *) -val add_universe_name : t -> string -> Univ.Level.t -> t +val universe_context : ?names:(Id.t Loc.located) list -> t -> Univ.universe_context + +(** {5 Pretty-printing} *) + +val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5c6ed33961..4af18ab2d5 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -298,6 +298,11 @@ let get_open_goals () = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) + List.length shelf +let constrain_variables init uctx = + let levels = Univ.Instance.levels (Univ.UContext.instance init) in + let cstrs = UState.constrain_variables levels uctx in + Univ.ContextSet.add_constraints cstrs (UState.context_set uctx) + let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let { pid; section_vars; strength; proof; terminator } = cur_pstate () in let poly = pi2 strength (* Polymorphic *) in @@ -326,7 +331,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let used_univs_typ = Universes.universes_of_constr typ in if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in - let ctx = Evd.evar_universe_context_set initunivs universes in + let ctx = constrain_variables initunivs universes in (* For vi2vo compilation proofs are computed now but we need to * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) @@ -334,7 +339,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in - let ctx = Evd.evar_universe_context_set initunivs universes in + let ctx = constrain_variables initunivs universes in (* Since the proof is computed now, we can simply have 1 set of * constraints in which we merge the ones for the body and the ones * for the typ *) @@ -349,7 +354,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let initunivs = Evd.evar_context_universe_context initial_euctx in Future.from_val (initunivs, nf t), Future.chain ~pure:true p (fun (pt,eff) -> - (pt,Evd.evar_universe_context_set initunivs (Future.force univs)),eff) + (pt,constrain_variables initunivs (Future.force univs)),eff) in let entries = Future.map2 (fun p (_, t) -> diff --git a/stm/lemmas.ml b/stm/lemmas.ml index d26af04baa..5f034e361e 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -428,7 +428,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = let body,opaq = retrieve_first_recthm ref in let subst = Evd.evar_universe_context_subst ctx in let norm c = Universes.subst_opt_univs_constr subst c in - let ctx = Evd.evar_universe_context_set (*FIXME*) Univ.UContext.empty ctx in + let ctx = UState.context_set (*FIXME*) ctx in let body = Option.map norm body in List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index cab74968d2..1a3f460399 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -268,7 +268,7 @@ let add_rewrite_hint bases ort t lcsr = let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in let ctx = - let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in + let ctx = UState.context_set ctx in if poly then ctx else (Global.push_context_set false ctx; Univ.ContextSet.empty) in diff --git a/toplevel/command.ml b/toplevel/command.ml index 7c86d2d059..06e2be72d8 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -1127,7 +1127,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexe let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in + let ctx = UState.context_set ctx in let ctx = Universes.restrict_universe_context ctx vars in let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in let ctx = Univ.ContextSet.to_context ctx in @@ -1160,7 +1160,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in + let ctx = UState.context_set ctx in let ctx = Univ.ContextSet.to_context ctx in ignore (List.map4 (declare_fix (local, poly, CoFixpoint) ctx) fixnames fixdecls fixtypes fiximps); diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index fc0e5beaad..5344909b61 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1547,7 +1547,7 @@ let vernac_global_check c = let sigma = Evd.from_env env in let c,ctx = interp_constr env sigma c in let senv = Global.safe_env() in - let cstrs = snd (Evd.evar_universe_context_set Univ.UContext.empty ctx) in + let cstrs = snd (UState.context_set ctx) in let senv = Safe_typing.add_constraints cstrs senv in let j = Safe_typing.typing senv c in let env = Safe_typing.env_of_safe_env senv in -- cgit v1.2.3 From 7cfb1c359faf13cd55bd92cba21fb00ca8d2d0d2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Sep 2015 19:08:11 +0200 Subject: Adding a notion of monotonous evarmap. --- dev/printers.mllib | 1 + engine/engine.mllib | 1 + engine/sigma.ml | 83 +++++++++++++++++++++++++++++++++++++++++++ engine/sigma.mli | 100 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 185 insertions(+) create mode 100644 engine/sigma.ml create mode 100644 engine/sigma.mli diff --git a/dev/printers.mllib b/dev/printers.mllib index b81fe151f7..de43efa670 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -119,6 +119,7 @@ Termops Namegen UState Evd +Sigma Glob_ops Redops Reductionops diff --git a/engine/engine.mllib b/engine/engine.mllib index befeaa1476..7197a25838 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -3,4 +3,5 @@ Termops Namegen UState Evd +Sigma Proofview_monad diff --git a/engine/sigma.ml b/engine/sigma.ml new file mode 100644 index 0000000000..e6189e29ce --- /dev/null +++ b/engine/sigma.ml @@ -0,0 +1,83 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ) = fun _ _ -> () + +type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma + +type 'a evar = Evar.t + +let lift_evar evk () = evk + +let to_evar_map evd = evd +let to_evar evk = evk + +(** API *) + +type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh + +let new_evar sigma ?naming info = + let (sigma, evk) = Evd.new_evar sigma ?naming info in + Fresh (evk, sigma, ()) + +let define evk c sigma = + Sigma ((), Evd.define evk c sigma, ()) + +(** Run *) + +type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } + +let run sigma f : 'a * Evd.evar_map = + let Sigma (x, sigma, ()) = f.run sigma in + (x, sigma) + +(** Monotonic references *) + +type evdref = Evd.evar_map ref + +let apply evdref f = + let Sigma (x, sigma, ()) = f.run !evdref in + evdref := sigma; + x + +let purify f = + let f (sigma : Evd.evar_map) = + let evdref = ref sigma in + let ans = f evdref in + Sigma (ans, !evdref, ()) + in + { run = f } + +(** Unsafe primitives *) + +module Unsafe = +struct + +let le = () +let of_evar_map sigma = sigma +let of_evar evk = evk +let of_ref ref = ref +let of_pair (x, sigma) = Sigma (x, sigma, ()) + +end + +module Notations = +struct + type ('a, 'r) sigma_ = ('a, 'r) sigma = + Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ + + let (+>) = fun _ _ -> () + + type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } +end diff --git a/engine/sigma.mli b/engine/sigma.mli new file mode 100644 index 0000000000..f4c47e08c6 --- /dev/null +++ b/engine/sigma.mli @@ -0,0 +1,100 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ('b, 'c) le -> ('a, 'c) le +(** Transitivity of anteriority *) + +val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le +(** Alias for {!cons} *) + +(** {5 Monotonous evarmaps} *) + +type 'r t +(** Stage-indexed evarmaps. *) + +type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma +(** Return values at a later stage *) + +type 'r evar +(** Stage-indexed evars *) + +(** {5 Postponing} *) + +val lift_evar : 'r evar -> ('r, 's) le -> 's evar +(** Any evar existing at stage ['r] is also valid at any later stage. *) + +(** {5 Downcasting} *) + +val to_evar_map : 'r t -> Evd.evar_map +val to_evar : 'r evar -> Evar.t + +(** {5 Monotonous API} *) + +type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh + +val new_evar : 'r t -> ?naming:Misctypes.intro_pattern_naming_expr -> + Evd.evar_info -> 'r fresh + +val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma + +(** FILLME *) + +(** {5 Run} *) + +type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } + +val run : Evd.evar_map -> 'a run -> 'a * Evd.evar_map + +(** {5 Imperative monotonic functions} *) + +type evdref +(** Monotonic references over evarmaps *) + +val apply : evdref -> 'a run -> 'a +(** Apply a monotonic function on a reference. *) + +val purify : (evdref -> 'a) -> 'a run +(** Converse of {!apply}. *) + +(** {5 Unsafe primitives} *) + +module Unsafe : +sig + val le : ('a, 'b) le + val of_evar_map : Evd.evar_map -> 'r t + val of_evar : Evd.evar -> 'r evar + val of_ref : Evd.evar_map ref -> evdref + val of_pair : ('a * Evd.evar_map) -> ('a, 'r) sigma +end + +(** {5 Notations} *) + +module Notations : +sig + type ('a, 'r) sigma_ = ('a, 'r) sigma = + Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma_ + + type 'a run_ = 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } + + val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le + (** Alias for {!cons} *) +end -- cgit v1.2.3 From 14edc57ac5ad75bbc4ea8559111606aea8978f48 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 18 Oct 2015 19:35:57 +0200 Subject: Adding a function to mirror decompose_prod_n_assum in that it counts let-ins, to compensate decompose_lam_n_assum which does not count let-ins. Any idea on a uniform and clear naming scheme for this kind of decomposition functions? --- kernel/term.ml | 28 +++++++++++++++++++++++----- kernel/term.mli | 31 ++++++++++++++++++++----------- 2 files changed, 43 insertions(+), 16 deletions(-) diff --git a/kernel/term.ml b/kernel/term.ml index 7bf4c8182d..33ed25fe1b 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -566,8 +566,10 @@ let decompose_lam_assum = in lamdec_rec empty_rel_context -(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T - into the pair ([(xn,Tn);...;(x1,T1)],T) *) +(* Given a positive integer n, decompose a product or let-in term + of the form [forall (x1:T1)..(xi:=ci:Ti)..(xn:Tn), T] into the pair + of the quantifying context [(xn,None,Tn);..;(xi,Some + ci,Ti);..;(x1,None,T1)] and of the inner type [T]) *) let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; @@ -581,10 +583,12 @@ let decompose_prod_n_assum n = in prodec_rec empty_rel_context n -(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T - into the pair ([(xn,Tn);...;(x1,T1)],T) +(* Given a positive integer n, decompose a lambda or let-in term [fun + (x1:T1)..(xi:=ci:Ti)..(xn:Tn) => T] into the pair of the abstracted + context [(xn,None,Tn);...;(xi,Some ci,Ti);...;(x1,None,T1)] and of + the inner body [T]. Lets in between are not expanded but turn into local definitions, - but n is the actual number of destructurated lambdas. *) + but n is the actual number of destructurated lambdas. *) let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; @@ -598,6 +602,20 @@ let decompose_lam_n_assum n = in lamdec_rec empty_rel_context n +(* Same, counting let-in *) +let decompose_lam_n_decls n = + if n < 0 then + error "decompose_lam_n_decls: integer parameter must be positive"; + let rec lamdec_rec l n c = + if Int.equal n 0 then l,c + else match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c + | Cast (c,_,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n_decls: not enough abstractions" + in + lamdec_rec empty_rel_context n + (* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction * gives n (casts are ignored) *) let nb_lam = diff --git a/kernel/term.mli b/kernel/term.mli index 501aaf741e..d60716410c 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -281,13 +281,15 @@ val decompose_prod : constr -> (Name.t*constr) list * constr {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) val decompose_lam : constr -> (Name.t*constr) list * constr -(** Given a positive integer n, transforms a product term +(** Given a positive integer n, decompose a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} - into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. *) + into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. + Raise a user error if not enough products. *) val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr -(** Given a positive integer {% $ %}n{% $ %}, transforms a lambda term - {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %} *) +(** Given a positive integer {% $ %}n{% $ %}, decompose a lambda term + {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}. + Raise a user error if not enough lambdas. *) val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr (** Extract the premisses and the conclusion of a term of the form @@ -297,10 +299,15 @@ val decompose_prod_assum : types -> rel_context * types (** Idem with lambda's *) val decompose_lam_assum : constr -> rel_context * constr -(** Idem but extract the first [n] premisses *) +(** Idem but extract the first [n] premisses, counting let-ins. *) val decompose_prod_n_assum : int -> types -> rel_context * types + +(** Idem for lambdas, _not_ counting let-ins *) val decompose_lam_n_assum : int -> constr -> rel_context * constr +(** Idem, counting let-ins *) +val decompose_lam_n_decls : int -> constr -> rel_context * constr + (** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction gives {% $ %}n{% $ %} (casts are ignored) *) val nb_lam : constr -> int @@ -308,12 +315,14 @@ val nb_lam : constr -> int (** Similar to [nb_lam], but gives the number of products instead *) val nb_prod : constr -> int -(** Returns the premisses/parameters of a type/term (let-in included) *) +(** Return the premisses/parameters of a type/term (let-in included) *) val prod_assum : types -> rel_context val lam_assum : constr -> rel_context -(** Returns the first n-th premisses/parameters of a type/term (let included)*) +(** Return the first n-th premisses/parameters of a type (let included and counted) *) val prod_n_assum : int -> types -> rel_context + +(** Return the first n-th premisses/parameters of a term (let included but not counted) *) val lam_n_assum : int -> constr -> rel_context (** Remove the premisses/parameters of a type/term *) @@ -328,11 +337,11 @@ val strip_lam_n : int -> constr -> constr val strip_prod_assum : types -> types val strip_lam_assum : constr -> constr -(** flattens application lists *) +(** Flattens application lists *) val collapse_appl : constr -> constr -(** Removes recursively the casts around a term i.e. +(** Remove recursively the casts around a term i.e. [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) val strip_outer_cast : constr -> constr @@ -352,10 +361,10 @@ type arity = rel_context * sorts (** Build an "arity" from its canonical form *) val mkArity : arity -> types -(** Destructs an "arity" into its canonical form *) +(** Destruct an "arity" into its canonical form *) val destArity : types -> arity -(** Tells if a term has the form of an arity *) +(** Tell if a term has the form of an arity *) val isArity : types -> bool (** {5 Kind of type} *) -- cgit v1.2.3 From 23545b802a14b2fad10f4382604c71f55b7d6d0e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 18 Oct 2015 19:44:49 +0200 Subject: Using appropriate lambda decomposition function counting let-ins when dealing with "match". Contrastingly, "fix" is considered not to count let-ins for finding the recursive argument (which is ok because the last argument is necessarily a lambda). --- pretyping/cases.ml | 5 +++-- pretyping/constr_matching.ml | 4 ++-- pretyping/detyping.ml | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 47d92f5e03..a5a7ace221 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1077,7 +1077,7 @@ let rec ungeneralize n ng body = let p = prod_applist p [mkRel (n+List.length sign+ng)] in it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in mkCase (ci,p,c,Array.map2 (fun q c -> - let sign,b = decompose_lam_n_assum q c in + let sign,b = decompose_lam_n_decls q c in it_mkLambda_or_LetIn (ungeneralize (n+q) ng b) sign) ci.ci_cstr_ndecls brs) | App (f,args) -> @@ -1102,7 +1102,8 @@ let rec is_dependent_generalization ng body = | Case (ci,p,c,brs) -> (* We traverse a split *) Array.exists2 (fun q c -> - let _,b = decompose_lam_n_assum q c in is_dependent_generalization ng b) + let _,b = decompose_lam_n_decls q c in + is_dependent_generalization ng b) ci.ci_cstr_ndecls brs | App (g,args) -> (* We traverse an inner generalization *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 121ab74885..5e99521a12 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -267,8 +267,8 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> - let ctx_b2,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in - let ctx_b2',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in + let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in + let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in let n = rel_context_length ctx_b2 in let n' = rel_context_length ctx_b2' in if noccur_between 1 n b2 && noccur_between 1 n' b2' then diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index a1213e72be..87f2550240 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -302,7 +302,7 @@ and contract_branch isgoal e (cdn,can,mkpat,b) = let is_nondep_branch c l = try (* FIXME: do better using tags from l *) - let sign,ccl = decompose_lam_n_assum (List.length l) c in + let sign,ccl = decompose_lam_n_decls (List.length l) c in noccur_between 1 (rel_context_length sign) ccl with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *) false -- cgit v1.2.3 From 8748947349a206a502e43cfe70e3397ee457c4f7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 17 Oct 2015 17:26:38 +0200 Subject: Fixing #4198 (continued): not matching within the inner lambdas/let-ins of the return clause and of the branches (what assumed that the implementation preserves the invariant that the return predicate and the branches are in canonical [fun Δ => t] form, with Δ possibly containing let-ins). --- pretyping/constr_matching.ml | 19 ++++++++++++++++--- test-suite/success/ltac.v | 26 ++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 3 deletions(-) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 5e99521a12..3fa037ffdd 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -413,12 +413,25 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in let sub = (env, c1) :: subargs env lc in try_aux sub mk_ctx next - | Case (ci,hd,c1,lc) -> + | Case (ci,p,c,brs) -> + (* Warning: this assumes predicate and branches to be + in canonical form using let and fun of the signature *) + let nardecls = List.length ci.ci_pp_info.ind_tags in + let sign_p,p = decompose_lam_n_decls (nardecls + 1) p in + let env_p = Environ.push_rel_context sign_p env in + let brs = Array.map2 decompose_lam_n_decls ci.ci_cstr_ndecls brs in + let sign_brs = Array.map fst brs in + let f (sign,br) = (Environ.push_rel_context sign env, br) in + let sub_br = Array.map f brs in let next_mk_ctx = function - | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) + | c :: p :: brs -> + let p = it_mkLambda_or_LetIn p sign_p in + let brs = + Array.map2 it_mkLambda_or_LetIn (Array.of_list brs) sign_brs in + mk_ctx (mkCase (ci,p,c,brs)) | _ -> assert false in - let sub = (env, c1) :: (env, hd) :: subargs env lc in + let sub = (env, c) :: (env_p, p) :: Array.to_list sub_br in try_aux sub next_mk_ctx next | Fix (indx,(names,types,bodies)) -> let nb_fix = Array.length types in diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 6c4d4ae98f..5bef2e512a 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -317,3 +317,29 @@ let T := constr:(fun a b : nat => a) in end. exact (eq_refl n). Qed. + +(* Check that matching "match" does not look into the invisible + canonically generated binders of the return clause and of the branches *) + +Goal forall n, match n with 0 => true | S _ => false end = true. +intros. unfold nat_rect. +Fail match goal with |- context [nat] => idtac end. +Abort. + +(* Check that branches of automatically generated elimination + principle are correctly eta-expanded and hence matchable as seen + from the user point of view *) + +Goal forall a f n, nat_rect (fun _ => nat) a f n = 0. +intros. unfold nat_rect. +match goal with |- context [f _] => idtac end. +Abort. + +(* Check that branches of automatically generated elimination + principle are in correct form also in the presence of let-ins *) + +Inductive a (b:=0) : let b':=1 in Type := c : let d:=0 in a. +Goal forall x, match x with c => 0 end = 1. +intros. +match goal with |- context [0] => idtac end. +Abort. -- cgit v1.2.3 From a856dfb5ce98ea1a8e3961a64e533565387a8b31 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 13 Oct 2015 19:37:55 +0200 Subject: Reference Manual: Applying standard style recommendation about not starting a sentence with a symbolic expression. --- doc/refman/RefMan-ltac.tex | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 04c356e44f..5880487f71 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -367,7 +367,8 @@ There is a for loop that repeats a tactic {\num} times: \begin{quote} {\tt do} {\num} {\tacexpr} \end{quote} -{\tacexpr} is evaluated to $v$. $v$ must be a tactic value. $v$ is +{\tacexpr} is evaluated to $v$ which must be a tactic value. +This tactic value $v$ is applied {\num} times. Supposing ${\num}>1$, after the first application of $v$, $v$ is applied, at least once, to the generated subgoals and so on. It fails if the application of $v$ fails before @@ -394,7 +395,8 @@ We can catch the tactic errors with: \begin{quote} {\tt try} {\tacexpr} \end{quote} -{\tacexpr} is evaluated to $v$. $v$ must be a tactic value. $v$ is +{\tacexpr} is evaluated to $v$ which must be a tactic value. +The tactic value $v$ is applied to each focused goal independently. If the application of $v$ fails in a goal, it catches the error and leaves the goal unchanged. If the level of the exception is positive, then the @@ -406,7 +408,8 @@ We can check if a tactic made progress with: \begin{quote} {\tt progress} {\tacexpr} \end{quote} -{\tacexpr} is evaluated to $v$. $v$ must be a tactic value. $v$ is +{\tacexpr} is evaluated to $v$ which must be a tactic value. +The tactic value $v$ is applied to each focued subgoal independently. If the application of $v$ to one of the focused subgoal produced subgoals equal to the initial goals (up to syntactical equality), then an error of level 0 @@ -422,7 +425,7 @@ We can branch with the following structure: {\tacexpr}$_1$ {\tt +} {\tacexpr}$_2$ \end{quote} {\tacexpr}$_1$ and {\tacexpr}$_2$ are evaluated to $v_1$ and -$v_2$. $v_1$ and $v_2$ must be tactic values. $v_1$ is applied to each +$v_2$ which must be tactic values. The tactic value $v_1$ is applied to each focused goal independently and if it fails or a later tactic fails, then the proof backtracks to the current goal and $v_2$ is applied. @@ -462,7 +465,7 @@ Yet another way of branching without backtracking is the following structure: {\tacexpr}$_1$ {\tt ||} {\tacexpr}$_2$ \end{quote} {\tacexpr}$_1$ and {\tacexpr}$_2$ are evaluated to $v_1$ and -$v_2$. $v_1$ and $v_2$ must be tactic values. $v_1$ is applied in each +$v_2$ which must be tactic values. The tactic value $v_1$ is applied in each subgoal independently and if it fails \emph{to progress} then $v_2$ is applied. {\tacexpr}$_1$ {\tt ||} {\tacexpr}$_2$ is equivalent to {\tt first [} {\tt progress} {\tacexpr}$_1$ {\tt |} {\tt progress} @@ -494,7 +497,8 @@ single success \emph{a posteriori}: \begin{quote} {\tt once} {\tacexpr} \end{quote} -{\tacexpr} is evaluated to $v$. $v$ must be a tactic value. $v$ is +{\tacexpr} is evaluated to $v$ which must be a tactic value. +The tactic value $v$ is applied but only its first success is used. If $v$ fails, {\tt once} {\tacexpr} fails like $v$. If $v$ has a least one success, {\tt once} {\tacexpr} succeeds once, but cannot produce more successes. @@ -505,7 +509,8 @@ Coq provides an experimental way to check that a tactic has \emph{exactly one} s \begin{quote} {\tt exactly\_once} {\tacexpr} \end{quote} -{\tacexpr} is evaluated to $v$. $v$ must be a tactic value. $v$ is +{\tacexpr} is evaluated to $v$ which must be a tactic value. +The tactic value $v$ is applied if it has at most one success. If $v$ fails, {\tt exactly\_once} {\tacexpr} fails like $v$. If $v$ has a exactly one success, {\tt exactly\_once} {\tacexpr} succeeds like $v$. If $v$ has @@ -592,7 +597,8 @@ amount of time: \begin{quote} {\tt timeout} {\num} {\tacexpr} \end{quote} -{\tacexpr} is evaluated to $v$. $v$ must be a tactic value. $v$ is +{\tacexpr} is evaluated to $v$ which must be a tactic value. +The tactic value $v$ is applied normally, except that it is interrupted after ${\num}$ seconds if it is still running. In this case the outcome is a failure. -- cgit v1.2.3 From c70ee60ed1603658eb33f4ae39b1a0be81bf45c6 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 17 Oct 2015 17:29:19 +0200 Subject: Using "__" rather than this unelegant arbitrary "A" for the name of variables of the context of an evar in debugging mode. --- pretyping/detyping.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 87f2550240..b5228094a2 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -513,7 +513,7 @@ let rec detype flags avoid env sigma t = id,l with Not_found -> Id.of_string ("X" ^ string_of_int (Evar.repr evk)), - (Array.map_to_list (fun c -> (Id.of_string "A",c)) cl) + (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) in GEvar (dl,id, List.map (on_snd (detype flags avoid env sigma)) l) -- cgit v1.2.3 From c8b57f62f5ad12f8926f57fcdbc5bb2ee3c63eff Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 13 Oct 2015 11:40:22 +0200 Subject: Miscellaneous typos, spacing, US spelling in comments or variable names. --- kernel/typeops.ml | 2 +- lib/future.mli | 4 ++-- proofs/logic_monad.ml | 2 +- proofs/proof_global.mli | 2 +- stm/stm.ml | 4 ++-- toplevel/coqtop.mli | 2 +- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 09299f31d7..4f32fdce83 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -477,7 +477,7 @@ let rec execute env cstr = let j' = execute env1 c3 in judge_of_letin env name j1 j2 j' - | Cast (c,k, t) -> + | Cast (c,k,t) -> let cj = execute env c in let tj = execute_type env t in judge_of_cast env cj k tj diff --git a/lib/future.mli b/lib/future.mli index de2282ae92..adc15e49c7 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -91,13 +91,13 @@ val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation * When a future enters the environment a corresponding hook is run to perform * some work. If this fails, then its failure has to be annotated with the * same state id that corresponds to the future computation end. I.e. Qed - * is split into two parts, the lazy one (the future) and the eagher one + * is split into two parts, the lazy one (the future) and the eager one * (the hook), both performing some computations for the same state id. *) val fix_exn_of : 'a computation -> fix_exn (* Run remotely, returns the function to assign. If not blocking (the default) it raises NotReady if forced before the - delage assigns it. *) + delegate assigns it. *) type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] val create_delegate : ?blocking:bool -> name:string -> diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml index 81f02b66db..b9165aa812 100644 --- a/proofs/logic_monad.ml +++ b/proofs/logic_monad.ml @@ -188,7 +188,7 @@ struct shape of the monadic type is reminiscent of that of the continuation monad transformer. - The paper also contains the rational for the [split] abstraction. + The paper also contains the rationale for the [split] abstraction. An explanation of how to derive such a monad from mathematical principles can be found in "Kan Extensions for Program diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 028116049c..fcb706cc8d 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -94,7 +94,7 @@ val start_dependent_proof : val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof (* Intermediate step necessary to delegate the future. - * Both access the current proof state. The formes is supposed to be + * Both access the current proof state. The former is supposed to be * chained with a computation that completed the proof *) type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context diff --git a/stm/stm.ml b/stm/stm.ml index 5bb46fd368..88a1fbbf48 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -639,7 +639,7 @@ end = struct (* {{{ *) proof, Summary.project_summary (States.summary_of_state system) summary_pstate - let freeze marhallable id = VCS.set_state id (freeze_global_state marhallable) + let freeze marshallable id = VCS.set_state id (freeze_global_state marshallable) let is_cached ?(cache=`No) id = if Stateid.equal id !cur_id then @@ -1912,7 +1912,7 @@ let init () = Backtrack.record (); Slaves.init (); if Flags.async_proofs_is_master () then begin - prerr_endline "Initialising workers"; + prerr_endline "Initializing workers"; Query.init (); let opts = match !Flags.async_proofs_private_flags with | None -> [] diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 356ccdcc69..6704474529 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -8,7 +8,7 @@ (** The Coq main module. The following function [start] will parse the command line, print the banner, initialize the load path, load the input - state, load the files given on the command line, load the ressource file, + state, load the files given on the command line, load the resource file, produce the output state if any, and finally will launch [Coqloop.loop]. *) val init_toplevel : string list -> unit -- cgit v1.2.3 From 4a76d2034983462175219426ec47c45a3c60d4fe Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 11 Oct 2015 14:47:52 +0200 Subject: Constraining refine to monotonic functions. --- plugins/decl_mode/decl_proof_instr.ml | 7 ++- proofs/proofview.ml | 9 +++- proofs/proofview.mli | 4 +- tactics/extratactics.ml4 | 7 ++- tactics/inv.ml | 3 +- tactics/rewrite.ml | 17 ++++--- tactics/tactics.ml | 86 +++++++++++++++++++++-------------- tactics/tactics.mli | 2 +- toplevel/classes.ml | 3 +- 9 files changed, 89 insertions(+), 49 deletions(-) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index d8c5b8a956..1741df533d 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -29,6 +29,7 @@ open Termops open Namegen open Goptions open Misctypes +open Sigma.Notations (* Strictness option *) @@ -1305,7 +1306,11 @@ let understand_my_constr env sigma c concl = Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc) let my_refine c gls = - let oc sigma = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in + let oc = { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in + Sigma.Unsafe.of_pair (c, sigma) + end } in Proofview.V82.of_tactic (Tactics.New.refine oc) gls (* end focus/claim *) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 11b7d07d05..f549913f2f 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -16,6 +16,7 @@ open Pp open Util open Proofview_monad +open Sigma.Notations (** Main state of tactics *) type proofview = Proofview_monad.proofview @@ -1031,7 +1032,7 @@ struct let prev_future_goals = Evd.future_goals sigma in let prev_principal_goal = Evd.principal_future_goal sigma in (** Create the refinement term *) - let (sigma, c) = f (Evd.reset_future_goals sigma) in + let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in let evs = Evd.future_goals sigma in let evkmain = Evd.principal_future_goal sigma in (** Check that the introduced evars are well-typed *) @@ -1074,7 +1075,11 @@ struct let refine_casted ?unsafe f = Goal.enter begin fun gl -> let concl = Goal.concl gl in let env = Goal.env gl in - let f h = let (h, c) = f h in with_type env h c concl in + let f = { run = fun h -> + let Sigma (c, h, p) = f.run h in + let sigma, c = with_type env (Sigma.to_evar_map h) c concl in + Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) + } in refine ?unsafe f end end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 98e1477ff1..04ca01ec4d 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -487,7 +487,7 @@ module Refine : sig (** {7 Refinement primitives} *) - val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * Constr.t) -> unit tactic + val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic (** In [refine ?unsafe t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the @@ -503,7 +503,7 @@ module Refine : sig (** [with_type env sigma c t] ensures that [c] is of type [t] inserting a coercion if needed. *) - val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*Constr.t) -> unit tactic + val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic (** Like {!refine} except the refined term is coerced to the conclusion of the current goal. *) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 1a3f460399..d7d82111c8 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -21,6 +21,7 @@ open Util open Evd open Equality open Misctypes +open Sigma.Notations DECLARE PLUGIN "extratactics" @@ -355,7 +356,11 @@ let refine_tac {Glob_term.closure=closure;term=term} = Pretyping.ltac_uconstrs = closure.Glob_term.untyped; Pretyping.ltac_idents = closure.Glob_term.idents; } in - let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in + let update = { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = Pretyping.understand_ltac flags env sigma lvar tycon term in + Sigma.Unsafe.of_pair (c, sigma) + end } in Tactics.New.refine ~unsafe:false update end diff --git a/tactics/inv.ml b/tactics/inv.ml index ef115aea0e..0acaeb44cf 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -27,6 +27,7 @@ open Elim open Equality open Misctypes open Tacexpr +open Sigma.Notations open Proofview.Notations let clear hyps = Proofview.V82.tactic (clear hyps) @@ -457,7 +458,7 @@ let raw_inversion inv_kind id status names = in let refined id = let prf = mkApp (mkVar id, args) in - Proofview.Refine.refine (fun h -> h, prf) + Proofview.Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } in let neqns = List.length realargs in let as_mode = names != None in diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 0811708695..1b6ba56e66 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -34,6 +34,7 @@ open Elimschemes open Environ open Termops open Libnames +open Sigma.Notations (** Typeclass-based generalized rewriting. *) @@ -1508,13 +1509,14 @@ let assert_replacing id newt tac = | (id, b, _) :: rem -> insert_dependent env (id, b, newt) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in - Proofview.Refine.refine ~unsafe:false begin fun sigma -> + Proofview.Refine.refine ~unsafe:false { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let sigma, ev = Evarutil.new_evar env' sigma concl in let sigma, ev' = Evarutil.new_evar env sigma newt in let map (n, _, _) = if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar ev in - sigma, mkEvar (e, Array.map_of_list map nc) - end + Sigma.Unsafe.of_pair (mkEvar (e, Array.map_of_list map nc), sigma) + end } end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) @@ -1533,7 +1535,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let gls = List.rev (Evd.fold_undefined fold undef []) in match clause, prf with | Some id, Some p -> - let tac = Proofview.Refine.refine ~unsafe:false (fun h -> (h, p)) <*> Proofview.Unsafe.tclNEWGOALS gls in + let tac = Proofview.Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in Proofview.Unsafe.tclEVARS undef <*> assert_replacing id newt tac | Some id, None -> @@ -1543,10 +1545,11 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = Proofview.Unsafe.tclEVARS undef <*> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let make sigma = + let make = { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let (sigma, ev) = Evarutil.new_evar env sigma newt in - sigma, mkApp (p, [| ev |]) - in + Sigma.Unsafe.of_pair (mkApp (p, [| ev |]), sigma) + end } in Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls end | None, None -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 27166bf488..90e4f8521e 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -43,6 +43,7 @@ open Locus open Locusops open Misctypes open Proofview.Notations +open Sigma.Notations let nb_prod x = let rec count n c = @@ -171,15 +172,16 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store (id, c, t) b = - Proofview.Refine.refine ~unsafe:true begin fun sigma -> + Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let ctx = named_context_val env in let nctx = push_named_context_val (id, c, t) ctx in let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar id) b in let sigma, ev = new_evar_instance nctx sigma nb ~store ninst in - sigma, mkNamedLambda_or_LetIn (id, c, t) ev - end + Sigma.Unsafe.of_pair (mkNamedLambda_or_LetIn (id, c, t) ev, sigma) + end } let introduction ?(check=true) id = Proofview.Goal.enter begin fun gl -> @@ -206,7 +208,8 @@ let convert_concl ?(check=true) ty k = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in - Proofview.Refine.refine ~unsafe:true begin fun sigma -> + Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let sigma = if check then begin ignore (Typing.unsafe_type_of env sigma ty); @@ -215,8 +218,9 @@ let convert_concl ?(check=true) ty k = sigma end else sigma in let (sigma,x) = Evarutil.new_evar env sigma ~principal:true ~store ty in - (sigma, if k == DEFAULTcast then x else mkCast(x,k,conclty)) - end + let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in + Sigma.Unsafe.of_pair (ans, sigma) + end } end let convert_hyp ?(check=true) d = @@ -227,7 +231,11 @@ let convert_hyp ?(check=true) d = let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in - Proofview.Refine.refine ~unsafe:true (fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty) + Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = Evarutil.new_evar env sigma ~principal:true ~store ty in + Sigma.Unsafe.of_pair (c, sigma) + end } end let convert_concl_no_check = convert_concl ~check:false @@ -345,9 +353,11 @@ let rename_hyp repl = let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in let instance = List.map (fun (id, _, _) -> mkVar id) hyps in - Proofview.Refine.refine ~unsafe:true begin fun sigma -> - Evarutil.new_evar_instance nctx sigma nconcl ~store instance - end + Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = Evarutil.new_evar_instance nctx sigma nconcl ~store instance in + Sigma.Unsafe.of_pair (c, sigma) + end } end (**************************************************************) @@ -1047,12 +1057,13 @@ let cut c = let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = local_strong whd_betaiota sigma c in - Proofview.Refine.refine ~unsafe:true begin fun h -> + Proofview.Refine.refine ~unsafe:true { run = begin fun h -> + let h = Sigma.to_evar_map h in let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let (h, x) = Evarutil.new_evar env h c in let f = mkLambda (Name id, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - (h, mkApp (f, [|x|])) - end + Sigma.Unsafe.of_pair (mkApp (f, [|x|]), h) + end } else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") end @@ -1700,13 +1711,14 @@ let cut_and_apply c = | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in - Proofview.Refine.refine begin fun sigma -> + Proofview.Refine.refine { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let typ = mkProd (Anonymous, c2, concl) in let (sigma, f) = Evarutil.new_evar env sigma typ in let (sigma, x) = Evarutil.new_evar env sigma c1 in let ans = mkApp (f, [|mkApp (c, [|x|])|]) in - (sigma, ans) - end + Sigma.Unsafe.of_pair (ans, sigma) + end } | _ -> error "lapply needs a non-dependent product." end @@ -1721,7 +1733,7 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let new_exact_no_check c = - Proofview.Refine.refine ~unsafe:true (fun h -> (h, c)) + Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma (c, h, Sigma.refl) } let exact_check c = Proofview.Goal.enter begin fun gl -> @@ -1763,7 +1775,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Proofview.Refine.refine ~unsafe:true (fun h -> (h, mkVar id)) + Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma (mkVar id, h, Sigma.refl) } else arec gl only_eq rest in let assumption_tac gl = @@ -1845,9 +1857,11 @@ let clear_body ids = check_is_type env concl msg in check_hyps <*> check_concl <*> - Proofview.Refine.refine ~unsafe:true begin fun sigma -> - Evarutil.new_evar env sigma concl - end + Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = Evarutil.new_evar env sigma concl in + Sigma.Unsafe.of_pair (c, sigma) + end } end let clear_wildcards ids = @@ -2419,11 +2433,11 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [heq,None,eq;id,body,t] lastlhyp env in let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in - (sigma,mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)) + Sigma.Unsafe.of_pair (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma) | None -> let newenv = insert_before [id,body,t] lastlhyp env in let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in - (sigma,mkNamedLetIn id c t x) + Sigma.Unsafe.of_pair (mkNamedLetIn id c t x, sigma) let letin_tac with_eq id c ty occs = Proofview.Goal.nf_enter begin fun gl -> @@ -2496,10 +2510,11 @@ let bring_hyps hyps = let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (instance_from_named_context hyps) in - Proofview.Refine.refine begin fun sigma -> + Proofview.Refine.refine { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let (sigma, ev) = Evarutil.new_evar env sigma newcl in - (sigma, (mkApp (ev, args))) - end + Sigma.Unsafe.of_pair (mkApp (ev, args), sigma) + end } end let revert hyps = @@ -2608,10 +2623,11 @@ let new_generalize_gen_let lconstr = 0 lconstr ((concl, sigma), []) in Proofview.Unsafe.tclEVARS sigma <*> - Proofview.Refine.refine begin fun sigma -> + Proofview.Refine.refine { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let (sigma, ev) = Evarutil.new_evar env sigma newcl in - (sigma, (applist (ev, args))) - end + Sigma.Unsafe.of_pair ((applist (ev, args)), sigma) + end } end let generalize_gen lconstr = @@ -3951,11 +3967,13 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma; - Proofview.Refine.refine ~unsafe:true (fun sigma -> + Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in let b = not with_evars && with_eq != None in let (sigma,c) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env sigma c in - mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t)); + mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) + end }; Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable); if is_arg_pure_hyp then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0])) @@ -3971,8 +3989,10 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let env = reset_with_named_context sign env in Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma'; - Proofview.Refine.refine ~unsafe:true (fun sigma -> - mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None); + Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None + end }; tac ] end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index ade89fc989..38e6ce0eaf 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -430,7 +430,7 @@ end module New : sig - val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*constr) -> unit Proofview.tactic + val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic (** [refine ?unsafe c] is [Proofview.Refine.refine ?unsafe c] followed by beta-iota-reduction of the conclusion. *) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 805a29e396..439e20a86b 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -20,6 +20,7 @@ open Libnames open Globnames open Constrintern open Constrexpr +open Sigma.Notations (*i*) open Decl_kinds @@ -322,7 +323,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Proofview.Refine.refine (fun evm -> evm, Option.get term); + Proofview.Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) }; Proofview.Unsafe.tclNEWGOALS gls; Tactics.New.reduce_after_refine; ] -- cgit v1.2.3 From 7d697193ab175b6bfa3c773880c0a06348449d19 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 18 Oct 2015 20:29:58 +0200 Subject: Making Evarutil.new_evar monotonous. --- pretyping/evarconv.ml | 5 ++++- pretyping/evarutil.ml | 15 ++++++++++----- pretyping/evarutil.mli | 4 ++-- pretyping/unification.ml | 27 ++++++++++++++++----------- proofs/clenv.ml | 9 +++++++-- proofs/proofview.ml | 4 +++- tactics/evar_tactics.ml | 5 ++++- tactics/rewrite.ml | 16 ++++++++-------- tactics/tactics.ml | 47 +++++++++++++++++++++-------------------------- 9 files changed, 75 insertions(+), 57 deletions(-) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index d5bb564f66..60d92f4beb 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -22,6 +22,7 @@ open Evarsolve open Globnames open Evd open Pretype_errors +open Sigma.Notations type unify_fun = transparent_state -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result @@ -830,7 +831,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (i,t2::ks, m-1, test) else let dloc = (Loc.ghost,Evar_kinds.InternalHole) in - let (i',ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in + let i = Sigma.Unsafe.of_evar_map i in + let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in + let i' = Sigma.to_evar_map i' in (i', ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 1c3ae9ad95..bc9f083315 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -385,7 +385,7 @@ let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?prin (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) -let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = +let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in let instance = @@ -394,9 +394,14 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance +let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = + let evd = Sigma.to_evar_map evd in + let (sigma, c) = new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ in + Sigma.Unsafe.of_pair (c, sigma) + let new_type_evar env evd ?src ?filter ?naming ?principal rigid = let evd', s = new_sort_variable rigid evd in - let evd', e = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in + let evd', e = new_evar_unsafe env evd' ?src ?filter ?naming ?principal (mkSort s) in evd', (e, s) let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = @@ -414,7 +419,7 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = (* The same using side-effect *) let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty = - let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in + let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in evdref := evd'; ev @@ -717,7 +722,7 @@ let define_pure_evar_as_product evd evk = let filter = Filter.extend 1 (evar_filter evi) in if is_prop_sort s then (* Impredicative product, conclusion must fall in [Prop]. *) - new_evar newenv evd1 concl ~src ~filter + new_evar_unsafe newenv evd1 concl ~src ~filter else let evd3, (rng, srng) = new_type_evar newenv evd1 univ_flexible_alg ~src ~filter in @@ -763,7 +768,7 @@ let define_pure_evar_as_lambda env evd evk = let newenv = push_named (id, None, dom) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in - let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in + let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in let lam = mkLambda (Name id, dom, subst_var id body) in Evd.define evk lam evd2, lam diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 76d67c748d..96648bb111 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -22,10 +22,10 @@ val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) val new_evar : - env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> evar_map * constr + ?principal:bool -> types -> (constr, 'r) Sigma.sigma val new_pure_evar : named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 123f9b8cd3..9caa868958 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -27,6 +27,7 @@ open Recordops open Locus open Locusops open Find_subterm +open Sigma.Notations let keyed_unification = ref (false) let _ = Goptions.declare_bool_option { @@ -105,7 +106,9 @@ let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) let abstract_list_all_with_dependencies env evd typ c l = - let evd,ev = new_evar env evd typ in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (ev, evd, _) = new_evar env evd typ in + let evd = Sigma.to_evar_map evd in let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in @@ -1155,20 +1158,20 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * close it off. But this might not always work, * since other metavars might also need to be resolved. *) -let applyHead env evd n c = - let rec apprec n c cty evd = +let applyHead env (type r) (evd : r Sigma.t) n c = + let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma = + fun n c cty p evd -> if Int.equal n 0 then - (evd, c) + Sigma (c, evd, p) else - match kind_of_term (whd_betadeltaiota env evd cty) with + match kind_of_term (whd_betadeltaiota env (Sigma.to_evar_map evd) cty) with | Prod (_,c1,c2) -> - let (evd',evar) = - Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in - apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' + let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in + apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' | _ -> error "Apply_Head_Then" in - apprec n c (Typing.unsafe_type_of env evd c) evd - + apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd + let is_mimick_head ts f = match kind_of_term f with | Const (c,u) -> not (Closure.is_transparent_constant ts c) @@ -1328,7 +1331,9 @@ let w_merge env with_types flags (evd,metas,evars) = and mimick_undefined_evar evd flags hdc nargs sp = let ev = Evd.find_undefined evd sp in let sp_env = Global.env_of_context ev.evar_hyps in - let (evd', c) = applyHead sp_env evd nargs hdc in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in + let evd' = Sigma.to_evar_map evd' in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags (get_type_of sp_env evd' c) ev.evar_concl in diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 0697c94d74..ae790d9b82 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -24,6 +24,7 @@ open Pretype_errors open Evarutil open Unification open Misctypes +open Sigma.Notations (* Abbreviations *) @@ -335,7 +336,9 @@ let clenv_pose_metas_as_evars clenv dep_mvs = else let src = evar_source_of_meta mv clenv.evd in let src = adjust_meta_source clenv.evd mv src in - let (evd,evar) = new_evar (cl_env clenv) clenv.evd ~src ty in + let evd = Sigma.Unsafe.of_evar_map clenv.evd in + let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in + let evd = Sigma.to_evar_map evd in let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv mvs in fold clenv dep_mvs @@ -614,7 +617,9 @@ let make_evar_clause env sigma ?len t = | Cast (t, _, _) -> clrec (sigma, holes) n t | Prod (na, t1, t2) -> let store = Typeclasses.set_resolvable Evd.Store.empty false in - let sigma, ev = new_evar ~store env sigma t1 in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in + let sigma = Sigma.to_evar_map sigma in let dep = dependent (mkRel 1) t2 in let hole = { hole_evar = ev; diff --git a/proofs/proofview.ml b/proofs/proofview.ml index f549913f2f..bc2cc3e913 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -65,7 +65,9 @@ let dependent_init = let rec aux = function | TNil sigma -> [], { solution = sigma; comb = []; } | TCons (env, sigma, typ, t) -> - let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in + let sigma = Sigma.to_evar_map sigma in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in let entry = (econstr, typ) :: ret in diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index c3fe6b6574..3d544274d2 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -14,6 +14,7 @@ open Tacexpr open Refiner open Evd open Locus +open Sigma.Notations (* The instantiate tactic *) @@ -76,7 +77,9 @@ let let_evar name typ = let id = Namegen.id_of_name_using_hdchar env typ name in Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) | Names.Name id -> id in - let sigma',evar = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (evar, sigma', _) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let sigma' = Sigma.to_evar_map sigma' in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS sigma')) (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) end diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 1b6ba56e66..7e0182137a 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -85,7 +85,9 @@ let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = let s = Typeclasses.set_resolvable Evd.Store.empty false in - let evd', t = Evarutil.new_evar ~store:s env evd t in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in + let evd' = Sigma.to_evar_map evd' in let ev, _ = destEvar t in (evd', Evar.Set.add ev cstrs), t @@ -1510,12 +1512,11 @@ let assert_replacing id newt tac = in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Proofview.Refine.refine ~unsafe:false { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let sigma, ev = Evarutil.new_evar env' sigma concl in - let sigma, ev' = Evarutil.new_evar env sigma newt in + let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in + let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in let map (n, _, _) = if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar ev in - Sigma.Unsafe.of_pair (mkEvar (e, Array.map_of_list map nc), sigma) + Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) end } end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) @@ -1546,9 +1547,8 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let make = { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, ev) = Evarutil.new_evar env sigma newt in - Sigma.Unsafe.of_pair (mkApp (p, [| ev |]), sigma) + let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in + Sigma (mkApp (p, [| ev |]), sigma, q) end } in Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 90e4f8521e..8a8b36a9e4 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -217,9 +217,10 @@ let convert_concl ?(check=true) ty k = if not b then error "Not convertible."; sigma end else sigma in - let (sigma,x) = Evarutil.new_evar env sigma ~principal:true ~store ty in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (x, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in - Sigma.Unsafe.of_pair (ans, sigma) + Sigma (ans, sigma, p) end } end @@ -232,9 +233,7 @@ let convert_hyp ?(check=true) d = let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = Evarutil.new_evar env sigma ~principal:true ~store ty in - Sigma.Unsafe.of_pair (c, sigma) + Evarutil.new_evar env sigma ~principal:true ~store ty end } end @@ -1058,11 +1057,10 @@ let cut c = (** Backward compat: normalize [c]. *) let c = local_strong whd_betaiota sigma c in Proofview.Refine.refine ~unsafe:true { run = begin fun h -> - let h = Sigma.to_evar_map h in - let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in - let (h, x) = Evarutil.new_evar env h c in + let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in + let Sigma (x, h, q) = Evarutil.new_evar env h c in let f = mkLambda (Name id, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - Sigma.Unsafe.of_pair (mkApp (f, [|x|]), h) + Sigma (mkApp (f, [|x|]), h, p +> q) end } else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") @@ -1712,12 +1710,11 @@ let cut_and_apply c = let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in Proofview.Refine.refine { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in let typ = mkProd (Anonymous, c2, concl) in - let (sigma, f) = Evarutil.new_evar env sigma typ in - let (sigma, x) = Evarutil.new_evar env sigma c1 in + let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in + let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in let ans = mkApp (f, [|mkApp (c, [|x|])|]) in - Sigma.Unsafe.of_pair (ans, sigma) + Sigma (ans, sigma, p +> q) end } | _ -> error "lapply needs a non-dependent product." end @@ -1858,9 +1855,7 @@ let clear_body ids = in check_hyps <*> check_concl <*> Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = Evarutil.new_evar env sigma concl in - Sigma.Unsafe.of_pair (c, sigma) + Evarutil.new_evar env sigma concl end } end @@ -2432,12 +2427,14 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [heq,None,eq;id,body,t] lastlhyp env in - let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in - Sigma.Unsafe.of_pair (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma) + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in + Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p) | None -> let newenv = insert_before [id,body,t] lastlhyp env in - let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in - Sigma.Unsafe.of_pair (mkNamedLetIn id c t x, sigma) + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in + Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = Proofview.Goal.nf_enter begin fun gl -> @@ -2511,9 +2508,8 @@ let bring_hyps hyps = let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (instance_from_named_context hyps) in Proofview.Refine.refine { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, ev) = Evarutil.new_evar env sigma newcl in - Sigma.Unsafe.of_pair (mkApp (ev, args), sigma) + let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma newcl in + Sigma (mkApp (ev, args), sigma, p) end } end @@ -2624,9 +2620,8 @@ let new_generalize_gen_let lconstr = in Proofview.Unsafe.tclEVARS sigma <*> Proofview.Refine.refine { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, ev) = Evarutil.new_evar env sigma newcl in - Sigma.Unsafe.of_pair ((applist (ev, args)), sigma) + let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma newcl in + Sigma ((applist (ev, args)), sigma, p) end } end -- cgit v1.2.3 From 289dde7331ee19229b9ba4b9778a76007d93b275 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 10:55:19 +0200 Subject: Documenting the option "Strict Universe Declaration" in CHANGES. --- CHANGES | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES b/CHANGES index 07d129a462..9f46131363 100644 --- a/CHANGES +++ b/CHANGES @@ -5,6 +5,9 @@ Vernacular commands - New command "Redirect" to redirect the output of a command to a file. - New command "Undelimit Scope" to remove the delimiter of a scope. +- New option "Strict Universe Declaration", set by default. It enforces the + declaration of all polymorphic universes appearing in a definition when + introducing it. Tactics -- cgit v1.2.3 From de32427bd2785c365374c554b4b74e97749cb995 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Mon, 19 Oct 2015 11:28:30 +0200 Subject: Fixed #4274, bad formatting of messages in emacs mode. --- lib/pp.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 1711008ead..4ed4b17791 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -362,11 +362,11 @@ let emacs_quote_info_start = "" let emacs_quote_info_end = "" let emacs_quote g = - if !print_emacs then str emacs_quote_start ++ hov 0 g ++ str emacs_quote_end + if !print_emacs then hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) else hov 0 g let emacs_quote_info g = - if !print_emacs then str emacs_quote_info_start++fnl() ++ hov 0 g ++ str emacs_quote_info_end + if !print_emacs then hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) else hov 0 g -- cgit v1.2.3 From 70d3ad33f6ba7a1c6b1fb93aadd5c05d7e9c03b8 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Mon, 19 Oct 2015 11:49:38 +0200 Subject: Partly fixes #3225. Removed some old experimental stuff in funind. --- plugins/funind/g_indfun.ml4 | 244 -------------------------------------------- 1 file changed, 244 deletions(-) diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index e7732a5037..045beb37cf 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -247,247 +247,3 @@ END VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY ["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ] END - - - - - -(* FINDUCTION *) - -(* comment this line to see debug msgs *) -let msg x = () ;; let pr_lconstr c = str "" - (* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") -let prlistconstr lc = List.iter prconstr lc -let prstr s = msg(str s) -let prNamedConstr s c = - begin - msg(str ""); - msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); - msg(str ""); - end - - - -(** Information about an occurrence of a function call (application) - inside a term. *) -type fapp_info = { - fname: constr; (** The function applied *) - largs: constr list; (** List of arguments *) - free: bool; (** [true] if all arguments are debruijn free *) - max_rel: int; (** max debruijn index in the funcall *) - onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *) -} - - -(** [constr_head_match(a b c) a] returns true, false otherwise. *) -let constr_head_match u t= - if isApp u - then - let uhd,args= destApp u in - Constr.equal uhd t - else false - -(** [hdMatchSub inu t] returns the list of occurrences of [t] in - [inu]. DeBruijn are not pushed, so some of them may be unbound in - the result. *) -let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = - let subres = - match kind_of_term inu with - | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> - hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test - | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) - Array.fold_left - (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) - [] bl - | _ -> (* Cofix will be wrong *) - fold_constr - (fun l cstr -> - l @ hdMatchSub cstr test) [] inu in - if not (test inu) then subres - else - let f,args = decompose_app inu in - let freeset = Termops.free_rels inu in - let max_rel = try Int.Set.max_elt freeset with Not_found -> -1 in - {fname = f; largs = args; free = Int.Set.is_empty freeset; - max_rel = max_rel; onlyvars = List.for_all isVar args } - ::subres - -let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) - -let mkEq typ c1 c2 = - mkApp (make_eq(),[| typ; c1; c2|]) - - -let poseq_unsafe idunsafe cstr gl = - let typ = Tacmach.pf_unsafe_type_of gl cstr in - tclTHEN - (Proofview.V82.of_tactic (Tactics.letin_tac None (Name idunsafe) cstr None Locusops.allHypsAndConcl)) - (tclTHENFIRST - (Proofview.V82.of_tactic (Tactics.assert_before Anonymous (mkEq typ (mkVar idunsafe) cstr))) - (Proofview.V82.of_tactic Tactics.reflexivity)) - gl - - -let poseq id cstr gl = - let x = Tactics.fresh_id [] id gl in - poseq_unsafe x cstr gl - -(* dirty? *) - -let list_constr_largs = ref [] - -let rec poseq_list_ids_rec lcstr gl = - match lcstr with - | [] -> tclIDTAC gl - | c::lcstr' -> - match kind_of_term c with - | Var _ -> - (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) - | _ -> - let _ = prstr "c = " in - let _ = prconstr c in - let _ = prstr "\n" in - let typ = Tacmach.pf_unsafe_type_of gl c in - let cname = Namegen.id_of_name_using_hdchar (Global.env()) typ Anonymous in - let x = Tactics.fresh_id [] cname gl in - let _ = list_constr_largs:=mkVar x :: !list_constr_largs in - let _ = prstr " list_constr_largs = " in - let _ = prlistconstr !list_constr_largs in - let _ = prstr "\n" in - - tclTHEN - (poseq_unsafe x c) - (poseq_list_ids_rec lcstr') - gl - -let poseq_list_ids lcstr gl = - let _ = list_constr_largs := [] in - poseq_list_ids_rec lcstr gl - -(** [find_fapp test g] returns the list of [app_info] of all calls to - functions that satisfy [test] in the conclusion of goal g. Trivial - repetition (not modulo conversion) are deleted. *) -let find_fapp (test:constr -> bool) g : fapp_info list = - let pre_res = hdMatchSub (Tacmach.pf_concl g) test in - let res = - List.fold_right (List.add_set Pervasives.(=)) pre_res [] in - (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); - res) - - - -(** [finduction id filter g] tries to apply functional induction on - an occurrence of function [id] in the conclusion of goal [g]. If - [id]=[None] then calls to any function are selected. In any case - [heuristic] is used to select the most pertinent occurrence. *) -let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) - (nexttac:Proof_type.tactic) g = - let test = match oid with - | Some id -> - let idref = const_of_id id in - (* JF : FIXME : we probably need to keep trace of evd in presence of universe polymorphism *) - let idconstr = snd (Evd.fresh_global (Global.env ()) (Evd.from_env (Global.env ())) idref) in - (fun u -> constr_head_match u idconstr) (* select only id *) - | None -> (fun u -> isApp u) in (* select calls to any function *) - let info_list = find_fapp test g in - let ordered_info_list = heuristic info_list in - prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); - if List.is_empty ordered_info_list then Errors.error "function not found in goal\n"; - let taclist: Proof_type.tactic list = - List.map - (fun info -> - (tclTHEN - (tclTHEN (poseq_list_ids info.largs) - ( - fun gl -> - (functional_induction - true (applist (info.fname, List.rev !list_constr_largs)) - None None) gl)) - nexttac)) ordered_info_list in - (* we try each (f t u v) until one does not fail *) - (* TODO: try also to mix functional schemes *) - tclFIRST taclist g - - - - -(** [chose_heuristic oi x] returns the heuristic for reordering - (and/or forgetting some elts of) a list of occurrences of - function calls infos to chose first with functional induction. *) -let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = - match oi with - | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) - | None -> - (* Default heuristic: put first occurrences where all arguments - are *bound* (meaning already introduced) variables *) - let ordering x y = - if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *) - else if x.free && x.onlyvars then -1 - else if y.free && y.onlyvars then 1 - else 0 (* both not pertinent *) - in - List.sort ordering - - - -TACTIC EXTEND finduction - ["finduction" ident(id) natural_opt(oi)] -> - [ - match oi with - | Some(n) when n<=0 -> Errors.error "numerical argument must be > 0" - | _ -> - let heuristic = chose_heuristic oi in - Proofview.V82.tactic (finduction (Some id) heuristic tclIDTAC) - ] -END - - - -TACTIC EXTEND fauto - [ "fauto" tactic(tac)] -> - [ - let heuristic = chose_heuristic None in - Proofview.V82.tactic (finduction None heuristic (Proofview.V82.of_tactic (Tacinterp.eval_tactic tac))) - ] - | - [ "fauto" ] -> - [ - let heuristic = chose_heuristic None in - Proofview.V82.tactic (finduction None heuristic tclIDTAC) - ] - -END - - -TACTIC EXTEND poseq - [ "poseq" ident(x) constr(c) ] -> - [ Proofview.V82.tactic (poseq x c) ] -END - -VERNAC COMMAND EXTEND Showindinfo CLASSIFIED AS QUERY - [ "showindinfo" ident(x) ] -> [ Merge.showind x ] -END - -VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF - [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" - "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> - [ - let f1,ctx = Constrintern.interp_constr (Global.env()) Evd.empty - (CRef (Libnames.Ident (Loc.ghost,id1),None)) in - let f2,ctx' = Constrintern.interp_constr (Global.env()) Evd.empty - (CRef (Libnames.Ident (Loc.ghost,id2),None)) in - let f1type = Typing.unsafe_type_of (Global.env()) Evd.empty f1 in - let f2type = Typing.unsafe_type_of (Global.env()) Evd.empty f2 in - let ar1 = List.length (fst (decompose_prod f1type)) in - let ar2 = List.length (fst (decompose_prod f2type)) in - let _ = - if not (Int.equal ar1 (List.length cl1)) then - Errors.error ("not the right number of arguments for " ^ Id.to_string id1) in - let _ = - if not (Int.equal ar2 (List.length cl2)) then - Errors.error ("not the right number of arguments for " ^ Id.to_string id2) in - Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id - ] -END -- cgit v1.2.3 From 6f6b67d3f772205d9481436d62efb6074e975555 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Mon, 19 Oct 2015 11:17:56 +0200 Subject: Function debug mode more formatted. --- plugins/funind/functional_principles_proofs.ml | 4 ++-- plugins/funind/invfun.ml | 4 ++-- plugins/funind/recdef.ml | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 169a706005..c9dd18a2fc 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -52,10 +52,10 @@ let rec print_debug_queue e = let _ = match e with | Some e -> - Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + Pp.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) | None -> begin - Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); + Pp.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); end in print_debug_queue None ; end diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d979401424..d074bbabd8 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -70,8 +70,8 @@ let do_observe_tac s tac g = with reraise -> let reraise = Errors.push reraise in let e = Cerrors.process_vernac_interp_error reraise in - observe (str "observation "++ s++str " raised exception " ++ - Errors.iprint e ++ str " on goal " ++ goal ); + observe (hov 0 (str "observation "++ s++str " raised exception " ++ + Errors.iprint e ++ str " on goal" ++ fnl() ++ goal )); iraise reraise;; diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index ac7140b9b4..aaeb577d39 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -212,10 +212,10 @@ let rec print_debug_queue b e = begin let lmsg,goal = Stack.pop debug_queue in if b then - Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + Pp.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) else begin - Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); + Pp.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); end; (* print_debug_queue false e; *) end -- cgit v1.2.3 From 4edab6bff366492d3e96c2b561384568927e2b05 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 11:20:15 +0200 Subject: Adding a monotonic variant of Goal.enter and Goal.nf_enter. --- proofs/proofview.ml | 61 ++++++++++++++++++++++++++++++++++++++++++---------- proofs/proofview.mli | 40 ++++++++++++++++++++++------------ 2 files changed, 76 insertions(+), 25 deletions(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index bc2cc3e913..da9c4da9f9 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -892,17 +892,9 @@ end module UnsafeRepr = Proof.Unsafe -(** {7 Notations} *) - -module Notations = struct - let (>>=) = tclBIND - let (<*>) = tclTHEN - let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) -end - -open Notations - - +let (>>=) = tclBIND +let (<*>) = tclTHEN +let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) (** {6 Goal-dependent tactics} *) @@ -982,6 +974,43 @@ module Goal = struct end end + type 'a enter = + { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + + let s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let gl = gmake env sigma goal in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (tac, sigma, _) = f.enter gl sigma in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let nf_s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let (gl, sigma) = nf_gmake env sigma goal in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (tac, sigma, _) = f.enter gl sigma in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + let goals = Env.get >>= fun env -> Pv.get >>= fun step -> @@ -1218,3 +1247,13 @@ module V82 = struct let (e, info) = Errors.push e in tclZERO ~info e end + +(** {7 Notations} *) + +module Notations = struct + let (>>=) = tclBIND + let (<*>) = tclTHEN + let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + type 'a enter = 'a Goal.enter = + { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } +end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 04ca01ec4d..b565589eb7 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -414,20 +414,6 @@ sig val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic end -(** {7 Notations} *) - -module Notations : sig - - (** {!tclBIND} *) - val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - (** {!tclTHEN} *) - val (<*>) : unit tactic -> 'a tactic -> 'a tactic - (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) - val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - -end - - (** {6 Goal-dependent tactics} *) module Goal : sig @@ -468,6 +454,17 @@ module Goal : sig (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : ([ `LZ ] t -> unit tactic) -> unit tactic + type 'a enter = + { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + + (** A variant of {!enter} allows to work with a monotonic state. The evarmap + returned by the argument is put back into the current state before firing + the returned tactic. *) + val s_enter : [ `LZ ] enter -> unit tactic + + (** Like {!s_enter}, but normalizes the goal beforehand. *) + val nf_s_enter : [ `NF ] enter -> unit tactic + (** Recover the list of current goals under focus, without evar-normalization *) val goals : [ `LZ ] t tactic list tactic @@ -583,3 +580,18 @@ module V82 : sig the monad. *) val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic end + +(** {7 Notations} *) + +module Notations : sig + + (** {!tclBIND} *) + val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + (** {!tclTHEN} *) + val (<*>) : unit tactic -> 'a tactic -> 'a tactic + (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) + val (<+>) : 'a tactic -> 'a tactic -> 'a tactic + + type 'a enter = 'a Goal.enter = + { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } +end -- cgit v1.2.3 From 872d88b5f5c5ab382c7a721f7089bd3085de3cc9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 11:56:42 +0200 Subject: Reducing the uses of tclEVARS in Tactics by using monotonous functions. --- tactics/tactics.ml | 183 +++++++++++++++++++++++++++++------------------------ 1 file changed, 102 insertions(+), 81 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 8a8b36a9e4..b2842ee6fb 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -610,17 +610,12 @@ let e_reduct_option ?(check=false) redfun = function (** Versions with evars to maintain the unification of universes resulting from conversions. *) -let tclWITHEVARS f k = - Proofview.Goal.enter begin fun gl -> - let evm, c' = f gl in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k c') - end - let e_change_in_concl (redfun,sty) = - tclWITHEVARS - (fun gl -> redfun (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) - (Proofview.Goal.raw_concl gl)) - (fun c -> convert_concl_no_check c sty) + Proofview.Goal.s_enter { enter = begin fun gl sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in + Sigma.Unsafe.of_pair (convert_concl_no_check c sty, sigma) + end } let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma = match c with @@ -639,11 +634,12 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma', (id,Some b',ty') let e_change_in_hyp redfun (id,where) = - tclWITHEVARS - (fun gl -> e_pf_change_decl redfun where - (Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl)) - (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)) - convert_hyp + Proofview.Goal.s_enter { enter = begin fun gl sigma -> + let sigma = Sigma.to_evar_map sigma in + let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in + let sigma, c = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + Sigma.Unsafe.of_pair (convert_hyp c, sigma) + end } type change_arg = Pattern.patvar_map -> evar_map -> evar_map * constr @@ -1249,9 +1245,9 @@ let general_elim with_evars clear_flag (c, lbindc) elim = (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in let t = Retyping.get_type_of env sigma c in let (mind,_) = reduce_to_quantified_ind env sigma t in @@ -1261,11 +1257,13 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + let tac = (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); elimrename = Some (false, constructors_nrealdecls (fst mind))}) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let general_case_analysis with_evars clear_flag (c,lbindc as cx) = match kind_of_term c with @@ -1298,11 +1296,13 @@ let find_eliminator c gl = let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE - (Proofview.Goal.enter begin fun gl -> - let evd, elim = find_eliminator c gl in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) + (Proofview.Goal.s_enter { enter = begin fun gl sigma -> + let sigma, elim = find_eliminator c gl in + let tac = (general_elim with_evars clear_flag cx elim) - end) + in + Sigma.Unsafe.of_pair (tac, sigma) + end }) begin function (e, info) -> match e with | IsNonrec -> (* For records, induction principles aren't there by default @@ -1467,21 +1467,22 @@ let descend_in_conjunctions avoid tac (err, info) c = (****************************************************) let solve_remaining_apply_goals = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let evd = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in - if Typeclasses.is_class_type sigma concl then - let evd', c' = Typeclasses.resolve_one_typeclass env sigma concl in - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS evd') + if Typeclasses.is_class_type evd concl then + let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in + let tac = (Proofview.V82.tactic (refine_no_check c')) - else Proofview.tclUNIT () - with Not_found -> Proofview.tclUNIT () - else Proofview.tclUNIT () - end + in + Sigma.Unsafe.of_pair (tac, evd') + else Sigma (Proofview.tclUNIT (), sigma, Sigma.refl) + with Not_found -> Sigma (Proofview.tclUNIT (), sigma, Sigma.refl) + else Sigma (Proofview.tclUNIT (), sigma, Sigma.refl) + end } let tclORELSEOPT t k = Proofview.tclORELSE t @@ -1733,15 +1734,17 @@ let new_exact_no_check c = Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma (c, h, Sigma.refl) } let exact_check c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in - Proofview.Unsafe.tclEVARS sigma <*> + let tac = Tacticals.New.tclTHEN (convert_leq ct concl) (new_exact_no_check c) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let exact_no_check = refine_no_check @@ -1947,7 +1950,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl @@ -1957,16 +1960,20 @@ let constructor_tac with_evars expctdnumopt i lbind = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; + let sigma = Sigma.to_evar_map sigma in let sigma, cons = Evd.fresh_constructor_instance - (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in + (Proofview.Goal.env gl) sigma (fst mind, i) in let cons = mkConstructU cons in let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in + let tac = (Tacticals.New.tclTHENLIST - [Proofview.Unsafe.tclEVARS sigma; + [ convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let one_constructor i lbind = constructor_tac false None i lbind @@ -2363,9 +2370,9 @@ let decode_hyp = function *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let t = match ty with Some t -> t | _ -> typ_of env sigma c in let eq_tac gl = match with_eq with | Some (lr,(loc,ido)) -> @@ -2388,13 +2395,15 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = | None -> (sigma, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in let (sigma,newcl,eq_tac) = eq_tac gl in - Tacticals.New.tclTHENLIST - [ Proofview.Unsafe.tclEVARS sigma; - convert_concl_no_check newcl DEFAULTcast; + let tac = + Tacticals.New.tclTHENLIST + [ convert_concl_no_check newcl DEFAULTcast; intro_gen (NamingMustBe (dloc,id)) (decode_hyp lastlhyp) true false; Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let insert_before decls lasthyp env = match lasthyp with @@ -2448,9 +2457,9 @@ let letin_tac with_eq id c ty occs = end let letin_pat_tac with_eq id c occs = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in @@ -2458,10 +2467,11 @@ let letin_pat_tac with_eq id c occs = let sigma,c = match res with | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c | Some (sigma,c) -> (sigma,c) in - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) + let tac = (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } (* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *) let forward b usetac ipat c = @@ -2604,10 +2614,10 @@ let generalize_gen_let lconstr gl = if Option.is_empty b then Some c else None) lconstr)) gl let new_generalize_gen_let lconstr = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in let (newcl, sigma), args = @@ -2618,12 +2628,14 @@ let new_generalize_gen_let lconstr = generalize_goal_gen env ids i o t cl, args) 0 lconstr ((concl, sigma), []) in - Proofview.Unsafe.tclEVARS sigma <*> + let tac = Proofview.Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma newcl in Sigma ((applist (ev, args)), sigma, p) end } - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let generalize_gen lconstr = generalize_gen_let (List.map (fun ((occs,c),na) -> @@ -3775,9 +3787,9 @@ let induction_tac with_evars params indvars elim gl = induction applies with the induction hypotheses *) let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in let statuslists,lhyp0,toclear,deps,avoid,dep = cook_sign hyp0 inhyps indvars env in let dep = dep || Option.cata (fun id -> occur_var env id concl) false hyp0 in @@ -3788,9 +3800,9 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = (fun a (id,b,_) -> if Option.is_empty b then (mkVar id)::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in let names = compute_induction_names (Array.length indsign) names in + let tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ - Proofview.Unsafe.tclEVARS sigma; (* Generalize dependent hyps (but not args) *) if deps = [] then Proofview.tclUNIT () else Proofview.V82.tactic (apply_type tmpcl deps_cstr); (* side-conditions in elim (resp case) schemes come last (resp first) *) @@ -3800,7 +3812,9 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = (Array.map2 (induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists)) indsign names) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = Proofview.Goal.enter begin fun gl -> @@ -3937,9 +3951,9 @@ let check_enough_applied env sigma elim = let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in @@ -3954,6 +3968,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in let (sigma,c0) = finish_evar_resolution ~flags env sigma (pending,c0) in + let tac = (if isrec then (* Historically, induction has side conditions last *) Tacticals.New.tclTHENFIRST @@ -3961,7 +3976,6 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ - Proofview.Unsafe.tclEVARS sigma; Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let b = not with_evars && with_eq != None in @@ -3976,21 +3990,25 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim if isrec then Proofview.cycle (-1) else Proofview.tclUNIT () ]) tac + in + Sigma.Unsafe.of_pair (tac, sigma) | Some (sigma',c) -> (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) let env = reset_with_named_context sign env in + let tac = Tacticals.New.tclTHENLIST [ - Proofview.Unsafe.tclEVARS sigma'; Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end }; tac ] - end + in + Sigma.Unsafe.of_pair (tac, sigma') + end } let has_generic_occurrences_but_goal cls id env ccl = clause_with_generic_context_selection cls && @@ -4215,20 +4233,20 @@ let elim_scheme_type elim t = end let elim_type t = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) - end + Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) + end } let case_type t = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = Tacmach.New.pf_apply build_case_analysis_scheme_default gl ind (Tacticals.New.elimination_sort_of_goal gl) in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) - end + Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) + end } (************************************************) @@ -4480,10 +4498,11 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let current_sign = Global.named_context() and global_sign = Proofview.Goal.hyps gl in - let evdref = ref (Proofview.Goal.sigma gl) in + let sigma = Sigma.to_evar_map sigma in + let evdref = ref sigma in let sign,secsign = List.fold_right (fun (id,_,_ as d) (s1,s2) -> @@ -4533,12 +4552,12 @@ let abstract_subproof id gk tac = let effs = cons_side_effects eff Entries.(snd (Future.force const.const_entry_body)) in let solve = - Proofview.Unsafe.tclEVARS evd <*> Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in - if not safe then Proofview.mark_as_unsafe <*> solve else solve - end + let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in + Sigma.Unsafe.of_pair (tac, evd) + end } let anon_id = Id.of_string "anonymous" @@ -4558,7 +4577,8 @@ let tclABSTRACT name_op tac = abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + let sigma = Sigma.to_evar_map sigma in try let core_flags = { (default_unify_flags ()).core_unify_flags with @@ -4570,10 +4590,11 @@ let unify ?(state=full_transparent_state) x y = merge_unify_flags = core_flags; subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } in - let evd = w_unify (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) Reduction.CONV ~flags x y - in Proofview.Unsafe.tclEVARS evd - with e when Errors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Not unifiable") - end + let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in + Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma) + with e when Errors.noncritical e -> + Sigma.Unsafe.of_pair (Tacticals.New.tclFAIL 0 (str"Not unifiable"), sigma) + end } module Simple = struct (** Simplified version of some of the above tactics *) -- cgit v1.2.3 From bdddfe4f3f720a65cdb9ea6ab2573d4adaa8694e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 14:32:50 +0200 Subject: Removing tclEVARS in various places. --- tactics/auto.ml | 9 +++++---- tactics/autorewrite.ml | 13 ++++++++----- tactics/contradiction.ml | 13 ++++++++----- tactics/equality.ml | 18 ++++++++++++------ tactics/evar_tactics.ml | 17 +++++++++-------- tactics/extratactics.ml4 | 11 ++++++----- tactics/inv.ml | 10 ++++++---- 7 files changed, 54 insertions(+), 37 deletions(-) diff --git a/tactics/auto.ml b/tactics/auto.ml index 617c491c35..9ca6162a21 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -117,10 +117,11 @@ let exact poly (c,clenv) = let ctx = Evd.evar_universe_context clenv.evd in ctx, c in - Proofview.Goal.enter begin fun gl -> - let sigma = Evd.merge_universe_context (Proofview.Goal.sigma gl) ctx in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (exact_check c') - end + Proofview.Goal.s_enter { enter = begin fun gl sigma -> + let sigma = Sigma.to_evar_map sigma in + let sigma = Evd.merge_universe_context sigma ctx in + Sigma.Unsafe.of_pair (exact_check c', sigma) + end } (* Util *) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 3a9d40de03..9892d29541 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -18,6 +18,8 @@ open Util open Tacexpr open Mod_subst open Locus +open Sigma.Notations +open Proofview.Notations (* Rewriting rules *) type rew_rule = { rew_lemma: constr; @@ -91,14 +93,15 @@ type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tac (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in - let try_rewrite dir ctx c tc = Proofview.Goal.nf_enter (fun gl -> + let try_rewrite dir ctx c tc = + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (general_rewrite_maybe_in dir c' tc) - ) in + let tac = general_rewrite_maybe_in dir c' tc in + Sigma.Unsafe.of_pair (tac, sigma) + end } in let lrul = List.map (fun h -> let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 22f218b4fb..0253747641 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -13,6 +13,8 @@ open Tactics open Coqlib open Reductionops open Misctypes +open Sigma.Notations +open Proofview.Notations (* Absurd *) @@ -22,18 +24,19 @@ let mk_absurd_proof t = mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma c in let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in let t = j.Environ.utj_val in + let tac = Tacticals.New.tclTHENLIST [ - Proofview.Unsafe.tclEVARS sigma; elim_type (build_coq_False ()); Simple.apply (mk_absurd_proof t) - ] - end + ] in + Sigma.Unsafe.of_pair (tac, sigma) + end } let absurd c = absurd c diff --git a/tactics/equality.ml b/tactics/equality.ml index a74d555dd0..1f66699004 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -40,6 +40,7 @@ open Eqschemes open Locus open Locusops open Misctypes +open Sigma.Notations open Proofview.Notations open Unification @@ -346,17 +347,20 @@ let type_of_clause cls gl = match cls with | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let isatomic = isProd (whd_zeta hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in let (sigma,elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in - Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS effs <*> + let tac = + Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let adjust_rewriting_direction args lft2rgt = match args with @@ -1472,19 +1476,21 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in + let tac = tclTHENFIRST (tclTHENLIST [ - (Proofview.Unsafe.tclEVARS sigma); (change_concl typ); (* Put in pattern form *) (replace_core onConcl l2r eqn) ]) (change_concl expected) (* Put in normalized form *) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let cutSubstInHyp l2r eqn id = Proofview.Goal.nf_enter begin fun gl -> diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 3d544274d2..43a31b04fc 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -15,6 +15,7 @@ open Refiner open Evd open Locus open Sigma.Notations +open Proofview.Notations (* The instantiate tactic *) @@ -69,17 +70,17 @@ let instantiate_tac_by_name id c = let let_evar name typ = let src = (Loc.ghost,Evar_kinds.GoalEvar) in - Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + Proofview.Goal.s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let id = match name with | Names.Anonymous -> let id = Namegen.id_of_name_using_hdchar env typ name in Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) - | Names.Name id -> id in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (evar, sigma', _) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in - let sigma' = Sigma.to_evar_map sigma' in - Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS sigma')) + | Names.Name id -> id + in + let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let tac = (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) - end + in + Sigma (tac, sigma, p) + end } diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index d7d82111c8..f543a7691a 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -617,8 +617,8 @@ let out_arg = function | ArgArg x -> x let hResolve id c occ t = - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + let sigma = Sigma.to_evar_map sigma in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in let env_ids = Termops.ids_of_context env in @@ -636,10 +636,11 @@ let hResolve id c occ t = let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) + let tac = (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } let hResolve_auto id c t = let rec resolve_auto n = diff --git a/tactics/inv.ml b/tactics/inv.ml index 0acaeb44cf..85f2d2f91f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -432,8 +432,8 @@ let rewrite_equations_tac as_mode othin id neqns names ba = tac let raw_inversion inv_kind id status names = - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let c = mkVar id in @@ -462,7 +462,7 @@ let raw_inversion inv_kind id status names = in let neqns = List.length realargs in let as_mode = names != None in - tclTHEN (Proofview.Unsafe.tclEVARS sigma) + let tac = (tclTHENS (assert_before Anonymous cut_concl) [case_tac names @@ -470,7 +470,9 @@ let raw_inversion inv_kind id status names = (rewrite_equations_tac as_mode inv_kind id neqns)) (Some elim_predicate) ind (c, t); onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) - end + in + Sigma.Unsafe.of_pair (tac, sigma) + end } (* Error messages of the inversion tactics *) let wrap_inv_error id = function (e, info) -> match e with -- cgit v1.2.3 From c3967bd7a71df53a004478d23b072309f13f2ff5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 19 Oct 2015 16:06:46 +0200 Subject: Turning anomaly into error for #4372 (weakness of inversion in the presence of dependent types with only superficial dependency). See discussion at https://coq.inria.fr/bugs/show_bug.cgi?id=4372. --- tactics/equality.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index 5ed9ac2ba0..bc711b81ef 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1126,7 +1126,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." - | None -> anomaly (Pp.str "Not enough components to build the dependent tuple") + | None -> + (* This at least happens if what has been detected as a + dependency is not one; use an evasive error message; + even if the problem is upwards: unification should be + tried in the first place in make_iterated_tuple instead + of approximatively computing the free rels; then + unsolved evars would mean not binding rel *) + error "Cannot solve a unification problem." in let scf = sigrec_clausal_form siglen ty in !evdref, Evarutil.nf_evar !evdref scf -- cgit v1.2.3 From c8986ad5589ad5bbed0936f9c16bba3f2ae1d2c4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 15:46:34 +0200 Subject: More monotonicity in Tactics. --- pretyping/unification.ml | 14 ++++++++++---- pretyping/unification.mli | 10 +++++----- tactics/tactics.ml | 49 +++++++++++++++++++++++++++-------------------- 3 files changed, 43 insertions(+), 30 deletions(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 9caa868958..269c723e30 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1442,9 +1442,10 @@ let indirect_dependency d decls = pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls)) let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = + let current_sigma = Sigma.to_evar_map current_sigma in let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in let sigma, subst = nf_univ_variables sigma in - sigma, subst_univs_constr subst (nf_evar sigma c) + Sigma.Unsafe.of_pair (subst_univs_constr subst (nf_evar sigma c), sigma) let default_matching_core_flags sigma = let ts = Names.full_transparent_state in { @@ -1595,7 +1596,11 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = in let lastlhyp = if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in - (id,sign,depdecls,lastlhyp,ccl,out test) + let res = match out test with + | None -> None + | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma)) + in + (id,sign,depdecls,lastlhyp,ccl,res) with SubtermUnificationError e -> raise (PretypeError (env,sigma,CannotUnifyOccurrences e)) @@ -1617,12 +1622,13 @@ type abstraction_request = | AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool | AbstractExact of Name.t * constr * types option * clause * bool -type abstraction_result = +type 'r abstraction_result = Names.Id.t * named_context_val * Context.named_declaration list * Names.Id.t option * - types * (Evd.evar_map * constr) option + types * (constr, 'r) Sigma.sigma option let make_abstraction env evd ccl abs = + let evd = Sigma.to_evar_map evd in match abs with | AbstractPattern (from_prefix,check,name,c,occs,check_occs) -> make_abstraction_core name diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 119b1a7590..51a51f3752 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -73,15 +73,15 @@ type abstraction_request = | AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool val finish_evar_resolution : ?flags:Pretyping.inference_flags -> - env -> Evd.evar_map -> pending_constr -> Evd.evar_map * constr + env -> 'r Sigma.t -> pending_constr -> (constr, 'r) Sigma.sigma -type abstraction_result = +type 'r abstraction_result = Names.Id.t * named_context_val * Context.named_declaration list * Names.Id.t option * - types * (Evd.evar_map * constr) option + types * (constr, 'r) Sigma.sigma option -val make_abstraction : env -> Evd.evar_map -> constr -> - abstraction_request -> abstraction_result +val make_abstraction : env -> 'r Sigma.t -> constr -> + abstraction_request -> 'r abstraction_result val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b2842ee6fb..8cc460560b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2418,6 +2418,7 @@ let insert_before decls lasthyp env = (* unsafe *) let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = + let sigma = Sigma.to_evar_map sigma in let body = if dep then Some c else None in let t = match ty with Some t -> t | _ -> typ_of env sigma c in match with_eq with @@ -2446,31 +2447,30 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in let (id,_,depdecls,lastlhyp,ccl,_) = make_abstraction env sigma ccl abs in (* We keep the original term to match *) - letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty - end + let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in + Sigma (tac, sigma, Sigma.refl) + end } let letin_pat_tac with_eq id c occs = Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in - let sigma,c = match res with + let Sigma (c, sigma, p) = match res with | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c - | Some (sigma,c) -> (sigma,c) in + | Some res -> res in let tac = (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } (* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *) @@ -3892,6 +3892,7 @@ let clear_unselected_context id inhyps cls gl = | None -> tclIDTAC gl let use_bindings env sigma elim must_be_closed (c,lbind) typ = + let sigma = Sigma.to_evar_map sigma in let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until @@ -3913,7 +3914,8 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = if must_be_closed && occur_meta (clenv_value indclause) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) - pose_all_metas_as_evars env indclause.evd (clenv_value indclause) + let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in + Sigma.Unsafe.of_pair (c, sigma) with e when catchable_exception e -> try find_clause (try_red_product env sigma typ) with Redelimination -> raise e in @@ -3931,6 +3933,7 @@ let check_expected_type env sigma (elimc,bl) elimt = fun t -> Evarconv.e_cumul env (ref sigma) t u let check_enough_applied env sigma elim = + let sigma = Sigma.to_evar_map sigma in (* A heuristic to decide whether the induction arg is enough applied *) match elim with | None -> @@ -3953,11 +3956,10 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = Proofview.Goal.s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in - let (sigma',c) = use_bindings env sigma elim false (c0,lbind) t0 in + let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in match res with @@ -3967,7 +3969,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in - let (sigma,c0) = finish_evar_resolution ~flags env sigma (pending,c0) in + let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in let tac = (if isrec then (* Historically, induction has side conditions last *) @@ -3977,10 +3979,9 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in let b = not with_evars && with_eq != None in - let (sigma,c) = use_bindings env sigma elim b (c0,lbind) t0 in - let t = Retyping.get_type_of env sigma c in + let Sigma (c, sigma, _) = use_bindings env sigma elim b (c0,lbind) t0 in + let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) end }; Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable); @@ -3991,9 +3992,9 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim ]) tac in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, q) - | Some (sigma',c) -> + | Some (Sigma (c, sigma', q)) -> (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) @@ -4001,13 +4002,12 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let tac = Tacticals.New.tclTHENLIST [ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end }; tac ] in - Sigma.Unsafe.of_pair (tac, sigma') + Sigma (tac, sigma', p +> q) end } let has_generic_occurrences_but_goal cls id env ccl = @@ -4026,6 +4026,7 @@ let induction_gen clear_flag isrec with_evars elim let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in let t = typ_of env sigma c in + let sigma = Sigma.Unsafe.of_evar_map sigma in let is_arg_pure_hyp = isVar c && not (mem_named_context (destVar c) (Global.named_context())) && lbind == NoBindings && not with_evars && Option.is_empty eqname @@ -4119,7 +4120,10 @@ let induction_destruct isrec with_evars (lc,elim) = let finish_evar_resolution f = let (sigma',(c,lbind)) = f env sigma in let pending = (sigma,sigma') in - snd (finish_evar_resolution env sigma' (pending,c)),lbind in + let sigma' = Sigma.Unsafe.of_evar_map sigma' in + let Sigma (c, _, _) = finish_evar_resolution env sigma' (pending,c) in + (c, lbind) + in let c = map_induction_arg finish_evar_resolution c in onInductionArg (fun _clear_flag (c,lbind) -> @@ -4161,7 +4165,10 @@ let induction_destruct isrec with_evars (lc,elim) = let pending = (sigma,sigma') in if lbind != NoBindings then error "'with' clause not supported here."; - snd (finish_evar_resolution env sigma' (pending,c)) in + let sigma' = Sigma.Unsafe.of_evar_map sigma' in + let Sigma (c, _, _) = finish_evar_resolution env sigma' (pending,c) in + c + in let lc = List.map (on_pi1 (map_induction_arg finish_evar_resolution)) lc in let newlc = List.map (fun (x,(eqn,names),cls) -> -- cgit v1.2.3 From b3b04d0a5c7c39140e2125321a17957ddcaf2b33 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 19 Oct 2015 17:23:48 +0200 Subject: Test for #4372 (anomaly in inversion in the presence of fake dependency). --- test-suite/bugs/closed/4372.v | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 test-suite/bugs/closed/4372.v diff --git a/test-suite/bugs/closed/4372.v b/test-suite/bugs/closed/4372.v new file mode 100644 index 0000000000..428192a344 --- /dev/null +++ b/test-suite/bugs/closed/4372.v @@ -0,0 +1,20 @@ +(* Tactic inversion was raising an anomaly because of a fake + dependency of TypeDenote into its argument *) + +Inductive expr := +| ETrue. + +Inductive IntermediateType : Set := ITbool. + +Definition TypeDenote (IT : IntermediateType) : Type := + match IT with + | _ => bool + end. + +Inductive ValueDenote : forall (e:expr) it, TypeDenote it -> Prop := +| VT : ValueDenote ETrue ITbool true. + +Goal forall it v, @ValueDenote ETrue it v -> True. + intros it v H. + inversion H. +Abort. -- cgit v1.2.3 From 50a574f8b3e7f29550d7abf600d92eb43e7f8ef6 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Mon, 19 Oct 2015 18:12:27 +0200 Subject: Categorizing debug messages as such + NonLogical uses loggers. --- proofs/logic_monad.ml | 15 +++++++-------- proofs/logic_monad.mli | 9 +++++---- proofs/tactic_debug.ml | 6 +++--- tactics/tacinterp.ml | 6 +++--- 4 files changed, 18 insertions(+), 18 deletions(-) diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml index b9165aa812..e3caa886a2 100644 --- a/proofs/logic_monad.ml +++ b/proofs/logic_monad.ml @@ -94,14 +94,6 @@ struct let print_char = fun c -> (); fun () -> print_char c - (** {!Pp.pp}. The buffer is also flushed. *) - let print_debug = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e -> - let (e, info) = Errors.push e in raise ~info e () - - (** {!Pp.pp}. The buffer is also flushed. *) - let print = fun s -> (); fun () -> try Pp.msg_notice s; Pp.pp_flush () with e -> - let (e, info) = Errors.push e in raise ~info e () - let timeout = fun n t -> (); fun () -> Control.timeout n t (Exception Timeout) @@ -111,6 +103,13 @@ struct let (e, info) = Errors.push e in Util.iraise (Exception e, info) + (** Use the current logger. The buffer is also flushed. *) + let print_debug s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) + let print_info s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) + let print_warning s = make (fun _ -> Pp.msg_warning s;Pp.pp_flush ()) + let print_error s = make (fun _ -> Pp.msg_error s;Pp.pp_flush ()) + let print_notice s = make (fun _ -> Pp.msg_notice s;Pp.pp_flush ()) + let run = fun x -> try x () with Exception e as src -> let (src, info) = Errors.push src in diff --git a/proofs/logic_monad.mli b/proofs/logic_monad.mli index 511dd7a6ed..84ffda7533 100644 --- a/proofs/logic_monad.mli +++ b/proofs/logic_monad.mli @@ -55,12 +55,13 @@ module NonLogical : sig val read_line : string t val print_char : char -> unit t - (** {!Pp.pp}. The buffer is also flushed. *) - val print : Pp.std_ppcmds -> unit t - (* FIXME: shouldn't we have a logger instead? *) - (** {!Pp.pp}. The buffer is also flushed. *) + (** Loggers. The buffer is also flushed. *) val print_debug : Pp.std_ppcmds -> unit t + val print_warning : Pp.std_ppcmds -> unit t + val print_notice : Pp.std_ppcmds -> unit t + val print_info : Pp.std_ppcmds -> unit t + val print_error : Pp.std_ppcmds -> unit t (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 667765dbf2..6d6215c521 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -33,7 +33,7 @@ let explain_logic_error = ref (fun e -> mt()) let explain_logic_error_no_anomaly = ref (fun e -> mt()) let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) -let msg_tac_notice s = Proofview.NonLogical.print (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) (* Prints the goal *) @@ -122,7 +122,7 @@ let run ini = let open Proofview.NonLogical in if not ini then begin - Proofview.NonLogical.print (str"\b\r\b\r") >> + Proofview.NonLogical.print_notice (str"\b\r\b\r") >> !skipped >>= fun skipped -> msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) end >> @@ -137,7 +137,7 @@ let rec prompt level = let runtrue = run true in begin let open Proofview.NonLogical in - Proofview.NonLogical.print (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> + Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in Proofview.NonLogical.catch Proofview.NonLogical.read_line begin function (e, info) -> match e with diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 96d0b592b8..5a0d26a1cb 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -44,8 +44,8 @@ open Proofview.Notations let safe_msgnl s = Proofview.NonLogical.catch - (Proofview.NonLogical.print (s++fnl())) - (fun _ -> Proofview.NonLogical.print (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) + (Proofview.NonLogical.print_debug (s++fnl())) + (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) type value = tlevel generic_argument @@ -1136,7 +1136,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with interp_message ist s >>= fun msg -> return (hov 0 msg , hov 0 msg) in - let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print msgnl)) in + let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in let log (msg,_) = Proofview.Trace.log (fun () -> msg) in let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in Ftactic.run msgnl begin fun msgnl -> -- cgit v1.2.3 From 666568377cbe1c18ce479d32f6359aa61af6d553 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 16:36:53 +0200 Subject: Type delayed_open_constr is now monotonic. --- intf/tacexpr.mli | 9 +++++---- plugins/funind/indfun.ml | 3 ++- printing/pptactic.ml | 5 ++++- tactics/equality.ml | 4 ++-- tactics/inv.ml | 4 ++-- tactics/tacinterp.ml | 37 ++++++++++++++++++++++++++++--------- tactics/tactics.ml | 19 +++++++++++-------- tactics/tactics.mli | 2 ++ 8 files changed, 56 insertions(+), 27 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 45f482cd44..124d4c0fef 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -122,11 +122,12 @@ type open_glob_constr = unit * glob_constr_and_expr type binding_bound_vars = Id.Set.t type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern -type delayed_open_constr_with_bindings = - Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr with_bindings +type 'a delayed_open = + { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } -type delayed_open_constr = - Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr +type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open + +type delayed_open_constr = Term.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr located type intro_patterns = delayed_open_constr intro_pattern_expr located list diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index eadeebd38e..ab3629f89e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -10,6 +10,7 @@ open Glob_term open Declarations open Misctypes open Decl_kinds +open Sigma.Notations let is_rec_info scheme_info = let test_branche min acc (_,_,br) = @@ -86,7 +87,7 @@ let functional_induction with_clean c princl pat = in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))),(None,pat),None)) + List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in let princ' = Some (princ,bindings) in diff --git a/printing/pptactic.ml b/printing/pptactic.ml index e8ccd29c8a..72d2eedcc3 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1437,6 +1437,9 @@ end) (** Registering *) +let run_delayed c = + Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } + let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in @@ -1447,7 +1450,7 @@ let () = Constrarg.wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) - (Miscprint.pr_intro_pattern (fun c -> pr_constr (snd (c (Global.env()) Evd.empty)))); + (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c)))); Genprint.register_print0 Constrarg.wit_clause_dft_concl (pr_clauses (Some true) pr_lident) diff --git a/tactics/equality.ml b/tactics/equality.ml index 1f66699004..c6d74525fe 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -487,7 +487,7 @@ let apply_special_clear_request clear_flag f = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in try - let sigma,(c,bl) = f env sigma in + let ((c, bl), sigma) = run_delayed env sigma f in apply_clear_request clear_flag (use_clear_hyp_by_default ()) c with e when catchable_exception e -> tclIDTAC @@ -498,7 +498,7 @@ let general_multi_rewrite with_evars l cl tac = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma,c = f env sigma in + let (c, sigma) = run_delayed env sigma f in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma end diff --git a/tactics/inv.ml b/tactics/inv.ml index 85f2d2f91f..d3d5c9a9bd 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -285,10 +285,10 @@ let error_too_many_names pats = tclZEROMSG ~loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ - str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (snd (c env Evd.empty)))) pats ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (fst (run_delayed env Evd.empty c)))) pats ++ str ".") -let rec get_names (allow_conj,issimple) (loc,pat as x) = match pat with +let get_names (allow_conj,issimple) (loc, pat as x) = match pat with | IntroNaming IntroAnonymous | IntroForthcoming _ -> error "Anonymous pattern not allowed for inversion equations." | IntroNaming (IntroFresh _) -> diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 96d0b592b8..ec6f041336 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -40,6 +40,7 @@ open Misctypes open Locus open Tacintern open Taccoerce +open Sigma.Notations open Proofview.Notations let safe_msgnl s = @@ -801,7 +802,7 @@ let rec message_of_value v = Ftactic.return (int (out_gen (topwit wit_int) v)) else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in - let print env sigma c = pr_constr_env env sigma (snd (c env Evd.empty)) in + let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in Ftactic.nf_enter begin fun gl -> Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Proofview.Goal.sigma gl) c) p) end @@ -864,7 +865,11 @@ and interp_intro_pattern_action ist env sigma = function let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l | IntroApplyOn (c,ipat) -> - let c = fun env sigma -> interp_constr ist env sigma c in + let c = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } in let sigma,ipat = interp_intro_pattern ist env sigma ipat in sigma, IntroApplyOn (c,ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x @@ -967,13 +972,21 @@ let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = let loc1 = loc_of_glob_constr c in let loc2 = loc_of_bindings bl in let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in - let f env sigma = interp_open_constr_with_bindings ist env sigma cb in + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in + Sigma.Unsafe.of_pair (c, sigma) + } in (loc,f) let interp_induction_arg ist gl arg = match arg with | keep,ElimOnConstr c -> - keep,ElimOnConstr (fun env sigma -> interp_constr_with_bindings ist env sigma c) + keep,ElimOnConstr { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr_with_bindings ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent (loc,id) -> let error () = user_err_loc (loc, "", @@ -984,7 +997,7 @@ let interp_induction_arg ist gl arg = if Tactics.is_quantified_hypothesis id' gl then keep,ElimOnIdent (loc,id') else - (try keep,ElimOnConstr (fun env sigma -> sigma,(constr_of_id env id',NoBindings)) + (try keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((constr_of_id env id',NoBindings), sigma, Sigma.refl) } with Not_found -> user_err_loc (loc,"", pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis.")) @@ -1005,16 +1018,18 @@ let interp_induction_arg ist gl arg = keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) else match Value.to_constr v with | None -> error () - | Some c -> keep,ElimOnConstr (fun env sigma -> sigma,(c,NoBindings)) + | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } with Not_found -> (* We were in non strict (interactive) mode *) if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (loc,id) else let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in - let f env sigma = + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in let (sigma,c) = interp_open_constr ist env sigma c in - sigma,(c,NoBindings) in + Sigma.Unsafe.of_pair ((c,NoBindings), sigma) + } in keep,ElimOnConstr f (* Associates variables with values and gives the remaining variables and @@ -2185,7 +2200,11 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacRewrite (ev,l,cl,by) -> Proofview.Goal.enter begin fun gl -> let l' = List.map (fun (b,m,(keep,c)) -> - let f env sigma = interp_open_constr_with_bindings ist env sigma c in + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } in (b,m,keep,f)) l in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 8cc460560b..04ee0183a0 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -981,12 +981,15 @@ let rec intros_move = function Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false) (intros_move rest) +let run_delayed env sigma c = + Sigma.run sigma { Sigma.run = fun sigma -> c.delayed env sigma } + (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) let onOpenInductionArg env sigma tac = function | clear_flag,ElimOnConstr f -> - let (sigma',cbl) = f env sigma in + let (cbl, sigma') = run_delayed env sigma f in let pending = (sigma,sigma') in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma') @@ -1578,7 +1581,7 @@ let apply_with_delayed_bindings_gen b e l = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma, cb = f env sigma in + let (cb, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES e (general_apply b b e k (loc,cb)) sigma end @@ -1680,7 +1683,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let sigma, c = f env sigma in + let (c, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,c)) tac) @@ -2245,7 +2248,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma,c = f env sigma in + let (c, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES false (Tacticals.New.tclTHENFIRST (* Skip the side conditions of the apply *) @@ -2339,7 +2342,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars *) let apply_in simple with_evars clear_flag id lemmas ipat = - let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, fun _ sigma -> sigma, l)) lemmas in + let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma (l, sigma, Sigma.refl) })) lemmas in general_apply_in false simple simple with_evars clear_flag id lemmas ipat let apply_delayed_in simple with_evars clear_flag id lemmas ipat = @@ -2729,7 +2732,7 @@ let check_unused_names names = (str"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_constr (snd (c (Global.env()) Evd.empty)))) names) + (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names) let intropattern_of_name gl avoid = function | Anonymous -> IntroNaming IntroAnonymous @@ -4118,7 +4121,7 @@ let induction_destruct isrec with_evars (lc,elim) = (* will be removable when is_functional_induction will be more clever *) if not (Option.is_empty cls) then error "'in' clause not supported here."; let finish_evar_resolution f = - let (sigma',(c,lbind)) = f env sigma in + let ((c, lbind), sigma') = run_delayed env sigma f in let pending = (sigma,sigma') in let sigma' = Sigma.Unsafe.of_evar_map sigma' in let Sigma (c, _, _) = finish_evar_resolution env sigma' (pending,c) in @@ -4161,7 +4164,7 @@ let induction_destruct isrec with_evars (lc,elim) = | Some elim -> (* Several induction hyps with induction scheme *) let finish_evar_resolution f = - let (sigma',(c,lbind)) = f env sigma in + let ((c, lbind), sigma') = run_delayed env sigma f in let pending = (sigma,sigma') in if lbind != NoBindings then error "'with' clause not supported here."; diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 38e6ce0eaf..d62d27ca34 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -205,6 +205,8 @@ val apply_delayed_in : (clear_flag * delayed_open_constr_with_bindings located) list -> intro_pattern option -> unit Proofview.tactic +val run_delayed : Environ.env -> evar_map -> 'a delayed_open -> 'a * evar_map + (** {6 Elimination tactics. } *) (* -- cgit v1.2.3 From 7d6d9c5aea6232200b99e828b7e04b49808f8478 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 19 Oct 2015 18:13:32 +0200 Subject: Do occur-check w.r.t existential's types also when instantiating an evar. --- pretyping/evarsolve.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index bbc4f1db29..b384bdfe16 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1272,6 +1272,15 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = restrict_evar evd evk None (UpdateWith candidates) | l -> evd +let occur_evar_upto_types sigma n c = + let rec occur_rec c = match kind_of_term c with + | Evar (sp,_) when Evar.equal sp n -> raise Occur + | Evar e -> Option.iter occur_rec (existential_opt_value sigma e); + occur_rec (existential_type sigma e) + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + (* We try to instantiate the evar assuming the body won't depend * on arguments that are not Rels or Vars, or appearing several times * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) @@ -1459,7 +1468,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (recheck_applications conv_algo (evar_env evi) evdref t'; t') else t' in (!evdref,body) - + (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said, * [define] tries to find an instance lhs such that @@ -1484,7 +1493,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = if occur_meta body then raise MetaOccurInBodyInternal; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) - if occur_evar_upto evd' evk body then raise (OccurCheckIn (evd',body)); + if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let evd', body = refresh_universes pbty env evd' body in (* Cannot strictly type instantiations since the unification algorithm -- cgit v1.2.3 From 94502de7ecf7db3830b2e419f43627fa2c8c1c87 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 18:47:50 +0200 Subject: Removing some unsafe uses of monotonicity. --- engine/sigma.ml | 10 +++++++ engine/sigma.mli | 16 +++++++++++ tactics/tactics.ml | 78 ++++++++++++++++++++++++++---------------------------- 3 files changed, 64 insertions(+), 40 deletions(-) diff --git a/engine/sigma.ml b/engine/sigma.ml index e6189e29ce..e3e83b6024 100644 --- a/engine/sigma.ml +++ b/engine/sigma.ml @@ -23,6 +23,8 @@ let lift_evar evk () = evk let to_evar_map evd = evd let to_evar evk = evk +let here x s = Sigma (x, s, ()) + (** API *) type 'r fresh = Fresh : 's evar * 's t * ('r, 's) le -> 'r fresh @@ -34,6 +36,14 @@ let new_evar sigma ?naming info = let define evk c sigma = Sigma ((), Evd.define evk c sigma, ()) +let fresh_constructor_instance env sigma pc = + let (sigma, c) = Evd.fresh_constructor_instance env sigma pc in + Sigma (c, sigma, ()) + +let fresh_global ?rigid ?names env sigma r = + let (sigma, c) = Evd.fresh_global ?rigid ?names env sigma r in + Sigma (c, sigma, ()) + (** Run *) type 'a run = { run : 'r. 'r t -> ('a, 'r) sigma } diff --git a/engine/sigma.mli b/engine/sigma.mli index f4c47e08c6..6ac56bb3e2 100644 --- a/engine/sigma.mli +++ b/engine/sigma.mli @@ -6,6 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Names +open Constr + (** Monotonous state enforced by typing. This module allows to constrain uses of evarmaps in a monotonous fashion, @@ -37,6 +40,11 @@ type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma type 'r evar (** Stage-indexed evars *) +(** {5 Constructors} *) + +val here : 'a -> 'r t -> ('a, 'r) sigma +(** [here x s] is a shorthand for [Sigma (x, s, refl)] *) + (** {5 Postponing} *) val lift_evar : 'r evar -> ('r, 's) le -> 's evar @@ -56,6 +64,14 @@ val new_evar : 'r t -> ?naming:Misctypes.intro_pattern_naming_expr -> val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma +(** Polymorphic universes *) + +val fresh_constructor_instance : Environ.env -> 'r t -> constructor -> + (pconstructor, 'r) sigma + +val fresh_global : ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> + 'r t -> Globnames.global_reference -> (constr, 'r) sigma + (** FILLME *) (** {5 Run} *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 04ee0183a0..866f406230 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -58,7 +58,7 @@ let inj_with_occurrences e = (AllOccurrences,e) let dloc = Loc.ghost -let typ_of = Retyping.get_type_of +let typ_of env sigma c = Retyping.get_type_of env (Sigma.to_evar_map sigma) c open Goptions @@ -209,18 +209,17 @@ let convert_concl ?(check=true) ty k = let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let sigma = + let Sigma ((), sigma, p) = if check then begin + let sigma = Sigma.to_evar_map sigma in ignore (Typing.unsafe_type_of env sigma ty); let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; - sigma - end else sigma in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (x, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store ty in + Sigma.Unsafe.of_pair ((), sigma) + end else Sigma.here () sigma in + let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in - Sigma (ans, sigma, p) + Sigma (ans, sigma, p +> q) end } end @@ -1482,9 +1481,9 @@ let solve_remaining_apply_goals = (Proofview.V82.tactic (refine_no_check c')) in Sigma.Unsafe.of_pair (tac, evd') - else Sigma (Proofview.tclUNIT (), sigma, Sigma.refl) - with Not_found -> Sigma (Proofview.tclUNIT (), sigma, Sigma.refl) - else Sigma (Proofview.tclUNIT (), sigma, Sigma.refl) + else Sigma.here (Proofview.tclUNIT ()) sigma + with Not_found -> Sigma.here (Proofview.tclUNIT ()) sigma + else Sigma.here (Proofview.tclUNIT ()) sigma end } let tclORELSEOPT t k = @@ -1734,7 +1733,7 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let new_exact_no_check c = - Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma (c, h, Sigma.refl) } + Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = Proofview.Goal.s_enter { enter = begin fun gl sigma -> @@ -1778,7 +1777,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma (mkVar id, h, Sigma.refl) } + Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar id) h } else arec gl only_eq rest in let assumption_tac gl = @@ -1963,8 +1962,7 @@ let constructor_tac with_evars expctdnumopt i lbind = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; - let sigma = Sigma.to_evar_map sigma in - let sigma, cons = Evd.fresh_constructor_instance + let Sigma (cons, sigma, p) = Sigma.fresh_constructor_instance (Proofview.Goal.env gl) sigma (fst mind, i) in let cons = mkConstructU cons in @@ -1975,7 +1973,7 @@ let constructor_tac with_evars expctdnumopt i lbind = convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let one_constructor i lbind = constructor_tac false None i lbind @@ -2342,7 +2340,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars *) let apply_in simple with_evars clear_flag id lemmas ipat = - let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma (l, sigma, Sigma.refl) })) lemmas in + let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma.here l sigma })) lemmas in general_apply_in false simple simple with_evars clear_flag id lemmas ipat let apply_delayed_in simple with_evars clear_flag id lemmas ipat = @@ -2375,9 +2373,8 @@ let decode_hyp = function let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Proofview.Goal.s_enter { enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let t = match ty with Some t -> t | _ -> typ_of env sigma c in - let eq_tac gl = match with_eq with + let Sigma ((newcl, eq_tac), sigma, p) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl @@ -2385,19 +2382,22 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = | IntroIdentifier id -> id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let sigma, eq = Evd.fresh_global env sigma eqdata.eq in - let sigma, refl = Evd.fresh_global env sigma eqdata.refl in + let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in + let sigma = Sigma.to_evar_map sigma in let sigma, _ = Typing.type_of env sigma term in - sigma, term, + let ans = term, Tacticals.New.tclTHEN (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) (clear_body [heq;id]) + in + Sigma.Unsafe.of_pair (ans, sigma) | None -> - (sigma, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in - let (sigma,newcl,eq_tac) = eq_tac gl in + Sigma.here (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) sigma + in let tac = Tacticals.New.tclTHENLIST [ convert_concl_no_check newcl DEFAULTcast; @@ -2405,7 +2405,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let insert_before decls lasthyp env = @@ -2421,7 +2421,6 @@ let insert_before decls lasthyp env = (* unsafe *) let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = - let sigma = Sigma.to_evar_map sigma in let body = if dep then Some c else None in let t = match ty with Some t -> t | _ -> typ_of env sigma c in match with_eq with @@ -2435,17 +2434,15 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in - let sigma, eq = Evd.fresh_global env sigma eqdata.eq in - let sigma, refl = Evd.fresh_global env sigma eqdata.refl in + let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [heq,None,eq;id,body,t] lastlhyp env in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in - Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p) + let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in + Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> let newenv = insert_before [id,body,t] lastlhyp env in - let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t x, sigma, p) @@ -2457,7 +2454,7 @@ let letin_tac with_eq id c ty occs = let (id,_,depdecls,lastlhyp,ccl,_) = make_abstraction env sigma ccl abs in (* We keep the original term to match *) let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in - Sigma (tac, sigma, Sigma.refl) + Sigma.here tac sigma end } let letin_pat_tac with_eq id c occs = @@ -3359,7 +3356,7 @@ let abstract_args gl generalize_vars dep id defined f args = hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in - let body, c' = if defined then Some c', typ_of ctxenv Evd.empty c' else None, c' in + let body, c' = if defined then Some c', Retyping.get_type_of ctxenv Evd.empty c' else None, c' in Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls, dep, succ (List.length ctx), vars) else None @@ -3944,7 +3941,7 @@ let check_enough_applied env sigma elim = fun u -> let t,_ = decompose_app (whd_betadeltaiota env sigma u) in isInd t | Some elimc -> - let elimt = typ_of env sigma (fst elimc) in + let elimt = Retyping.get_type_of env sigma (fst elimc) in let scheme = compute_elim_sig ~elimc elimt in match scheme.indref with | None -> @@ -3983,9 +3980,10 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (Tacticals.New.tclTHENLIST [ Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> let b = not with_evars && with_eq != None in - let Sigma (c, sigma, _) = use_bindings env sigma elim b (c0,lbind) t0 in + let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in - mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) + let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in + Sigma (ans, sigma, p +> q) end }; Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable); if is_arg_pure_hyp @@ -4028,8 +4026,8 @@ let induction_gen clear_flag isrec with_evars elim let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in - let t = typ_of env sigma c in let sigma = Sigma.Unsafe.of_evar_map sigma in + let t = typ_of env sigma c in let is_arg_pure_hyp = isVar c && not (mem_named_context (destVar c) (Global.named_context())) && lbind == NoBindings && not with_evars && Option.is_empty eqname @@ -4588,7 +4586,6 @@ let tclABSTRACT name_op tac = let unify ?(state=full_transparent_state) x y = Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> - let sigma = Sigma.to_evar_map sigma in try let core_flags = { (default_unify_flags ()).core_unify_flags with @@ -4600,10 +4597,11 @@ let unify ?(state=full_transparent_state) x y = merge_unify_flags = core_flags; subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } } in + let sigma = Sigma.to_evar_map sigma in let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Sigma.Unsafe.of_pair (Proofview.tclUNIT (), sigma) with e when Errors.noncritical e -> - Sigma.Unsafe.of_pair (Tacticals.New.tclFAIL 0 (str"Not unifiable"), sigma) + Sigma.here (Tacticals.New.tclFAIL 0 (str"Not unifiable")) sigma end } module Simple = struct -- cgit v1.2.3 From a104cd04f3d245bb45e6ff1db8b4ac10c51f4123 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 20:02:23 +0200 Subject: Expliciting the uses of the old Tacmach API in Tactics. --- tactics/tactics.ml | 88 +++++++++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 44 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 866f406230..1040d469ea 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -26,7 +26,7 @@ open Evd open Pfedit open Tacred open Genredexpr -open Tacmach +open Tacmach.New open Logic open Clenv open Refiner @@ -280,7 +280,7 @@ let error_replacing_dependency env sigma id err = errorlabstrm "" (replacing_dependency_msg env sigma id err) let thin l gl = - try thin l gl + try Tacmach.thin l gl with Evarutil.ClearDependencyError (id,err) -> error_clear_dependency (pf_env gl) (project gl) id err @@ -422,7 +422,7 @@ let assert_before_then_gen b naming t tac = Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> - try internal_cut b id t gl + try Tacmach.internal_cut b id t gl with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) @@ -440,7 +440,7 @@ let assert_after_then_gen b naming t tac = Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> - try internal_cut_rev b id t gl + try Tacmach.internal_cut_rev b id t gl with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) @@ -481,7 +481,7 @@ let cofix ido gl = match ido with type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where (id,c,ty) gl = - let redfun' = pf_reduce redfun gl in + let redfun' = Tacmach.pf_reduce redfun gl in match c with | None -> if where == InHypValueOnly then @@ -561,11 +561,11 @@ let bind_red_expr_occurrences occs nbcl redexp = certain hypothesis *) let reduct_in_concl (redfun,sty) gl = - Proofview.V82.of_tactic (convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty) gl + Proofview.V82.of_tactic (convert_concl_no_check (Tacmach.pf_reduce redfun gl (Tacmach.pf_concl gl)) sty) gl let reduct_in_hyp ?(check=false) redfun (id,where) gl = Proofview.V82.of_tactic (convert_hyp ~check - (pf_reduce_decl redfun where (pf_get_hyp gl id) gl)) gl + (pf_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl)) gl let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r @@ -592,13 +592,13 @@ let pf_e_reduce_decl redfun where (id,c,ty) gl = let e_reduct_in_concl (redfun,sty) gl = Proofview.V82.of_tactic - (let sigma, c' = (pf_apply redfun gl (pf_concl gl)) in + (let sigma, c' = (Tacmach.pf_apply redfun gl (Tacmach.pf_concl gl)) in Proofview.Unsafe.tclEVARS sigma <*> convert_concl_no_check c' sty) gl let e_reduct_in_hyp ?(check=false) redfun (id,where) gl = Proofview.V82.of_tactic - (let sigma, decl' = pf_e_reduce_decl redfun where (pf_get_hyp gl id) gl in + (let sigma, decl' = pf_e_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl in Proofview.Unsafe.tclEVARS sigma <*> convert_hyp ~check decl') gl @@ -700,7 +700,7 @@ let change_option occl t = function | None -> change_in_concl occl t let change chg c cls gl = - let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in + let cls = concrete_clause_of (fun () -> Tacmach.pf_ids_of_hyps gl) cls in Proofview.V82.of_tactic (Tacticals.New.tclMAP (function | OnHyp (id,occs,where) -> change_option (bind_change_occurrences occs chg) c (Some (id,where)) @@ -741,12 +741,12 @@ let reduction_clause redexp cl = (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl goal = - let cl = concrete_clause_of (fun () -> pf_ids_of_hyps goal) cl in + let cl = concrete_clause_of (fun () -> Tacmach.pf_ids_of_hyps goal) cl in let redexps = reduction_clause redexp cl in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in let tac = tclMAP (fun (where,redexp) -> e_reduct_option ~check - (Redexpr.reduction_of_red_expr (pf_env goal) redexp) where) redexps in + (Redexpr.reduction_of_red_expr (Tacmach.pf_env goal) redexp) where) redexps in if check then with_check tac goal else tac goal (* Unfolding occurrences of a constant *) @@ -928,7 +928,7 @@ let pf_lookup_hypothesis_as_renamed_gen red h gl = env (project gl) ccl)) | x -> x in - try aux (pf_concl gl) + try aux (Tacmach.pf_concl gl) with Redelimination -> None let is_quantified_hypothesis id g = @@ -965,7 +965,7 @@ let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) let intros_until = intros_until_gen true let intros_until_n = intros_until_n_gen true -let tclCHECKVAR id gl = ignore (pf_get_hyp gl id); tclIDTAC gl +let tclCHECKVAR id gl = ignore (Tacmach.pf_get_hyp gl id); tclIDTAC gl let try_intros_until_id_check id = Tacticals.New.tclORELSE (intros_until_id id) (Proofview.V82.tactic (tclCHECKVAR id)) @@ -1106,7 +1106,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) if not with_evars && occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in - let exact_tac = Proofview.V82.tactic (refine_no_check new_hyp_prf) in + let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in let naming = NamingMustBe (dloc,targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN @@ -1478,7 +1478,7 @@ let solve_remaining_apply_goals = if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in let tac = - (Proofview.V82.tactic (refine_no_check c')) + (Proofview.V82.tactic (Tacmach.refine_no_check c')) in Sigma.Unsafe.of_pair (tac, evd') else Sigma.here (Proofview.tclUNIT ()) sigma @@ -1748,16 +1748,16 @@ let exact_check c = Sigma.Unsafe.of_pair (tac, sigma) end } -let exact_no_check = refine_no_check +let exact_no_check = Tacmach.refine_no_check let vm_cast_no_check c gl = - let concl = pf_concl gl in - refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl + let concl = Tacmach.pf_concl gl in + Tacmach.refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl let exact_proof c gl = - let c,ctx = Constrintern.interp_casted_constr (pf_env gl) (project gl) c (pf_concl gl) - in tclTHEN (tclEVARUNIVCONTEXT ctx) (refine_no_check c) gl + let c,ctx = Constrintern.interp_casted_constr (Tacmach.pf_env gl) (Tacmach.project gl) c (Tacmach.pf_concl gl) + in tclTHEN (tclEVARUNIVCONTEXT ctx) (Tacmach.refine_no_check c) gl let assumption = let rec arec gl only_eq = function @@ -1892,7 +1892,7 @@ let specialize (c,lbind) g = let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in tclEVARS evd, nf_evar evd c else - let clause = pf_apply make_clenv_binding g (c,pf_unsafe_type_of g c) lbind in + let clause = Tacmach.pf_apply make_clenv_binding g (c,Tacmach.pf_unsafe_type_of g c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in @@ -1909,14 +1909,14 @@ let specialize (c,lbind) g = tclEVARS clause.evd, term in match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with - | Var id when Id.List.mem id (pf_ids_of_hyps g) -> + | Var id when Id.List.mem id (Tacmach.pf_ids_of_hyps g) -> tclTHEN tac (tclTHENFIRST - (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (pf_unsafe_type_of g term)) g) + (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (Tacmach.pf_unsafe_type_of g term)) g) (exact_no_check term)) g | _ -> tclTHEN tac (tclTHENLAST - (fun g -> Proofview.V82.of_tactic (cut (pf_unsafe_type_of g term)) g) + (fun g -> Proofview.V82.of_tactic (cut (Tacmach.pf_unsafe_type_of g term)) g) (exact_no_check term)) g (* Keeping only a few hypotheses *) @@ -2562,9 +2562,9 @@ let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) = mkProd_or_LetIn (na,b,t) cl', evd' let generalize_goal gl i ((occs,c,b),na as o) cl = - let t = pf_unsafe_type_of gl c in - let env = pf_env gl in - generalize_goal_gen env (pf_ids_of_hyps gl) i o t cl + let t = Tacmach.pf_unsafe_type_of gl c in + let env = Tacmach.pf_env gl in + generalize_goal_gen env (Tacmach.pf_ids_of_hyps gl) i o t cl let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in @@ -2586,11 +2586,11 @@ let generalize_dep ?(with_let=false) c gl = -> id::tothin | _ -> tothin in - let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in + let cl' = it_mkNamedProd_or_LetIn (Tacmach.pf_concl gl) to_quantify in let body = if with_let then match kind_of_term c with - | Var id -> pi2 (pf_get_hyp gl id) + | Var id -> pi2 (Tacmach.pf_get_hyp gl id) | _ -> None else None in @@ -2607,7 +2607,7 @@ let generalize_dep ?(with_let=false) c gl = let generalize_gen_let lconstr gl = let newcl, evd = List.fold_right_i (generalize_goal gl) 0 lconstr - (pf_concl gl,project gl) + (Tacmach.pf_concl gl,Tacmach.project gl) in tclTHEN (tclEVARS evd) (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> @@ -3221,11 +3221,11 @@ let mk_term_eq env sigma ty t ty' t' = let make_abstract_generalize gl id concl dep ctx body c eqs args refls = let meta = Evarutil.new_meta() in let eqslen = List.length eqs in - let term, typ = mkVar id, pf_get_hyp_typ gl id in + let term, typ = mkVar id, Tacmach.pf_get_hyp_typ gl id in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let abshypeq, abshypt = if dep then - let eq, refl = mk_term_eq (push_rel_context ctx (pf_env gl)) (project gl) (lift 1 c) (mkRel 1) typ term in + let eq, refl = mk_term_eq (push_rel_context ctx (Tacmach.pf_env gl)) (Tacmach.project gl) (lift 1 c) (mkRel 1) typ term in mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in @@ -3286,9 +3286,9 @@ let is_defined_variable env id = match lookup_named id env with | (_, Some _, _) -> true let abstract_args gl generalize_vars dep id defined f args = - let sigma = project gl in - let env = pf_env gl in - let concl = pf_concl gl in + let sigma = Tacmach.project gl in + let env = Tacmach.pf_env gl in + let concl = Tacmach.pf_concl gl in let dep = dep || dependent (mkVar id) concl in let avoid = ref [] in let get_id name = @@ -3306,7 +3306,7 @@ let abstract_args gl generalize_vars dep id defined f args = let rel, c = Reductionops.splay_prod_n env sigma 1 prod in List.hd rel, c in - let argty = pf_unsafe_type_of gl arg in + let argty = Tacmach.pf_unsafe_type_of gl arg in let ty = (* refresh_universes_strict *) ty in let lenctx = List.length ctx in let liftargty = lift lenctx argty in @@ -3347,7 +3347,7 @@ let abstract_args gl generalize_vars dep id defined f args = in if dogen then let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (pf_unsafe_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' + Array.fold_left aux (Tacmach.pf_unsafe_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = @@ -3401,8 +3401,8 @@ let rec compare_upto_variables x y = else compare_constr compare_upto_variables x y let specialize_eqs id gl = - let env = pf_env gl in - let ty = pf_get_hyp_typ gl id in + let env = Tacmach.pf_env gl in + let ty = Tacmach.pf_get_hyp_typ gl id in let evars = ref (project gl) in let unif env evars c1 c2 = compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 @@ -3745,10 +3745,10 @@ let recolle_clenv i params args elimclause gl = let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in (* parameters correspond to first elts of lid. *) let clauses_params = - List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) + List.map_i (fun i id -> mkVar id , Tacmach.pf_get_hyp_typ gl id , lindmv.(i)) 0 params in let clauses_args = - List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(k+i)) + List.map_i (fun i id -> mkVar id , Tacmach.pf_get_hyp_typ gl id , lindmv.(k+i)) 0 args in let clauses = clauses_params@clauses_args in (* iteration of clenv_fchain with all infos we have. *) @@ -3775,7 +3775,7 @@ let induction_tac with_evars params indvars elim gl = let elimc = contract_letin_in_lam_header elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in let elimclause = - pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in + Tacmach.pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in (* one last resolution (useless?) *) @@ -3874,7 +3874,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls gl = - if occur_var (pf_env gl) id (pf_concl gl) && + if occur_var (Tacmach.pf_env gl) id (Tacmach.pf_concl gl) && cls.concl_occs == NoOccurrences then errorlabstrm "" (str "Conclusion must be mentioned: it depends on " ++ pr_id id -- cgit v1.2.3 From f5d8d305c34f9bab21436c765aeeb56a65005dfe Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Oct 2015 22:52:36 +0200 Subject: Renaming Goal.enter field into s_enter. --- proofs/proofview.ml | 12 ++++++------ proofs/proofview.mli | 12 ++++++------ tactics/auto.ml | 2 +- tactics/autorewrite.ml | 2 +- tactics/contradiction.ml | 2 +- tactics/equality.ml | 4 ++-- tactics/evar_tactics.ml | 2 +- tactics/extratactics.ml4 | 2 +- tactics/inv.ml | 2 +- tactics/tactics.ml | 34 +++++++++++++++++----------------- 10 files changed, 37 insertions(+), 37 deletions(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index da9c4da9f9..7edbef57b4 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -974,8 +974,8 @@ module Goal = struct end end - type 'a enter = - { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = + { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin @@ -985,7 +985,7 @@ module Goal = struct try let gl = gmake env sigma goal in let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl sigma in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1002,7 +1002,7 @@ module Goal = struct try let (gl, sigma) = nf_gmake env sigma goal in let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl sigma in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1254,6 +1254,6 @@ module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type 'a enter = 'a Goal.enter = - { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = 'a Goal.s_enter = + { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index b565589eb7..a94610af47 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -454,16 +454,16 @@ module Goal : sig (** Like {!nf_enter}, but does not normalize the goal beforehand. *) val enter : ([ `LZ ] t -> unit tactic) -> unit tactic - type 'a enter = - { enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = + { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing the returned tactic. *) - val s_enter : [ `LZ ] enter -> unit tactic + val s_enter : [ `LZ ] s_enter -> unit tactic (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : [ `NF ] enter -> unit tactic + val nf_s_enter : [ `NF ] s_enter -> unit tactic (** Recover the list of current goals under focus, without evar-normalization *) val goals : [ `LZ ] t tactic list tactic @@ -592,6 +592,6 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - type 'a enter = 'a Goal.enter = - { enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type 'a s_enter = 'a Goal.s_enter = + { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end diff --git a/tactics/auto.ml b/tactics/auto.ml index dc4ac55b23..686d4b471a 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -119,7 +119,7 @@ let exact poly (c,clenv) = let ctx = Evd.evar_universe_context clenv.evd in ctx, c in - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (exact_check c', sigma) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 9892d29541..2ecba176ae 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -94,7 +94,7 @@ type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tac let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in let sigma = Sigma.to_evar_map sigma in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 0253747641..7deb4baf62 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -24,7 +24,7 @@ let mk_absurd_proof t = mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma c in diff --git a/tactics/equality.ml b/tactics/equality.ml index 740a165f8d..fdc77be2f3 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -347,7 +347,7 @@ let type_of_clause cls gl = match cls with | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let isatomic = isProd (whd_zeta hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in @@ -1483,7 +1483,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 43a31b04fc..c9fc01088c 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -70,7 +70,7 @@ let instantiate_tac_by_name id c = let let_evar name typ = let src = (Loc.ghost,Evar_kinds.GoalEvar) in - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let id = match name with | Names.Anonymous -> diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f543a7691a..7b754636f4 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -617,7 +617,7 @@ let out_arg = function | ArgArg x -> x let hResolve id c occ t = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let sigma = Sigma.to_evar_map sigma in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in diff --git a/tactics/inv.ml b/tactics/inv.ml index d3d5c9a9bd..f326e24798 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -432,7 +432,7 @@ let rewrite_equations_tac as_mode othin id neqns names ba = tac let raw_inversion inv_kind id status names = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 1040d469ea..d3cf154c90 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -610,7 +610,7 @@ let e_reduct_option ?(check=false) redfun = function from conversions. *) let e_change_in_concl (redfun,sty) = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in Sigma.Unsafe.of_pair (convert_concl_no_check c sty, sigma) @@ -633,7 +633,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma', (id,Some b',ty') let e_change_in_hyp redfun (id,where) = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let sigma = Sigma.to_evar_map sigma in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in let sigma, c = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in @@ -1247,7 +1247,7 @@ let general_elim with_evars clear_flag (c, lbindc) elim = (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in @@ -1298,7 +1298,7 @@ let find_eliminator c gl = let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE - (Proofview.Goal.s_enter { enter = begin fun gl sigma -> + (Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let sigma, elim = find_eliminator c gl in let tac = (general_elim with_evars clear_flag cx elim) @@ -1469,7 +1469,7 @@ let descend_in_conjunctions avoid tac (err, info) c = (****************************************************) let solve_remaining_apply_goals = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in @@ -1736,7 +1736,7 @@ let new_exact_no_check c = Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in @@ -1952,7 +1952,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl @@ -2371,7 +2371,7 @@ let decode_hyp = function *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let t = match ty with Some t -> t | _ -> typ_of env sigma c in let Sigma ((newcl, eq_tac), sigma, p) = match with_eq with @@ -2447,7 +2447,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in @@ -2458,7 +2458,7 @@ let letin_tac with_eq id c ty occs = end } let letin_pat_tac with_eq id c occs = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let check t = true in @@ -2614,7 +2614,7 @@ let generalize_gen_let lconstr gl = if Option.is_empty b then Some c else None) lconstr)) gl let new_generalize_gen_let lconstr = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Sigma.to_evar_map sigma in @@ -3787,7 +3787,7 @@ let induction_tac with_evars params indvars elim gl = induction applies with the induction hypotheses *) let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in @@ -3954,7 +3954,7 @@ let check_enough_applied env sigma elim = let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in @@ -4241,14 +4241,14 @@ let elim_scheme_type elim t = end let elim_type t = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) end } let case_type t = - Proofview.Goal.s_enter { enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = Tacmach.New.pf_apply build_case_analysis_scheme_default gl ind (Tacticals.New.elimination_sort_of_goal gl) @@ -4506,7 +4506,7 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let current_sign = Global.named_context() and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in @@ -4585,7 +4585,7 @@ let tclABSTRACT name_op tac = abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = - Proofview.Goal.nf_s_enter { enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> try let core_flags = { (default_unify_flags ()).core_unify_flags with -- cgit v1.2.3 From cc42541eeaaec0371940e07efdb009a4ee74e468 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 20 Oct 2015 13:04:45 +0200 Subject: Boxing the Goal.enter primitive into a record type. --- plugins/btauto/refl_btauto.ml | 9 +- plugins/cc/cctac.ml | 38 +++--- plugins/fourier/fourierR.ml | 5 +- plugins/micromega/coq_micromega.ml | 24 ++-- plugins/omega/coq_omega.ml | 29 ++--- plugins/quote/quote.ml | 9 +- plugins/setoid_ring/newring.ml | 9 +- proofs/clenvtac.ml | 10 +- proofs/proofview.ml | 17 ++- proofs/proofview.mli | 9 +- proofs/tactic_debug.ml | 5 +- tactics/auto.ml | 41 ++++--- tactics/autorewrite.ml | 8 +- tactics/class_tactics.ml | 15 +-- tactics/contradiction.ml | 16 +-- tactics/eauto.ml4 | 30 ++--- tactics/elim.ml | 16 +-- tactics/eqdecide.ml | 21 ++-- tactics/equality.ml | 92 +++++++------- tactics/extratactics.ml4 | 44 +++---- tactics/inv.ml | 22 ++-- tactics/leminv.ml | 5 +- tactics/rewrite.ml | 17 +-- tactics/tacinterp.ml | 116 +++++++++--------- tactics/tacticals.ml | 53 ++++---- tactics/tactics.ml | 244 ++++++++++++++++++------------------- tactics/tauto.ml4 | 5 +- toplevel/auto_ind_decl.ml | 40 +++--- 28 files changed, 483 insertions(+), 466 deletions(-) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 57268a9cfa..5a49fc8f45 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -1,3 +1,4 @@ +open Proofview.Notations let contrib_name = "btauto" @@ -216,7 +217,7 @@ module Btauto = struct Tacticals.tclFAIL 0 msg gl let try_unification env = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let t = decomp_term concl in @@ -228,10 +229,10 @@ module Btauto = struct | _ -> let msg = str "Btauto: Internal error" in Tacticals.New.tclFAIL 0 msg - end + end } let tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let bool = Lazy.force Bool.typ in @@ -255,6 +256,6 @@ module Btauto = struct | _ -> let msg = str "Cannot recognize a boolean equality" in Tacticals.New.tclFAIL 0 msg - end + end } end diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 068cb25cf2..35178aa1e4 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -22,6 +22,7 @@ open Ccproof open Pp open Errors open Util +open Proofview.Notations let reference dir s = lazy (Coqlib.gen_reference "CC" dir s) @@ -254,13 +255,13 @@ let new_app_global f args k = let new_refine c = Proofview.V82.tactic (refine c) let assert_before n c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let evm, _ = Tacmach.New.pf_apply type_of gl c in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) - end + end } let rec proof_tac p : unit Proofview.tactic = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with @@ -325,10 +326,10 @@ let rec proof_tac p : unit Proofview.tactic = app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end + end } let refute_tac c t1 t2 p = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype = Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt1)) gl @@ -338,14 +339,14 @@ let refute_tac c t1 t2 p = let false_t=mkApp (c,[|mkVar hid|]) in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] - end + end } let refine_exact_check c gl = let evm, _ = pf_apply type_of gl c in Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl let convert_to_goal_tac c t1 t2 p = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort = Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt2)) gl @@ -357,20 +358,20 @@ let convert_to_goal_tac c t1 t2 p = let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] - end + end } let convert_to_hyp_tac c1 t1 c2 t2 p = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let tt2=constr_of_term t2 in let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in let false_t=mkApp (c2,[|mkVar h|]) in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] - end + end } let discriminate_tac (cstr,u as cstru) p = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let intype = Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls t1)) gl @@ -399,7 +400,7 @@ let discriminate_tac (cstr,u as cstru) p = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]) - end + end } (* wrap everything *) @@ -411,7 +412,7 @@ let build_term_to_complete uf meta pac = applistc (mkConstructU cinfo.ci_constr) all_args let cc_tactic depth additionnal_terms = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.logic_module_name; let _ = debug (Pp.str "Reading subgoal ...") in let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in @@ -462,7 +463,7 @@ let cc_tactic depth additionnal_terms = convert_to_goal_tac id ta tb p | HeqnH (ida,idb) -> convert_to_hyp_tac ida ta idb tb p - end + end } let cc_fail gls = errorlabstrm "Congruence" (Pp.str "congruence failed.") @@ -485,8 +486,7 @@ let congruence_tac depth l = let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> - Proofview.Goal.enter begin - fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in @@ -494,10 +494,10 @@ let mk_eq f c1 c2 k = let evm, _ = type_of (pf_env gl) evm term in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k term) - end) + end }) let f_equal = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) @@ -523,4 +523,4 @@ let f_equal = | Type_errors.TypeError _ -> Proofview.tclUNIT () | e -> Proofview.tclZERO ~info e end - end + end } diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 7a56cd6657..e5c9b27075 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -19,6 +19,7 @@ open Globnames open Tacmach open Fourier open Contradiction +open Proofview.Notations (****************************************************************************** Opérations sur les combinaisons linéaires affines. @@ -462,7 +463,7 @@ exception GoalDone (* Résolution d'inéquations linéaires dans R *) let rec fourier () = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; let goal = strip_outer_cast concl in @@ -622,7 +623,7 @@ let rec fourier () = (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) !tac (* ((tclABSTRACT None !tac) gl) *) - end + end } ;; (* diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index ef1169342f..a0e61623c7 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -20,6 +20,7 @@ open Pp open Mutils open Proofview open Goptions +open Proofview.Notations (** * Debug flag @@ -1444,8 +1445,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap (spec.typ) env in (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter - begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1462,7 +1462,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* Tactics.new_generalize env ; Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids) ] - end + end } (** @@ -1707,9 +1707,7 @@ let micromega_gen (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec prover = - Proofview.Goal.nf_enter - begin - fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in try @@ -1735,7 +1733,7 @@ let micromega_gen ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end + end } let micromega_gen parse_arith (negate:'cst atom -> 'cst mc_cnf) @@ -1756,9 +1754,7 @@ let micromega_order_changer cert env ff = let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) env in - Proofview.Goal.nf_enter - begin - fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -1774,7 +1770,7 @@ let micromega_order_changer cert env ff = Tactics.new_generalize env ; Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids) ] - end + end } let micromega_genr prover = @@ -1790,9 +1786,7 @@ let micromega_genr prover = proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in - Proofview.Goal.nf_enter - begin - fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in try @@ -1822,7 +1816,7 @@ let micromega_genr prover = ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end + end } let micromega_genr prover = (micromega_genr prover) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index aac9a7d315..976ab949c1 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -27,6 +27,7 @@ open Globnames open Nametab open Contradiction open Misctypes +open Proofview.Notations module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -34,9 +35,9 @@ open OmegaSolver (* Added by JCF, 09/03/98 *) let elim_id id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> simplest_elim (Tacmach.New.pf_global id gl) - end + end } let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl let timing timer_name f arg = f arg @@ -1416,7 +1417,7 @@ let reintroduce id = open Proofview.Notations let coq_omega = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in let destructure_omega = Tacmach.New.of_old destructure_omega gl in @@ -1464,12 +1465,12 @@ let coq_omega = Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path) with NO_CONTRADICTION -> Tacticals.New.tclZEROMSG (Pp.str"Omega can't solve this system") end - end + end } let coq_omega = coq_omega let nat_inject = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in let rec explore p t : unit Proofview.tactic = try match destructurate_term t with @@ -1603,7 +1604,7 @@ let nat_inject = in let hyps_types = Tacmach.New.pf_hyps_types gl in loop (List.rev hyps_types) - end + end } let dec_binop = function | Zne -> coq_dec_Zne @@ -1673,22 +1674,22 @@ let onClearedName id tac = (* so renaming may be necessary *) Tacticals.New.tclTHEN (Proofview.V82.tactic (tclTRY (clear [id]))) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.nf_enter { enter = begin fun gl -> let id = Tacmach.New.of_old (fresh_id [] id) gl in Tacticals.New.tclTHEN (introduction id) (tac id) - end) + end }) let onClearedName2 id tac = Tacticals.New.tclTHEN (Proofview.V82.tactic (tclTRY (clear [id]))) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.nf_enter { enter = begin fun gl -> let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] - end) + end }) let destructure_hyps = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let decidability = Tacmach.New.of_old decidability gl in let pf_nf = Tacmach.New.of_old pf_nf gl in @@ -1828,10 +1829,10 @@ let destructure_hyps = in let hyps = Proofview.Goal.hyps gl in loop hyps - end + end } let destructure_goal = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let decidability = Tacmach.New.of_old decidability gl in let rec loop t = @@ -1855,7 +1856,7 @@ let destructure_goal = Tacticals.New.tclTHEN goal_tac destructure_hyps in (loop concl) - end + end } let destructure_goal = destructure_goal diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 2a2ef30fb1..8d60b8ba2a 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -109,6 +109,7 @@ open Pattern open Patternops open Constr_matching open Tacmach +open Proofview.Notations (*i*) (*s First, we need to access some Coq constants @@ -446,7 +447,7 @@ let quote_terms ivs lc = yet. *) let quote f lid = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let f = Tacmach.New.pf_global f gl in let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in let ivs = compute_ivs f cl gl in @@ -459,10 +460,10 @@ let quote f lid = match ivs.variable_lhs with | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast - end + end } let gen_quote cont c f lid = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let f = Tacmach.New.pf_global f gl in let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in let ivs = compute_ivs f cl gl in @@ -474,7 +475,7 @@ let gen_quote cont c f lid = match ivs.variable_lhs with | None -> cont (mkApp (f, [| p |])) | Some _ -> cont (mkApp (f, [| vm; p |])) - end + end } (*i diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 942ca15a5f..8ff4230e89 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -31,6 +31,7 @@ open Decl_kinds open Entries open Misctypes open Newring_ast +open Proofview.Notations (****************************************************************************) (* controlled reduction *) @@ -747,7 +748,7 @@ let ltac_ring_structure e = lemma1;lemma2;pretac;posttac] let ring_lookup (f:glob_tactic_expr) lH rl t = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in try (* find_ring_strucure can raise an exception *) @@ -759,7 +760,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t = let ring = ltac_ring_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end + end } (***********************************************************************) @@ -1019,7 +1020,7 @@ let ltac_field_structure e = field_simpl_eq_in_ok;cond_ok;pretac;posttac] let field_lookup (f:glob_tactic_expr) lH rl t = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in try @@ -1031,4 +1032,4 @@ let field_lookup (f:glob_tactic_expr) lH rl t = let field = ltac_field_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - end + end } diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index f54d4c4470..65bd325362 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -16,7 +16,7 @@ open Logic open Reduction open Tacmach open Clenv - +open Proofview.Notations (* This function put casts around metavariables whose type could not be * infered by the refiner, that is head of applications, predicates and @@ -83,10 +83,10 @@ open Unification let dft = default_unify_flags let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let clenv gl = clenv_unique_resolver ~flags clenv gl in clenv_refine with_evars ~with_classes (Tacmach.New.of_old clenv (Proofview.Goal.assume gl)) - end + end } (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en particulier ne semblent pas vérifier que des instances différentes @@ -118,7 +118,7 @@ let fail_quick_unif_flags = { (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) let unify ?(flags=fail_quick_unif_flags) m = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let n = Tacmach.New.pf_nf_concl gl in let evd = clear_metas (Proofview.Goal.sigma gl) in @@ -126,4 +126,4 @@ let unify ?(flags=fail_quick_unif_flags) m = let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' with e when Errors.noncritical e -> Proofview.tclZERO e - end + end } diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 7edbef57b4..b8a58daeb2 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -915,6 +915,9 @@ module Goal = struct self : Evar.t ; (* for compatibility with old-style definitions *) } + type 'a enter = + { enter : 'a t -> unit tactic } + let assume (gl : 'a t) = (gl :> [ `NF ] t) let env { env=env } = env @@ -944,7 +947,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl)) + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) with e when catchable_exception e -> let (e, info) = Errors.push e in tclZERO ~info e @@ -962,7 +965,7 @@ module Goal = struct gmake_with info env sigma goal let enter f = - let f gl = InfoL.tag (Info.DBranch) (f gl) in + let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in InfoL.tag (Info.Dispatch) begin iter_goal begin fun goal -> Env.get >>= fun env -> @@ -1054,7 +1057,7 @@ struct let (pr_constrv,pr_constr) = Hook.make ~default:(fun _env _sigma _c -> Pp.str"") () - let refine ?(unsafe = true) f = Goal.enter begin fun gl -> + let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl -> let sigma = Goal.sigma gl in let env = Goal.env gl in let concl = Goal.concl gl in @@ -1091,7 +1094,7 @@ struct let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> Pv.set { solution = sigma; comb; } - end + end } (** Useful definitions *) @@ -1103,7 +1106,7 @@ struct in evd , j'.Environ.uj_val - let refine_casted ?unsafe f = Goal.enter begin fun gl -> + let refine_casted ?unsafe f = Goal.enter { Goal.enter = begin fun gl -> let concl = Goal.concl gl in let env = Goal.env gl in let f = { run = fun h -> @@ -1112,7 +1115,7 @@ struct Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) } in refine ?unsafe f - end + end } end @@ -1254,6 +1257,8 @@ module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + type 'a enter = 'a Goal.enter = + { enter : 'a Goal.t -> unit tactic } type 'a s_enter = 'a Goal.s_enter = { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index a94610af47..1616782e54 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -445,14 +445,17 @@ module Goal : sig normalised. *) val raw_concl : 'a t -> Term.constr + type 'a enter = + { enter : 'a t -> unit tactic } + (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) - val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic + val nf_enter : [ `NF ] enter -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ] t -> unit tactic) -> unit tactic + val enter : [ `LZ ] enter -> unit tactic type 'a s_enter = { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } @@ -592,6 +595,8 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic + type 'a enter = 'a Goal.enter = + { enter : 'a Goal.t -> unit tactic } type 'a s_enter = 'a Goal.s_enter = { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } end diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 6d6215c521..fb23a28feb 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -12,6 +12,7 @@ open Pp open Tacexpr open Termops open Nameops +open Proofview.Notations let (prtac, tactic_printer) = Hook.make () let (prmatchpatt, match_pattern_printer) = Hook.make () @@ -47,10 +48,10 @@ let db_pr_goal gl = str" " ++ pc) ++ fnl () let db_pr_goal = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end + end } (* Prints the commands *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 686d4b471a..4e4eafe4e5 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -96,11 +96,11 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = in clenv, c let unify_resolve poly flags ((c : raw_hint), clenv) = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in Clenvtac.clenv_refine false clenv - end + end } let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h @@ -151,11 +151,12 @@ let conclPattern concl pat tac = with Constr_matching.PatternMatchingFailure -> Tacticals.New.tclZEROMSG (str "conclPattern") in - Proofview.Goal.enter (fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in constr_bindings env sigma >>= fun constr_bindings -> - Hook.get forward_interp_tactic constr_bindings tac) + Hook.get forward_interp_tactic constr_bindings tac + end } (***********************************************************) (** A debugging / verbosity framework for trivial and auto *) @@ -320,7 +321,7 @@ let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = Tacticals.New.tclTHEN (dbg_intro dbg) - ( Proofview.Goal.enter begin fun gl -> + ( Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in @@ -329,15 +330,15 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) - end) + end }) in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE (trivial_resolve dbg mod_delta db_list local_db concl))) - end + end } and my_find_search_nodelta db_list local_db hdc concl = List.map (fun hint -> (None,hint)) @@ -414,7 +415,7 @@ and trivial_resolve dbg mod_delta db_list local_db cl = "nocore" amongst the databases. *) let trivial ?(debug=Off) lems dbnames = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let db_list = make_db_list dbnames in @@ -422,10 +423,10 @@ let trivial ?(debug=Off) lems dbnames = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) - end + end } let full_trivial ?(debug=Off) lems = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let db_list = current_pure_db () in @@ -433,7 +434,7 @@ let full_trivial ?(debug=Off) lems = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (trivial_fail_db d false db_list hints) - end + end } let gen_trivial ?(debug=Off) lems = function | None -> full_trivial ~debug lems @@ -466,10 +467,10 @@ let extend_local_db decl db gl = let intro_register dbg kont db = Tacticals.New.tclTHEN (dbg_intro dbg) - (Proofview.Goal.enter begin fun gl -> + (Proofview.Goal.enter { enter = begin fun gl -> let extend_local_db decl db = extend_local_db decl db gl in Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db)) - end) + end }) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) @@ -482,14 +483,14 @@ let search d n mod_delta db_list local_db = if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) - ( Proofview.Goal.enter begin fun gl -> + ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) (possible_resolve d mod_delta db_list local_db concl)) - end)) + end })) end [] in search d n local_db @@ -497,7 +498,7 @@ let search d n mod_delta db_list local_db = let default_search_depth = ref 5 let delta_auto debug mod_delta n lems dbnames = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let db_list = make_db_list dbnames in @@ -505,7 +506,7 @@ let delta_auto debug mod_delta n lems dbnames = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) - end + end } let delta_auto = if Flags.profile then @@ -520,7 +521,7 @@ let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] let delta_full_auto ?(debug=Off) mod_delta n lems = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let db_list = current_pure_db () in @@ -528,7 +529,7 @@ let delta_full_auto ?(debug=Off) mod_delta n lems = let hints = make_local_hint_db env sigma false lems in tclTRY_dbg d (search d n mod_delta db_list hints) - end + end } let full_auto ?(debug=Off) n = delta_full_auto ~debug false n let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 2ecba176ae..43a8d7f06a 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -123,7 +123,7 @@ let autorewrite ?(conds=Naive) tac_main lbas = (Proofview.tclUNIT()) lbas)) let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> (* let's check at once if id exists (to raise the appropriate error) *) let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in let general_rewrite_in id = @@ -166,7 +166,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) idl - end + end } let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] @@ -191,10 +191,10 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = | None -> (* try to rewrite in all hypothesis (except maybe the rewritten one) *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids - end) + end }) let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT()) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 83b1202b72..9c22beba27 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -140,17 +140,17 @@ let rec eq_constr_mod_evars x y = | _, _ -> compare_constr eq_constr_mod_evars x y let progress_evars t = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let check = - Proofview.Goal.nf_enter begin fun gl' -> + Proofview.Goal.nf_enter { enter = begin fun gl' -> let newconcl = Proofview.Goal.concl gl' in if eq_constr_mod_evars concl newconcl then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)") else Proofview.tclUNIT () - end + end } in t <*> check - end + end } let e_give_exact flags poly (c,clenv) gl = @@ -188,10 +188,11 @@ let clenv_of_prods poly nprods (c, clenv) gl = else None let with_prods nprods poly (c, clenv) f = - Proofview.Goal.nf_enter (fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> match clenv_of_prods poly nprods (c, clenv) gl with | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some clenv' -> f (c, clenv') gl) + | Some clenv' -> f (c, clenv') gl + end } (** Hack to properly solve dependent evars that are typeclasses *) @@ -901,5 +902,5 @@ let autoapply c i gl = (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - let tac = unify_e_resolve false flags ((c,cty,Univ.ContextSet.empty),ce) in + let tac = { enter = fun gl -> unify_e_resolve false flags ((c,cty,Univ.ContextSet.empty),ce) gl } in Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 7deb4baf62..34886d74d1 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -48,13 +48,13 @@ let filter_hyp f tac = | [] -> Proofview.tclZERO Not_found | (id,_,t)::rest when f t -> tac id | _::rest -> seek rest in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in seek hyps - end + end } let contradiction_context = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let rec seek_neg l = match l with @@ -67,11 +67,11 @@ let contradiction_context = else match kind_of_term typ with | Prod (na,t,u) when is_empty_type u -> (Proofview.tclORELSE - (Proofview.Goal.enter begin fun gl -> + (Proofview.Goal.enter { enter = begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in filter_hyp (fun typ -> is_conv_leq typ t) (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) - end) + end }) begin function (e, info) -> match e with | Not_found -> seek_neg rest | e -> Proofview.tclZERO ~info e @@ -80,7 +80,7 @@ let contradiction_context = in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in seek_neg hyps - end + end } let is_negation_of env sigma typ t = match kind_of_term (whd_betadeltaiota env sigma t) with @@ -90,7 +90,7 @@ let is_negation_of env sigma typ t = | _ -> false let contradiction_term (c,lbind as cl) = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -113,7 +113,7 @@ let contradiction_term (c,lbind as cl) = | Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.") | e -> Proofview.tclZERO ~info e end - end + end } let contradiction = function | None -> Tacticals.New.tclTHEN intros contradiction_context diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index d0fd4b0780..08502e0ccb 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -28,26 +28,27 @@ open Misctypes open Locus open Locusops open Hints +open Proofview.Notations DECLARE PLUGIN "eauto" let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t2 = Tacmach.New.pf_concl gl in if occur_existential t1 || occur_existential t2 then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) else exact_check c - end + end } let assumption id = e_give_exact (mkVar id) let e_assumption = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) - end + end } TACTIC EXTEND eassumption | [ "eassumption" ] -> [ e_assumption ] @@ -58,10 +59,10 @@ TACTIC EXTEND eexact END let registered_e_assumption = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) (Tacmach.New.pf_ids_of_hyps gl)) - end + end } (************************************************************************) (* PROLOG tactic *) @@ -126,15 +127,14 @@ open Unification let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) let unify_e_resolve poly flags (c,clenv) = - Proofview.Goal.nf_enter begin - fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in Proofview.V82.tactic (fun gls -> let clenv' = clenv_unique_resolver ~flags clenv' gls in tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) - end + end } let hintmap_of hdc concl = match hdc with @@ -152,19 +152,19 @@ let e_exact poly flags (c,clenv) = in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) let rec e_trivial_fail_db db_list local_db = - let next = Proofview.Goal.nf_enter begin fun gl -> + let next = Proofview.Goal.nf_enter { enter = begin fun gl -> let d = Tacmach.New.pf_last_hyp gl in let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) d in e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) hintl local_db) - end in - Proofview.Goal.enter begin fun gl -> + end } in + Proofview.Goal.enter { enter = begin fun gl -> let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) - end + end } and e_my_find_search db_list local_db hdc concl = let hint_of_db = hintmap_of hdc concl in @@ -567,7 +567,7 @@ let unfold_head env (ids, csts) c = in aux c let autounfold_one db cl = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let st = @@ -586,7 +586,7 @@ let autounfold_one db cl = | Some hyp -> change_in_hyp None (make_change_arg c') hyp | None -> convert_concl_no_check c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") - end + end } (* Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *) (* (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *) diff --git a/tactics/elim.ml b/tactics/elim.ml index 4841d2c252..27e96637d9 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -84,7 +84,7 @@ let tmphyp_name = Id.of_string "_TmpHyp" let up_to_delta = ref false (* true *) let general_decompose recognizer c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let typc = type_of c in tclTHENS (cut typc) @@ -93,7 +93,7 @@ let general_decompose recognizer c = (ifOnHyp recognizer (general_decompose_aux recognizer) (fun id -> Proofview.V82.tactic (clear [id])))); Proofview.V82.tactic (exact_no_check c) ] - end + end } let head_in indl t gl = let env = Proofview.Goal.env gl in @@ -107,10 +107,10 @@ let head_in indl t gl = with Not_found -> false let decompose_these c l = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in general_decompose (fun (_,t) -> head_in indl t gl) c - end + end } let decompose_and c = general_decompose @@ -138,7 +138,7 @@ let induction_trailer abs_i abs_j bargs = (tclDO (abs_j - abs_i) intro) (onLastHypId (fun id -> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let idty = pf_unsafe_type_of gl (mkVar id) in let fvty = global_vars (pf_env gl) idty in let possible_bring_hyps = @@ -156,11 +156,11 @@ let induction_trailer abs_i abs_j bargs = (tclTHENLIST [bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids)); simple_elimination (mkVar id)]) - end + end } )) let double_ind h1 h2 = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let abs_i = of_old (depth_of_quantified_hypothesis true h1) gl in let abs_j = of_old (depth_of_quantified_hypothesis true h2) gl in let abs = @@ -173,7 +173,7 @@ let double_ind h1 h2 = (fun id -> elimination_then (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) - end + end } let h_double_induction = double_ind diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 4fb76bb828..74e5e036a2 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -27,6 +27,7 @@ open Constr_matching open Hipattern open Tacmach.New open Coqlib +open Proofview.Notations (* This file containts the implementation of the tactics ``Decide Equality'' and ``Compare''. They can be used to decide the @@ -146,7 +147,7 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with intros_reflexivity; ] | a1 :: largs, a2 :: rargs -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let rectype = pf_unsafe_type_of gl a1 in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in @@ -154,13 +155,13 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] else [diseqCase hyps eqonleft;eqCase tac;default_auto] in (tclTHENS (elim_type decide) subtacs) - end + end } | _ -> invalid_arg "List.fold_right2" let solveEqBranch rectype = Proofview.tclORELSE begin - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) -> let (mib,mip) = Global.lookup_inductive rectype in @@ -169,7 +170,7 @@ let solveEqBranch rectype = let rargs = getargs rhs and largs = getargs lhs in solveArg [] eqonleft op largs rargs - end + end } end begin function (e, info) -> match e with | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") @@ -185,7 +186,7 @@ let hd_app c = match kind_of_term c with let decideGralEquality = Proofview.tclORELSE begin - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> let headtyp = hd_app (pf_compute gl typ) in @@ -196,7 +197,7 @@ let decideGralEquality = (tclTHEN (mkBranches c1 c2) (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) - end + end } end begin function (e, info) -> match e with | PatternMatchingFailure -> @@ -207,20 +208,20 @@ let decideGralEquality = let decideEqualityGoal = tclTHEN intros decideGralEquality let decideEquality rectype = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let decide = mkGenDecideEqGoal rectype gl in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) - end + end } (* The tactic Compare *) let compare c1 c2 = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let rectype = pf_unsafe_type_of gl c1 in let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in (tclTHENS (cut decide) [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); decideEquality rectype]) - end + end } diff --git a/tactics/equality.ml b/tactics/equality.ml index fdc77be2f3..e8f88fca10 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -207,10 +207,10 @@ let rewrite_conv_closed_unif_flags = { } let rewrite_elim with_evars frzevars cls c e = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in general_elim_clause with_evars flags cls c e - end + end } (* Ad hoc asymmetric general_elim_clause *) let general_elim_clause with_evars frzevars cls rew elim = @@ -245,7 +245,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = (general_elim_clause with_evars frzevars cls c elim)) tac in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let instantiate_lemma concl = if not all then instantiate_lemma gl c t l l2r concl else instantiate_lemma_all frzevars gl c t l l2r concl @@ -257,7 +257,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) else tclMAP try_clause cs - end + end } (* The next function decides in particular whether to try a regular rewrite or a generalized rewrite. @@ -383,7 +383,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac if occs != AllOccurrences then ( rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in @@ -411,7 +411,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac | None -> Proofview.tclZERO ~info e (* error "The provided term does not end with an equality or a declared rewrite relation." *) end - end + end } let general_rewrite_ebindings = general_rewrite_ebindings_clause None @@ -473,9 +473,9 @@ let general_rewrite_clause l2r with_evars ?tac c cl = let ids_of_hyps = pf_ids_of_hyps gl in Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> do_hyps_atleastonce (ids gl) - end + end } in if cl.concl_occs == NoOccurrences then do_hyps else tclIFTHENTRYELSEMUST @@ -483,7 +483,7 @@ let general_rewrite_clause l2r with_evars ?tac c cl = do_hyps let apply_special_clear_request clear_flag f = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in try @@ -491,17 +491,17 @@ let apply_special_clear_request clear_flag f = apply_clear_request clear_flag (use_clear_hyp_by_default ()) c with e when catchable_exception e -> tclIDTAC - end + end } let general_multi_rewrite with_evars l cl tac = let do1 l2r f = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma - end + end } in let rec doN l2r c = function | Precisely n when n <= 0 -> Proofview.tclUNIT () @@ -564,7 +564,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = | None -> Proofview.tclUNIT () | Some tac -> tclCOMPLETE tac in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in @@ -590,7 +590,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = tclTHEN (apply sym) assumption; try_prove_eq ]))) - end + end } let replace c1 c2 = replace_using_leibniz onConcl c2 c1 false false None @@ -873,7 +873,7 @@ let rec build_discriminator env sigma dirn c sort = function *) let gen_absurdity id = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in let hyp_typ = pf_nf_evar gl hyp_typ in if is_empty_type hyp_typ @@ -881,7 +881,7 @@ let gen_absurdity id = simplest_elim (mkVar id) else tclZEROMSG (str "Not the negation of an equality.") - end + end } (* Precondition: eq is leibniz equality @@ -937,7 +937,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in match find_positions env sigma t1 t2 with @@ -946,10 +946,10 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = | Inl (cpath, (_,dirn), _) -> let sort = pf_apply get_type_of gl concl in discr_positions env sigma u eq_clause cpath dirn sort - end + end } let onEquality with_evars tac (c,lbindc) = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in @@ -961,10 +961,10 @@ let onEquality with_evars tac (c,lbindc) = tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') - end + end } let onNegatedEquality with_evars tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -975,7 +975,7 @@ let onNegatedEquality with_evars tac = onEquality with_evars tac (mkVar id,NoBindings))) | _ -> tclZEROMSG (str "Not a negated primitive equality.") - end + end } let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq @@ -1244,7 +1244,7 @@ let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let inject_if_homogenous_dependent_pair ty = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> try let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in (* fetch the informations of the pair *) @@ -1282,7 +1282,7 @@ let inject_if_homogenous_dependent_pair ty = ])] with Exit -> Proofview.tclUNIT () - end + end } (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type @@ -1374,7 +1374,7 @@ let injConcl = injClause None false None let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id))) let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let sort = pf_apply get_type_of gl (Proofview.Goal.concl gl) in let sigma = clause.evd in let env = Proofview.Goal.env gl in @@ -1386,7 +1386,7 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = | Inr posns -> inject_at_positions env sigma true u clause posns (ntac (clenv_value clause)) - end + end } let dEqThen with_evars ntac = function | None -> onNegatedEquality with_evars (decompEqThen (ntac None)) @@ -1397,10 +1397,10 @@ let dEq with_evars = (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decompe_eq tac data cl = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let cl = pf_apply make_clenv_binding gl cl NoBindings in decompEqThen (fun _ -> tac) data cl - end + end } let _ = declare_intro_decomp_eq intro_decompe_eq @@ -1500,7 +1500,7 @@ let cutSubstInConcl l2r eqn = end } let cutSubstInHyp l2r eqn id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in @@ -1512,7 +1512,7 @@ let cutSubstInHyp l2r eqn id = (replace_core (onHyp id) l2r eqn) ]) (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) - end + end } let try_rewrite tac = Proofview.tclORELSE tac begin function (e, info) -> match e with @@ -1534,11 +1534,11 @@ let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); Proofview.V82.tactic (exact_no_check c)] - end + end } let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls) let rewriteInHyp l2r c id = rewriteClause l2r c (Some id) @@ -1564,7 +1564,7 @@ user = raise user error specific to rewrite (* Substitutions tactics (JCF) *) let unfold_body x = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let (_, xval, _) = Context.lookup_named x hyps in @@ -1581,7 +1581,7 @@ let unfold_body x = let reductc = Proofview.V82.tactic (fun gl -> reduct_in_concl (rfun, DEFAULTcast) gl) in tclTHENLIST [tclMAP reducth hl; reductc] end - end + end } let restrict_to_eq_and_identity eq = (* compatibility *) if not (is_global glob_eq eq) && @@ -1604,7 +1604,7 @@ let is_eq_x gl x (id,_,c) = erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in @@ -1630,13 +1630,13 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = else [Proofview.tclUNIT ()]) @ [tclTRY (clear [x; hyp])]) - end + end } (* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *) let subst_one_var dep_proof_ok x = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let (_,xval,_) = pf_get_hyp x gl in (* If x has a body, simply replace x with body and clear x *) @@ -1655,7 +1655,7 @@ let subst_one_var dep_proof_ok x = str".") with FoundHyp res -> res in subst_one dep_proof_ok x res - end + end } let subst_gen dep_proof_ok ids = tclTHEN Proofview.V82.nf_evar_goals (tclMAP (subst_one_var dep_proof_ok) ids) @@ -1715,7 +1715,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = (* Second step: treat equations *) let process hyp = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let find_eq_data_decompose = find_eq_data_decompose gl in let (_,_,c) = pf_get_hyp hyp gl in @@ -1729,19 +1729,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () - end + end } in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let ids = find_equations gl in tclMAP process ids - end + end } else (* Old implementation, not able to manage configurations like a=b, a=t, or situations like "a = S b, b = S a", or also accidentally unfolding let-ins *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try @@ -1758,7 +1758,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let ids = List.map_filter test hyps in let ids = List.uniquize ids in subst_gen flags.rewrite_dependent_proof ids - end + end } (* Rewrite the first assumption for which a condition holds and gives the direction of the rewrite *) @@ -1794,10 +1794,10 @@ let rewrite_assumption_cond cond_eq_term cl = with | Failure _ | UserError _ -> arec rest gl end in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps gl in arec hyps gl - end + end } (* Generalize "subst x" to substitution of subterm appearing as an equation in the context, but not clearing the hypothesis *) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 7b754636f4..fa13234a63 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -22,6 +22,7 @@ open Evd open Equality open Misctypes open Sigma.Notations +open Proofview.Notations DECLARE PLUGIN "extratactics" @@ -346,7 +347,7 @@ END (* Refine *) let refine_tac {Glob_term.closure=closure;term=term} = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = Pretyping.all_no_fail_flags in @@ -362,7 +363,7 @@ let refine_tac {Glob_term.closure=closure;term=term} = Sigma.Unsafe.of_pair (c, sigma) end } in Tactics.New.refine ~unsafe:false update - end + end } TACTIC EXTEND refine [ "refine" uconstr(c) ] -> [ refine_tac c ] @@ -662,7 +663,7 @@ END *) let hget_evar n = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in let evl = evar_list concl in @@ -672,7 +673,7 @@ let hget_evar n = let ev = List.nth evl (n-1) in let ev_type = existential_type sigma ev in change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) - end + end } TACTIC EXTEND hget_evar | [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ] @@ -691,12 +692,12 @@ END exception Found of unit Proofview.tactic let rewrite_except h = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) hyps - end + end } let refl_equal = @@ -710,27 +711,27 @@ let refl_equal = should be replaced by a call to the tactic but I don't know how to call it before it is defined. *) let mkCaseEq a : unit Proofview.tactic = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in Tacticals.New.tclTHENLIST [Proofview.V82.tactic (Tactics.Simple.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in change_concl (snd (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl)) - end; + end }; simplest_case a] - end + end } let case_eq_intros_rewrite x = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let n = nb_prod (Proofview.Goal.concl gl) in (* Pp.msgnl (Printer.pr_lconstr x); *) Tacticals.New.tclTHENLIST [ mkCaseEq x; - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let hyps = Tacmach.New.pf_ids_of_hyps gl in let n' = nb_prod concl in @@ -739,9 +740,9 @@ let case_eq_intros_rewrite x = Tacticals.New.tclDO (n'-n-1) intro; introduction h; rewrite_except h] - end + end } ] - end + end } let rec find_a_destructable_match t = match kind_of_term t with @@ -761,15 +762,15 @@ let destauto t = with Found tac -> tac let destauto_in id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) (* Pp.msgnl (Printer.pr_lconstr (ctype)); *) destauto ctype - end + end } TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.nf_enter (fun gl -> destauto (Proofview.Goal.concl gl)) ] +| [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] END @@ -777,10 +778,11 @@ END (* ********************************************************************* *) let eq_constr x y = - Proofview.Goal.enter (fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let evd = Proofview.Goal.sigma gl in if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () - else Tacticals.New.tclFAIL 0 (str "Not equal")) + else Tacticals.New.tclFAIL 0 (str "Not equal") + end } TACTIC EXTEND constr_eq | [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] @@ -981,14 +983,14 @@ TACTIC EXTEND guard END let decompose l c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let to_ind c = if isInd c then Univ.out_punivs (destInd c) else error "not an inductive type" in let l = List.map to_ind l in Elim.h_decompose l c - end + end } TACTIC EXTEND decompose | [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] diff --git a/tactics/inv.ml b/tactics/inv.ml index f326e24798..a9fa52e928 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -270,14 +270,14 @@ Nota: with Inversion_clear, only four useless hypotheses let generalizeRewriteIntros as_mode tac depids id = Proofview.tclENV >>= fun env -> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let dids = dependent_hyps env id depids gl in let reintros = if as_mode then intros_replacing else intros_possibly_replacing in (tclTHENLIST [bring_hyps dids; tac; (* may actually fail to replace if dependent in a previous eq *) reintros (ids_of_named_context dids)]) - end + end } let error_too_many_names pats = let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in @@ -339,7 +339,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in let substHypIfVariable tac id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in @@ -347,7 +347,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 | _ -> tac id - end + end } in let deq_trailer id clear_flag _ neqns = assert (clear_flag == None); @@ -374,7 +374,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = id let nLastDecls i tac = - Proofview.Goal.nf_enter (fun gl -> tac (nLastDecls gl i)) + Proofview.Goal.nf_enter { enter = begin fun gl -> tac (nLastDecls gl i) end } (* Introduction of the equations on arguments othin: discriminates Simple Inversion, Inversion and Inversion_clear @@ -382,7 +382,7 @@ let nLastDecls i tac = Some thin: the equations are rewritten, and cleared if thin is true *) let rewrite_equations as_mode othin neqns names ba = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in let avoid = if as_mode then List.map pi1 nodepids else [] in @@ -415,7 +415,7 @@ let rewrite_equations as_mode othin neqns names ba = [tclDO neqns intro; bring_hyps nodepids; clear (ids_of_named_context nodepids)]) - end + end } let interp_inversion_kind = function | SimpleInversion -> None @@ -514,12 +514,12 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) * back to their places in the hyp-list. *) let invIn k names ids id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let concl = Proofview.Goal.concl gl in let nb_prod_init = nb_prod concl in let intros_replace_ids = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in let nb_of_new_hyp = nb_prod concl - (List.length hyps + nb_prod_init) @@ -528,7 +528,7 @@ let invIn k names ids id = intros_replacing ids else tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) - end + end } in Proofview.tclORELSE (tclTHENLIST @@ -536,7 +536,7 @@ let invIn k names ids id = inversion k NoDep names id; intros_replace_ids]) (wrap_inv_error id) - end + end } let invIn_gen k names idl = try_intros_until (invIn k names idl) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 42d22bc3c4..04a78dc574 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -27,6 +27,7 @@ open Declare open Tacticals.New open Tactics open Decl_kinds +open Proofview.Notations let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ @@ -268,7 +269,7 @@ let lemInv id c gls = let lemInv_gen id c = try_intros_until (fun id -> Proofview.V82.tactic (lemInv id c)) id let lemInvIn id c ids = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let intros_replace_ids = let concl = Proofview.Goal.concl gl in @@ -280,7 +281,7 @@ let lemInvIn id c ids = in ((tclTHEN (tclTHEN (bring_hyps hyps) (Proofview.V82.tactic (lemInv id c))) (intros_replace_ids))) - end + end } let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 7e0182137a..2667fa7ff9 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -35,6 +35,7 @@ open Environ open Termops open Libnames open Sigma.Notations +open Proofview.Notations (** Typeclass-based generalized rewriting. *) @@ -1501,7 +1502,7 @@ let rec insert_dependent env decl accu hyps = match hyps with insert_dependent env decl (ndecl :: accu) rem let assert_replacing id newt tac = - let prf = Proofview.Goal.nf_enter begin fun gl -> + let prf = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let ctx = Environ.named_context env in @@ -1518,7 +1519,7 @@ let assert_replacing id newt tac = let (e, _) = destEvar ev in Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) end } - end in + end } in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) let newfail n s = @@ -1544,14 +1545,14 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = convert_hyp_no_check (id, None, newt) | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let make = { run = begin fun sigma -> let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in Sigma (mkApp (p, [| ev |]), sigma, q) end } in Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls - end + end } | None, None -> Proofview.Unsafe.tclEVARS undef <*> convert_concl_no_check newt DEFAULTcast @@ -1562,7 +1563,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = | None -> Proofview.tclUNIT () | Some id -> Proofview.V82.tactic (Tactics.reduct_in_hyp beta_red (id, InHyp)) in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -1590,7 +1591,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = with | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) - end + end } let tactic_init_setoid () = try init_setoid (); tclIDTAC @@ -2037,7 +2038,7 @@ let not_declared env ty rel = str ty ++ str" relation. Maybe you need to require the Setoid library") let setoid_proof ty fn fallback = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in @@ -2066,7 +2067,7 @@ let setoid_proof ty fn fallback = | e' -> Proofview.tclZERO ~info e' end end - end + end } let tac_open ((evm,_), c) tac = Proofview.V82.tactic diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 895064951d..1ea19bce09 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -632,10 +632,10 @@ let pf_interp_constr ist gl = let new_interp_constr ist c k = let open Proofview in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (sigma, c) = interp_constr ist (Goal.env gl) (Goal.sigma gl) c in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c) - end + end } let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = @@ -1172,9 +1172,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) end | TacAbstract (tac,ido) -> - Proofview.Goal.nf_enter begin fun gl -> Tactics.tclABSTRACT + Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT (Option.map (Tacmach.New.of_old (pf_interp_ident ist) gl) ido) (interp_tactic ist tac) - end + end } | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) | TacDispatch tl -> @@ -1350,7 +1350,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacML (loc,opn,l) -> let trace = push_trace (loc,LtacMLCall tac) ist in let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let goal_sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in @@ -1364,7 +1364,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) - end + end } and force_vrec ist v : typed_generic_argument Ftactic.t = let v = Value.normalize v in @@ -1803,7 +1803,7 @@ and interp_atomic ist tac : unit Proofview.tactic = match tac with (* Basic tactics *) | TacIntroPattern l -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in @@ -1813,9 +1813,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) (Tactics.intros_patterns l')) sigma - end + end } | TacIntroMove (ido,hto) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let mloc = interp_move_location ist env sigma hto in @@ -1823,7 +1823,7 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacIntroMove(ido,mloc)) (Tactics.intro_move ido mloc) - end + end } | TacExact c -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin @@ -1838,7 +1838,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let l = List.map (fun (k,c) -> @@ -1851,10 +1851,10 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in sigma, Tactics.apply_delayed_in a ev clear id l cl in Tacticals.New.tclWITHHOLES ev tac sigma - end + end } end | TacElim (ev,(keep,cb),cbo) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in @@ -1864,9 +1864,9 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma - end + end } | TacCase (ev,(keep,cb)) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in @@ -1875,16 +1875,16 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacCase(ev,(keep,cb))) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma - end + end } | TacFix (idopt,n) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacFix(idopt,n)) (Proofview.V82.tactic (Tactics.fix idopt n)) - end + end } | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin @@ -1903,14 +1903,14 @@ and interp_atomic ist tac : unit Proofview.tactic = end end | TacCofix idopt -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacCofix (idopt)) (Proofview.V82.tactic (Tactics.cofix idopt)) - end + end } | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin @@ -1929,7 +1929,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end end | TacAssert (b,t,ipat,c) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (sigma,c) = @@ -1941,9 +1941,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacAssert(b,t,ipat,c)) (Tactics.forward b tac ipat' c)) sigma - end + end } | TacGeneralize cl -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in @@ -1951,7 +1951,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacGeneralize cl) (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))) sigma - end + end } | TacGeneralizeDep c -> (new_interp_constr ist c) (fun c -> name_atomic (* spiwack: probably needs a goal environment *) @@ -1960,7 +1960,7 @@ and interp_atomic ist tac : unit Proofview.tactic = ) | TacLetTac (na,c,clp,b,eqpat) -> Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let clp = interp_clause ist env sigma clp in @@ -1993,7 +1993,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) (let_pat_tac b (interp_name ist env sigma na) ((sigma,sigma'),c) clp eqpat) sigma') - end + end } (* Automation tactics *) | TacTrivial (debug,lems,l) -> @@ -2003,7 +2003,7 @@ and interp_atomic ist tac : unit Proofview.tactic = ++strbrk"does not print traces anymore." ++ spc() ++strbrk"Use \"Info 1 trivial\", instead.") end; - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let lems = interp_auto_lemmas ist env sigma lems in @@ -2012,7 +2012,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (Auto.h_trivial ~debug lems (Option.map (List.map (interp_hint_base ist)) l)) - end + end } | TacAuto (debug,n,lems,l) -> begin if debug == Tacexpr.Info then msg_warning @@ -2020,7 +2020,7 @@ and interp_atomic ist tac : unit Proofview.tactic = ++strbrk"does not print traces anymore." ++ spc() ++strbrk"Use \"Info 1 auto\", instead.") end; - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let lems = interp_auto_lemmas ist env sigma lems in @@ -2029,14 +2029,14 @@ and interp_atomic ist tac : unit Proofview.tactic = (Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n) lems (Option.map (List.map (interp_hint_base ist)) l)) - end + end } (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma,l = @@ -2060,7 +2060,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.induction_destruct isrec ev (l,el))) - end + end } | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in let h2 = interp_quantified_hypothesis ist h2 in @@ -2069,7 +2069,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (Elim.h_double_induction h1 h2) (* Context management *) | TacClear (b,l) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let sigma = Proofview.Goal.sigma gl in let l = interp_hyp_list ist env sigma l in @@ -2078,16 +2078,16 @@ and interp_atomic ist tac : unit Proofview.tactic = (* spiwack: until the tactic is in the monad *) let tac = Proofview.V82.tactic (fun gl -> Tactics.clear l gl) in Proofview.Trace.name_tactic (fun () -> Pp.str"") tac - end + end } | TacClearBody l -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let sigma = Proofview.Goal.sigma gl in let l = interp_hyp_list ist env sigma l in name_atomic ~env (TacClearBody l) (Tactics.clear_body l) - end + end } | TacMove (id1,id2) -> Proofview.V82.tactic begin fun gl -> Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1) @@ -2095,7 +2095,7 @@ and interp_atomic ist tac : unit Proofview.tactic = gl end | TacRename l -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let sigma = Proofview.Goal.sigma gl in let l = @@ -2106,11 +2106,11 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacRename l) (Tactics.rename_hyp l) - end + end } (* Constructors *) | TacSplit (ev,bll) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in @@ -2119,7 +2119,7 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacSplit (ev, bll)) tac in Tacticals.New.tclWITHHOLES ev named_tac sigma - end + end } (* Conversion *) | TacReduce (r,cl) -> (* spiwack: until the tactic is in the monad *) @@ -2163,7 +2163,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.V82.nf_evar_goals <*> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in Proofview.V82.tactic begin fun gl -> @@ -2182,23 +2182,23 @@ and interp_atomic ist tac : unit Proofview.tactic = (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) { gl with sigma = sigma } end - end + end } end (* Equivalence relations *) | TacSymmetry c -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let cl = interp_clause ist env sigma c in name_atomic ~env (TacSymmetry cl) (Tactics.intros_symmetry cl) - end + end } (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let l' = List.map (fun (b,m,(keep,c)) -> let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in @@ -2215,9 +2215,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)) - end + end } | TacInversion (DepInversion (k,c,ids),hyp) -> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (sigma,c_interp) = @@ -2235,9 +2235,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) (Inv.dinv k c_interp ids_interp dqhyps)) sigma - end + end } | TacInversion (NonDepInversion (k,idl,ids),hyp) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let hyps = interp_hyp_list ist env sigma idl in @@ -2247,9 +2247,9 @@ and interp_atomic ist tac : unit Proofview.tactic = (name_atomic ~env (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) (Inv.inv_clause k ids_interp hyps dqhyps)) sigma - end + end } | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (sigma,c_interp) = interp_constr ist env sigma c in @@ -2259,7 +2259,7 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) (Leminv.lemInv_clause dqhyps c_interp hyps) - end + end } (* Initial call for interpretation *) @@ -2280,7 +2280,7 @@ let eval_tactic_ist ist t = let interp_tac_gen lfun avoid_ids debug t = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let extra = TacStore.set TacStore.empty f_debug debug in let extra = TacStore.set extra f_avoid_ids avoid_ids in @@ -2289,7 +2289,7 @@ let interp_tac_gen lfun avoid_ids debug t = interp_tactic ist (intern_pure_tactic { ltacvars; genv = env } t) - end + end } let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t let _ = Proof_global.set_interp_tac interp @@ -2309,9 +2309,9 @@ let hide_interp global t ot = Proofview.tclENV >>= fun env -> hide_interp env else - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> hide_interp (Proofview.Goal.env gl) - end + end } (***************************************************************************) (** Register standard arguments *) @@ -2411,7 +2411,7 @@ let _ = Hook.set Auto.extern_interp let dummy_id = Id.of_string "_" let lift_constr_tac_to_ml_tac vars tac = - let tac _ ist = Proofview.Goal.enter begin fun gl -> + let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let map = function @@ -2424,5 +2424,5 @@ let lift_constr_tac_to_ml_tac vars tac = in let args = List.map_filter map vars in tac args ist - end in + end } in tac diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bc82e9ef46..3c56bbdc0d 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -538,66 +538,65 @@ module New = struct mkVar (nthHypId m gl) let onNthHypId m tac = - Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end + Proofview.Goal.enter { enter = begin fun gl -> tac (nthHypId m gl) end } let onNthHyp m tac = - Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end + Proofview.Goal.enter { enter = begin fun gl -> tac (nthHyp m gl) end } let onLastHypId = onNthHypId 1 let onLastHyp = onNthHyp 1 let onNthDecl m tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclUNIT (nthDecl m gl) >>= tac - end + end } let onLastDecl = onNthDecl 1 let ifOnHyp pred tac1 tac2 id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in if pred (id,typ) then tac1 id else tac2 id - end + end } - let onHyps find tac = Proofview.Goal.nf_enter (fun gl -> tac (find gl)) + let onHyps find tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (find gl) end } let afterHyp id tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps gl in let rem, _ = List.split_when (fun (hyp,_,_) -> Id.equal hyp id) hyps in tac rem - end + end } let fullGoal gl = let hyps = Tacmach.New.pf_ids_of_hyps gl in None :: List.map Option.make hyps let tryAllHyps tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in tclFIRST_PROGRESS_ON tac hyps - end + end } let tryAllHypsAndConcl tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> tclFIRST_PROGRESS_ON tac (fullGoal gl) - end + end } let onClause tac cl = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl) - end + end } (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - Proofview.Goal.nf_enter - begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.nf_enter { enter = begin fun gl -> let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in (* applying elimination_scheme just a little modified *) let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in @@ -649,10 +648,10 @@ module New = struct Proofview.tclTHEN (Clenvtac.clenv_refine false clenv') (Proofview.tclEXTEND [] tclIDTAC branchtacs) - end) end + end }) end } let elimination_then tac c = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with @@ -660,7 +659,7 @@ module New = struct | Some _ -> false,gl_make_case_dep in general_elim_then_using mkelim isrec None tac None ind (c, t) - end + end } let case_then_using = general_elim_then_using gl_make_case_dep false @@ -669,16 +668,16 @@ module New = struct general_elim_then_using gl_make_case_nodep false let elim_on_ba tac ba = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let branches = Tacmach.New.of_old (make_elim_branch_assumptions ba) gl in tac branches - end + end } let case_on_ba tac ba = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let branches = Tacmach.New.of_old (make_case_branch_assumptions ba) gl in tac branches - end + end } let elimination_sort_of_goal gl = (** Retyping will expand evars anyway. *) @@ -695,11 +694,11 @@ module New = struct | Some id -> elimination_sort_of_hyp id gl let pf_constr_of_global ref tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (sigma, c) = Evd.fresh_global env sigma ref in Proofview.Unsafe.tclEVARS sigma <*> (tac c) - end + end } end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d3cf154c90..66053a314e 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -184,7 +184,7 @@ let unsafe_intro env store (id, c, t) b = end } let introduction ?(check=true) id = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Proofview.Goal.sigma gl in @@ -199,12 +199,12 @@ let introduction ?(check=true) id = | Prod (_, t, b) -> unsafe_intro env store (id, None, t) b | LetIn (_, c, t, b) -> unsafe_intro env store (id, Some c, t) b | _ -> raise (RefinerError IntroNeedsProduct) - end + end } let refine = Tacmach.refine let convert_concl ?(check=true) ty k = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in @@ -221,10 +221,10 @@ let convert_concl ?(check=true) ty k = let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in Sigma (ans, sigma, p +> q) end } - end + end } let convert_hyp ?(check=true) d = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let ty = Proofview.Goal.raw_concl gl in @@ -234,20 +234,20 @@ let convert_hyp ?(check=true) d = Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end } - end + end } let convert_concl_no_check = convert_concl ~check:false let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> try let sigma = Tacmach.New.pf_apply Evd.conversion gl pb x y in Proofview.Unsafe.tclEVARS sigma with (* Reduction.NotConvertible *) _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") -end +end } let convert x y = convert_gen Reduction.CONV x y let convert_leq x y = convert_gen Reduction.CUMUL x y @@ -319,7 +319,7 @@ let rename_hyp repl = match dom with | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping") | Some (src, dst) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in let concl = Proofview.Goal.concl gl in @@ -356,7 +356,7 @@ let rename_hyp repl = let (sigma, c) = Evarutil.new_evar_instance nctx sigma nconcl ~store instance in Sigma.Unsafe.of_pair (c, sigma) end } - end + end } (**************************************************************) (* Fresh names *) @@ -417,7 +417,7 @@ let find_name mayrepl decl naming gl = match naming with (**************************************************************) let assert_before_then_gen b naming t tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (Anonymous,None,t) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic @@ -426,7 +426,7 @@ let assert_before_then_gen b naming t tac = with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) - end + end } let assert_before_gen b naming t = assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) @@ -435,7 +435,7 @@ let assert_before na = assert_before_gen false (naming_of_name na) let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) let assert_after_then_gen b naming t tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (Anonymous,None,t) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic @@ -444,7 +444,7 @@ let assert_after_then_gen b naming t tac = with Evarutil.ClearDependencyError (id,err) -> error_replacing_dependency (pf_env gl) (project gl) id err)) (tac id) - end + end } let assert_after_gen b naming t = assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) @@ -783,7 +783,7 @@ let build_intro_tac id dest tac = match dest with Proofview.V82.tactic (move_hyp id dest); tac id] let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let concl = nf_evar (Proofview.Goal.sigma gl) concl in match kind_of_term concl with @@ -809,7 +809,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end - end + end } let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) let intro_mustbe_force id = intro_gen (NamingMustBe (dloc,id)) MoveLast true false @@ -873,14 +873,14 @@ let get_previous_hyp_position id gl = aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let intro_replacing id = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let next_hyp = get_next_hyp_position id gl in Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (thin_for_replacing [id]); introduction id; Proofview.V82.tactic (move_hyp id next_hyp); ] - end + end } (* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to reintroduce y, y,' y''. Note that we have to clear y, y' and y'' @@ -892,7 +892,7 @@ let intro_replacing id = (* the behavior of inversion *) let intros_possibly_replacing ids = let suboptimal = true in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> @@ -901,16 +901,16 @@ let intros_possibly_replacing ids = (Tacticals.New.tclMAP (fun (id,pos) -> Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id)) posl) - end + end } (* This version assumes that replacement is actually possible *) let intros_replacing ids = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in Tacticals.New.tclTHEN (Proofview.V82.tactic (thin_for_replacing ids)) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) - end + end } (* User-level introduction tactics *) @@ -954,10 +954,10 @@ let depth_of_quantified_hypothesis red h gl = str".") let intros_until_gen red h = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let n = Tacmach.New.of_old (depth_of_quantified_hypothesis red h) gl in Tacticals.New.tclDO n (if red then introf else intro) - end + end } let intros_until_id id = intros_until_gen false (NamedHyp id) let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) @@ -998,20 +998,20 @@ let onOpenInductionArg env sigma tac = function (intros_until_n n) (Tacticals.New.onLastHyp (fun c -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let pending = (sigma,sigma) in tac clear_flag (pending,(c,NoBindings)) - end)) + end })) | clear_flag,ElimOnIdent (_,id) -> (* A quantified hypothesis *) Tacticals.New.tclTHEN (try_intros_until_id_check id) - (Proofview.Goal.enter begin fun gl -> + (Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let pending = (sigma,sigma) in tac clear_flag (pending,(mkVar id,NoBindings)) - end) + end }) let onInductionArg tac = function | clear_flag,ElimOnConstr cbl -> @@ -1036,7 +1036,7 @@ let map_induction_arg f = function (****************************************) let cut c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let concl = Tacmach.New.pf_nf_concl gl in @@ -1062,7 +1062,7 @@ let cut c = end } else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") - end + end } let error_uninstantiated_metas t clenv = let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in @@ -1171,12 +1171,12 @@ let enforce_prop_bound_names rename tac = mkLetIn (na,c,t,aux (push_rel (na,Some c,t) env) sigma (i-1) t') | _ -> print_int i; Pp.msg (print_constr t); assert false in let rename_branch i = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let t = Proofview.Goal.concl gl in change_concl (aux env sigma i t) - end in + end } in (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) tac (Array.map rename_branch nn) @@ -1191,7 +1191,7 @@ let rec contract_letin_in_lam_header c = let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let elim = contract_letin_in_lam_header elim in @@ -1204,7 +1204,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags) - end + end } (* * Elimination tactic with bindings and using an arbitrary @@ -1221,7 +1221,7 @@ type eliminator = { } let general_elim_clause_gen elimtac indclause elim = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (elimc,lbindelimc) = elim.elimbody in @@ -1229,10 +1229,10 @@ let general_elim_clause_gen elimtac indclause elim = let i = match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause - end + end } let general_elim with_evars clear_flag (c, lbindc) elim = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let ct = Retyping.get_type_of env sigma c in @@ -1242,7 +1242,7 @@ let general_elim with_evars clear_flag (c, lbindc) elim = Tacticals.New.tclTHEN (general_elim_clause_gen elimtac indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) - end + end } (* Case analysis tactics *) @@ -1349,7 +1349,7 @@ let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let elim = contract_letin_in_lam_header elim in @@ -1372,7 +1372,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' (fun id -> Proofview.tclUNIT ()) - end + end } let general_elim_clause with_evars flags id c e = let elim = match id with @@ -1427,7 +1427,7 @@ let make_projection env sigma params cstr sign elim i n c u = in elim let descend_in_conjunctions avoid tac (err, info) c = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in try @@ -1448,7 +1448,7 @@ let descend_in_conjunctions avoid tac (err, info) c = NotADefinedRecordUseScheme (snd elim) in Tacticals.New.tclFIRST (List.init n (fun i -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in match make_projection env sigma params cstr sign elim i n c u with @@ -1459,10 +1459,10 @@ let descend_in_conjunctions avoid tac (err, info) c = [Proofview.V82.tactic (refine p); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] - end)) + end })) | None -> Proofview.tclZERO ~info err with RefinerError _|UserError _ -> Proofview.tclZERO ~info err - end + end } (****************************************************) (* Resolution tactics *) @@ -1495,7 +1495,7 @@ let tclORELSEOPT t k = | Some tac -> tac) let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags () in @@ -1504,7 +1504,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) step. *) let concl_nprod = nb_prod concl in let rec try_main_apply with_destruct c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -1558,14 +1558,14 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) | PretypeError _|RefinerError _|UserError _|Failure _ -> Some (try_red_apply thm_ty0 (e, info)) | _ -> None) - end + end } in Tacticals.New.tclTHENLIST [ try_main_apply with_destruct c; solve_remaining_apply_goals; apply_clear_request clear_flag (use_clear_hyp_by_default ()) c ] - end + end } let rec apply_with_bindings_gen b e = function | [] -> Proofview.tclUNIT () @@ -1577,13 +1577,13 @@ let rec apply_with_bindings_gen b e = function let apply_with_delayed_bindings_gen b e l = let one k (loc, f) = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let (cb, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES e (general_apply b b e k (loc,cb)) sigma - end + end } in let rec aux = function | [] -> Proofview.tclUNIT () @@ -1646,7 +1646,7 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) = let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let flags = @@ -1655,7 +1655,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (Anonymous,None,t') naming gl in let rec aux idstoclear with_destruct c = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in try @@ -1672,14 +1672,14 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming (descend_in_conjunctions [targetid] (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) - end + end } in aux [] with_destruct d - end + end } let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,f)) tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (c, sigma) = run_delayed env sigma f in @@ -1687,7 +1687,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam (apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,c)) tac) sigma - end + end } (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -1707,7 +1707,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam *) let cut_and_apply c = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> let concl = Proofview.Goal.concl gl in @@ -1720,7 +1720,7 @@ let cut_and_apply c = Sigma (ans, sigma, p +> q) end } | _ -> error "lapply needs a non-dependent product." - end + end } (********************************************************************) (* Exact tactics *) @@ -1780,10 +1780,10 @@ let assumption = Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar id) h } else arec gl only_eq rest in - let assumption_tac gl = + let assumption_tac = { enter = begin fun gl -> let hyps = Proofview.Goal.hyps gl in arec gl true hyps - in + end } in Proofview.Goal.nf_enter assumption_tac (*****************************************************************) @@ -1826,7 +1826,7 @@ let check_decl env (_, c, ty) msg = msg e let clear_body ids = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let ctx = named_context env in @@ -1862,7 +1862,7 @@ let clear_body ids = Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma concl end } - end + end } let clear_wildcards ids = Proofview.V82.tactic (tclMAP (fun (loc,id) gl -> @@ -1922,7 +1922,7 @@ let specialize (c,lbind) g = (* Keeping only a few hypotheses *) let keep hyps = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = @@ -1935,7 +1935,7 @@ let keep hyps = ~init:([],[]) (Proofview.Goal.env gl) in Proofview.V82.tactic (fun gl -> thin cl gl) - end + end } (************************) (* Introduction tactics *) @@ -1991,7 +1991,7 @@ let rec tclANY tac = function let any_constructor with_evars tacopt = let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl @@ -2001,7 +2001,7 @@ let any_constructor with_evars tacopt = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; tclANY tac (List.interval 1 nconstr) - end + end } let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2 @@ -2052,7 +2052,7 @@ let my_find_eq_data_decompose gl t = | Constr_matching.PatternMatchingFailure -> None let intro_decomp_eq loc l thin tac id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in @@ -2063,10 +2063,10 @@ let intro_decomp_eq loc l thin tac id = (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") - end + end } let intro_or_and_pattern loc bracketed ll thin tac id = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in @@ -2077,7 +2077,7 @@ let intro_or_and_pattern loc bracketed ll thin tac id = (Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id]))) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) nv (Array.of_list ll)) - end + end } let rewrite_hyp assert_style l2r id = let rew_on l2r = @@ -2085,7 +2085,7 @@ let rewrite_hyp assert_style l2r id = let subst_on l2r x rhs = Hook.get forward_subst_one true x (id,rhs,l2r) in let clear_var_and_eq c = tclTHEN (clear [id]) (clear [destVar c]) in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_betadeltaiota = Tacmach.New.pf_apply whd_betadeltaiota gl in @@ -2107,7 +2107,7 @@ let rewrite_hyp assert_style l2r id = Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) | _ -> Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) - end + end } let rec prepare_naming loc = function | IntroIdentifier id -> NamingMustBe (loc,id) @@ -2243,7 +2243,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with Proofview.tclUNIT () (* apply_in_once do a replacement *) else Proofview.V82.tactic (clear [id]) in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in @@ -2255,7 +2255,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with (fun id -> Tacticals.New.tclTHEN doclear (tac_ipat id))) (tac thin None [])) sigma - end + end } and prepare_intros_loc loc dft destopt = function | IntroNaming ipat -> @@ -2318,7 +2318,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) else get_previous_hyp_position id gl in @@ -2329,7 +2329,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id - end + end } (* if sidecond_first then @@ -2477,12 +2477,12 @@ let letin_pat_tac with_eq id c occs = let forward b usetac ipat c = match usetac with | None -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let t = Tacmach.New.pf_unsafe_type_of gl c in let hd = head_ident c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (Proofview.V82.tactic (exact_no_check c)) - end + end } | Some tac -> if b then Tacticals.New.tclTHENFIRST (assert_as b None ipat c) tac @@ -2512,7 +2512,7 @@ let apply_type hdcty argl gl = let bring_hyps hyps = if List.is_empty hyps then Tacticals.New.tclIDTAC else - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in @@ -2521,14 +2521,14 @@ let bring_hyps hyps = let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma newcl in Sigma (mkApp (ev, args), sigma, p) end } - end + end } let revert hyps = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) - end + end } (* Compute a name for a generalization *) @@ -2809,7 +2809,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = match ra with | (RecArg,deprec,recvarname) :: (IndArg,depind,hyprecname) :: ra' -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in @@ -2817,37 +2817,37 @@ let induct_discharge dests avoid' tac (avoid,ra) names = | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in dest_intro_patterns avoid thin dest [recpat] (fun ids thin -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (hyprec,names) = consume_pattern avoid (Name hyprecname) depind gl names in dest_intro_patterns avoid thin MoveLast [hyprec] (fun ids' thin -> peel_tac ra' (update_dest dests ids') names thin) - end) - end + end }) + end } | (IndArg,dep,hyprecname) :: ra' -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid (Name hyprecname) dep gl names in dest_intro_patterns avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) - end + end } | (RecArg,dep,recvarname) :: ra' -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in let dest = get_recarg_dest dests in dest_intro_patterns avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) - end + end } | (OtherArg,dep,_) :: ra' -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in safe_dest_intro_patterns avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) - end + end } | [] -> check_unused_names names; Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests) @@ -2861,7 +2861,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in @@ -2910,7 +2910,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = (atomize_one (i-1) (mkVar x::args) (x::avoid)) in atomize_one (List.length argl) [] [] - end + end } (* [cook_sign] builds the lists [beforetoclear] (preceding the ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps @@ -3362,7 +3362,7 @@ let abstract_args gl generalize_vars dep id defined f args = else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in @@ -3394,7 +3394,7 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = [revert vars ; Proofview.V82.tactic (fun gl -> tclMAP (fun id -> tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)]) - end + end } let rec compare_upto_variables x y = if (isVar x || isRel x) && (isVar y || isRel y) then true @@ -3817,12 +3817,12 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = end } let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in atomize_param_of_ind_then elim_info hyp0 (fun indvars -> apply_induction_in_context (Some hyp0) inhyps (pi3 elim_info) indvars names (fun elim -> Proofview.V82.tactic (induction_tac with_evars [] [hyp0] elim))) - end + end } let msg_not_right_number_induction_arguments scheme = str"Not the right number of induction arguments (expected " ++ @@ -3839,7 +3839,7 @@ let msg_not_right_number_induction_arguments scheme = must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac *) let induction_without_atomization isrec with_evars elim names lid = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in let nargs_indarg_farg = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in @@ -3870,7 +3870,7 @@ let induction_without_atomization isrec with_evars elim names lid = ]) in let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in apply_induction_in_context None [] elim indvars names induct_tac - end + end } (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls gl = @@ -4021,7 +4021,7 @@ let induction_gen clear_flag isrec with_evars elim let inhyps = match cls with | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps | _ -> [] in - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.raw_concl gl in @@ -4057,7 +4057,7 @@ let induction_gen clear_flag isrec with_evars elim isrec with_evars info_arg elim id arg t inhyps cls (induction_with_atomization_of_ind_arg isrec with_evars elim names id inhyps) - end + end } (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is @@ -4082,7 +4082,7 @@ let induction_gen_l isrec with_evars elim names lc = atomize_list l' | _ -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let x = id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in @@ -4093,7 +4093,7 @@ let induction_gen_l isrec with_evars elim names lc = Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') - end in + end } in Tacticals.New.tclTHENLIST [ (atomize_list lc); @@ -4110,7 +4110,7 @@ let induction_destruct isrec with_evars (lc,elim) = match lc with | [] -> assert false (* ensured by syntax, but if called inside caml? *) | [c,(eqname,names as allnames),cls] -> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in match elim with @@ -4135,9 +4135,9 @@ let induction_destruct isrec with_evars (lc,elim) = (* standard induction *) onOpenInductionArg env sigma (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c - end + end } | _ -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in match elim with @@ -4153,12 +4153,12 @@ let induction_destruct isrec with_evars (lc,elim) = (onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag isrec with_evars None (a,b) cl) a) (Tacticals.New.tclMAP (fun (a,b,cl) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag false with_evars None (a,b) cl) a - end) l) + end }) l) | Some elim -> (* Several induction hyps with induction scheme *) let finish_evar_resolution f = @@ -4186,7 +4186,7 @@ let induction_destruct isrec with_evars (lc,elim) = error "'as' clause with multiple arguments and 'using' clause can only occur last."; let newlc = List.map (fun (x,_) -> (x,None)) newlc in induction_gen_l isrec with_evars elim names newlc - end + end } let induction ev clr c l e = induction_gen clr true ev e @@ -4228,7 +4228,7 @@ let simple_destruct = function *) let elim_scheme_type elim t = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in match kind_of_term (last_arg clause.templval.rebus) with | Meta mv -> @@ -4238,7 +4238,7 @@ let elim_scheme_type elim t = (clenv_meta_type clause mv) clause in Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false | _ -> anomaly (Pp.str "elim_scheme_type") - end + end } let elim_type t = Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> @@ -4274,7 +4274,7 @@ let maybe_betadeltaiota_concl allowred gl = whd_betadeltaiota env sigma concl let reflexivity_red allowred = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4282,7 +4282,7 @@ let reflexivity_red allowred = match match_with_equality_type concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings - end + end } let reflexivity = Proofview.tclORELSE @@ -4324,7 +4324,7 @@ let match_with_equation c = Proofview.tclZERO NoEquationFound let symmetry_red allowred = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4336,7 +4336,7 @@ let symmetry_red allowred = (convert_concl_no_check concl DEFAULTcast) (Tacticals.New.pf_constr_of_global eq_data.sym apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind - end + end } let symmetry = Proofview.tclORELSE @@ -4350,7 +4350,7 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in Proofview.tclORELSE @@ -4368,7 +4368,7 @@ let symmetry_in id = | NoEquationFound -> Hook.get forward_setoid_symmetry_in id | e -> Proofview.tclZERO ~info e end - end + end } let intros_symmetry = Tacticals.New.onClause @@ -4393,7 +4393,7 @@ let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (eq1,eq2) = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) @@ -4413,10 +4413,10 @@ let prove_transitivity hdcncl eq_kind t = [ Tacticals.New.tclDO 2 intro; Tacticals.New.onLastHyp simplest_case; assumption ])) - end + end } let transitivity_red allowred t = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) @@ -4433,7 +4433,7 @@ let transitivity_red allowred t = match t with | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") | Some t -> prove_transitivity eq eq_kind t - end + end } let transitivity_gen t = Proofview.tclORELSE diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 59c5792377..9bee7ab3ed 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -18,6 +18,7 @@ open Tacinterp open Tactics open Errors open Util +open Proofview.Notations DECLARE PLUGIN "tauto" @@ -305,13 +306,13 @@ let reduction_not_iff _ist = let t_reduction_not_iff = tacticIn reduction_not_iff let intuition_gen ist flags tac = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let tac = Value.of_closure ist tac in let env = Proofview.Goal.env gl in let vars, ist, intuition = tauto_intuit flags t_reduction_not_iff tac in let glb_intuition = Tacintern.glob_tactic_env vars env intuition in eval_tactic_ist ist glb_intuition - end + end } let tauto_intuitionistic flags = Proofview.tclORELSE diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 8ac273c84f..8282ce30be 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -355,7 +355,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = ))) ) in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of_pq = Tacmach.New.of_old (fun gl -> pf_unsafe_type_of gl p) gl in let u,v = destruct_ind type_of_pq in let lb_type_of_p = @@ -385,7 +385,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; Equality.replace p q ; apply app ; Auto.default_auto] - end + end } (* used in the bool -> leib side *) let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = @@ -417,7 +417,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let rec aux l1 l2 = match (l1,l2) with | (t1::q1,t2::q2) -> - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in if eq_constr t1 t2 then aux q1 q2 else ( @@ -458,7 +458,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = aux q1 q2 ] ) ) - end + end } | ([],[]) -> Proofview.tclUNIT () | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.") in @@ -565,7 +565,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = avoid := fresh::(!avoid); fresh end gl in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -588,18 +588,18 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Tacticals.New.tclREPEAT ( Tacticals.New.tclTHENLIST [ Simple.apply_in freshz (andb_prop()); - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in (destruct_on_as (mkVar freshz) [[dl,IntroNaming (IntroIdentifier fresht); dl,IntroNaming (IntroIdentifier freshz)]]) - end + end } ]); (* Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) - Proofview.Goal.nf_enter begin fun gls -> + Proofview.Goal.nf_enter { enter = begin fun gls -> let gl = Proofview.Goal.concl gls in match (kind_of_term gl) with | App (c,ca) -> ( @@ -618,10 +618,10 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") ) | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - end + end } ] - end + end } let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -708,7 +708,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = avoid := fresh::(!avoid); fresh end gl in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -731,7 +731,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclTHENLIST [apply (andb_true_intro()); simplest_split ;Auto.default_auto ] ); - Proofview.Goal.nf_enter begin fun gls -> + Proofview.Goal.nf_enter { enter = begin fun gls -> let gl = Proofview.Goal.concl gls in (* assume the goal to be eq (eq_type ...) = true *) match (kind_of_term gl) with @@ -747,9 +747,9 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = ) | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - end + end } ] - end + end } let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") @@ -855,7 +855,7 @@ let compute_dec_tact ind lnamesparrec nparrec = avoid := fresh::(!avoid); fresh end gl in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in let freshn = fresh_id (Id.of_string "x") gl in let freshm = fresh_id (Id.of_string "y") gl in @@ -886,7 +886,7 @@ let compute_dec_tact ind lnamesparrec nparrec = ) (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto); - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let freshH2 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENS (destruct_on_using (mkVar freshH) freshH2) [ (* left *) @@ -898,7 +898,7 @@ let compute_dec_tact ind lnamesparrec nparrec = ; (*right *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let freshH3 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENLIST [ simplest_right ; @@ -920,11 +920,11 @@ let compute_dec_tact ind lnamesparrec nparrec = true; Equality.discr_tac false None ] - end + end } ] - end + end } ] - end + end } let make_eq_decidability mode mind = let mib = Global.lookup_mind mind in -- cgit v1.2.3 From 4cc1714ac9b0944b6203c23af8c46145e7239ad3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 20 Oct 2015 14:45:31 +0200 Subject: Indexing Proofview.goals with a stage. This is not perfect though, some primitives are unsound, and some higher-order API should use polymorphic functions so as not to depend on a given level. --- plugins/micromega/coq_micromega.ml | 22 +++++++----- proofs/proofview.ml | 22 ++++++------ proofs/proofview.mli | 68 ++++++++++++++++++++++---------------- proofs/tacmach.ml | 2 +- proofs/tacmach.mli | 45 +++++++++++++------------ tactics/auto.mli | 2 +- tactics/class_tactics.ml | 10 +++--- tactics/equality.ml | 1 + tactics/ftactic.mli | 6 ++-- tactics/hipattern.mli | 6 ++-- tactics/tacticals.ml | 2 +- tactics/tacticals.mli | 10 +++--- 12 files changed, 109 insertions(+), 87 deletions(-) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a0e61623c7..470e21c820 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -888,7 +888,7 @@ struct let is_convertible gl t1 t2 = - Reductionops.is_conv (Tacmach.New.pf_env gl) (Goal.sigma gl) t1 t2 + Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2 let parse_zop gl (op,args) = match kind_of_term op with @@ -1169,8 +1169,8 @@ struct with e when Errors.noncritical e -> (X(t),env,tg) in let is_prop term = - let ty = Typing.unsafe_type_of (Goal.env gl) (Goal.sigma gl) term in - let sort = Typing.sort_of (Goal.env gl) (ref (Goal.sigma gl)) ty in + let ty = Typing.unsafe_type_of (Tacmach.pf_env gl) (Tacmach.project gl) term in + let sort = Typing.sort_of (Tacmach.pf_env gl) (ref (Tacmach.project gl)) ty in Term.is_prop_sort sort in let rec xparse_formula env tg term = @@ -1446,6 +1446,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let vm = dump_varmap (spec.typ) env in (* todo : directly generate the proof term - or generalize before conversion? *) Proofview.Goal.nf_enter { enter = begin fun gl -> + let gl = Tacmach.New.of_old (fun x -> x) gl in Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1457,7 +1458,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|])); ("__wit", cert, cert_typ) ] - (Tacmach.New.pf_concl gl)) + (Tacmach.pf_concl gl)) ; Tactics.new_generalize env ; Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids) @@ -1708,8 +1709,9 @@ let micromega_gen unsat deduce spec prover = Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in + let gl = Tacmach.New.of_old (fun x -> x) gl in + let concl = Tacmach.pf_concl gl in + let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in @@ -1755,6 +1757,7 @@ let micromega_order_changer cert env ff = let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) env in Proofview.Goal.nf_enter { enter = begin fun gl -> + let gl = Tacmach.New.of_old (fun x -> x) gl in Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -1766,7 +1769,7 @@ let micromega_order_changer cert env ff = [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); ("__wit", cert, cert_typ) ] - (Tacmach.New.pf_concl gl))); + (Tacmach.pf_concl gl))); Tactics.new_generalize env ; Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids) ] @@ -1787,8 +1790,9 @@ let micromega_genr prover = dump_proof = dump_psatz coq_Q dump_q } in Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in + let gl = Tacmach.New.of_old (fun x -> x) gl in + let concl = Tacmach.pf_concl gl in + let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in diff --git a/proofs/proofview.ml b/proofs/proofview.ml index b8a58daeb2..826b4772a0 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -908,17 +908,17 @@ let catchable_exception = function module Goal = struct - type 'a t = { + type ('a, 'r) t = { env : Environ.env; sigma : Evd.evar_map; concl : Term.constr ; self : Evar.t ; (* for compatibility with old-style definitions *) } - type 'a enter = - { enter : 'a t -> unit tactic } + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } - let assume (gl : 'a t) = (gl :> [ `NF ] t) + let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) let env { env=env } = env let sigma { sigma=sigma } = sigma @@ -977,8 +977,8 @@ module Goal = struct end end - type 'a s_enter = - { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin @@ -1033,6 +1033,8 @@ module Goal = struct (* compatibility *) let goal { self=self } = self + let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) + end @@ -1257,8 +1259,8 @@ module Notations = struct let (>>=) = tclBIND let (<*>) = tclTHEN let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type 'a enter = 'a Goal.enter = - { enter : 'a Goal.t -> unit tactic } - type 'a s_enter = 'a Goal.s_enter = - { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 1616782e54..5c97ada344 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -418,61 +418,71 @@ end module Goal : sig - (** The type of goals. The parameter type is a phantom argument indicating - whether the data contained in the goal has been normalized w.r.t. the - current sigma. If it is the case, it is flagged [ `NF ]. You may still - access the un-normalized data using {!assume} if you known you do not rely - on the assumption of being normalized, at your own risk. *) - type 'a t + (** Type of goals. + + The first parameter type is a phantom argument indicating whether the data + contained in the goal has been normalized w.r.t. the current sigma. If it + is the case, it is flagged [ `NF ]. You may still access the un-normalized + data using {!assume} if you known you do not rely on the assumption of + being normalized, at your own risk. + + The second parameter is a stage indicating where the goal belongs. See + module {!Sigma}. + *) + type ('a, 'r) t (** Assume that you do not need the goal to be normalized. *) - val assume : 'a t -> [ `NF ] t + val assume : ('a, 'r) t -> ([ `NF ], 'r) t (** Normalises the argument goal. *) - val normalize : 'a t -> [ `NF ] t tactic + val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) - val concl : [ `NF ] t -> Term.constr - val hyps : [ `NF ] t -> Context.named_context - val env : 'a t -> Environ.env - val sigma : 'a t -> Evd.evar_map - val extra : 'a t -> Evd.Store.t + val concl : ([ `NF ], 'r) t -> Term.constr + val hyps : ([ `NF ], 'r) t -> Context.named_context + val env : ('a, 'r) t -> Environ.env + val sigma : ('a, 'r) t -> Evd.evar_map + val extra : ('a, 'r) t -> Evd.Store.t (** Returns the goal's conclusion even if the goal is not normalised. *) - val raw_concl : 'a t -> Term.constr + val raw_concl : ('a, 'r) t -> Term.constr - type 'a enter = - { enter : 'a t -> unit tactic } + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } (** [nf_enter t] applies the goal-dependent tactic [t] in each goal independently, in the manner of {!tclINDEPENDENT} except that the current goal is also given as an argument to [t]. The goal is normalised with respect to evars. *) - val nf_enter : [ `NF ] enter -> unit tactic + val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : [ `LZ ] enter -> unit tactic + val enter : ([ `LZ ], unit tactic) enter -> unit tactic - type 'a s_enter = - { s_enter : 'r. 'a t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing the returned tactic. *) - val s_enter : [ `LZ ] s_enter -> unit tactic + val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : [ `NF ] s_enter -> unit tactic + val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic - (** Recover the list of current goals under focus, without evar-normalization *) - val goals : [ `LZ ] t tactic list tactic + (** Recover the list of current goals under focus, without evar-normalization. + FIXME: encapsulate the level in an existential type. *) + val goals : ([ `LZ ], 'r) t tactic list tactic (** Compatibility: avoid if possible *) - val goal : [ `NF ] t -> Evar.t + val goal : ([ `NF ], 'r) t -> Evar.t + + (** Every goal is valid at a later stage. FIXME: take a later evarmap *) + val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t end @@ -595,8 +605,8 @@ module Notations : sig (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - type 'a enter = 'a Goal.enter = - { enter : 'a Goal.t -> unit tactic } - type 'a s_enter = 'a Goal.s_enter = - { s_enter : 'r. 'a Goal.t -> 'r Sigma.t -> (unit tactic, 'r) Sigma.sigma } + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } end diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 4238d1e372..8af28b6ab1 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -212,7 +212,7 @@ module New = struct let hyps = Proofview.Goal.hyps gl in List.hd hyps - let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) = + let pf_nf_concl (gl : ([ `LZ ], 'r) Proofview.Goal.t) = (** We normalize the conclusion just after *) let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index a0e1a01577..3ed6a2eeb1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -106,36 +106,37 @@ val pr_glls : goal list sigma -> Pp.std_ppcmds (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig - val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a - val pf_global : identifier -> 'a Proofview.Goal.t -> constr - val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a + val pf_apply : (env -> evar_map -> 'a) -> ('b, 'r) Proofview.Goal.t -> 'a + val pf_global : identifier -> ('a, 'r) Proofview.Goal.t -> constr + (** FIXME: encapsulate the level in an existential type. *) + val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a - val pf_env : 'a Proofview.Goal.t -> Environ.env - val pf_concl : [ `NF ] Proofview.Goal.t -> types + val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env + val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types - val pf_unsafe_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types - val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> evar_map * Term.types - val pf_conv_x : 'a Proofview.Goal.t -> Term.constr -> Term.constr -> bool + val pf_unsafe_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types + val pf_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> evar_map * Term.types + val pf_conv_x : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.constr -> bool - val pf_get_new_id : identifier -> [ `NF ] Proofview.Goal.t -> identifier - val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list - val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list + val pf_get_new_id : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> identifier + val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list + val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list - val pf_get_hyp : identifier -> [ `NF ] Proofview.Goal.t -> named_declaration - val pf_get_hyp_typ : identifier -> [ `NF ] Proofview.Goal.t -> types - val pf_last_hyp : [ `NF ] Proofview.Goal.t -> named_declaration + val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_get_hyp_typ : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types + val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> named_declaration - val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types + val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types + val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types - val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types - val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types + val pf_hnf_constr : ('a, 'r) Proofview.Goal.t -> constr -> types + val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> constr -> types - val pf_whd_betadeltaiota : 'a Proofview.Goal.t -> constr -> constr - val pf_compute : 'a Proofview.Goal.t -> constr -> constr + val pf_whd_betadeltaiota : ('a, 'r) Proofview.Goal.t -> constr -> constr + val pf_compute : ('a, 'r) Proofview.Goal.t -> constr -> constr - val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map + val pf_matches : ('a, 'r) Proofview.Goal.t -> constr_pattern -> constr -> patvar_map - val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr + val pf_nf_evar : ('a, 'r) Proofview.Goal.t -> constr -> constr end diff --git a/tactics/auto.mli b/tactics/auto.mli index cae180ce76..215544a591 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -26,7 +26,7 @@ val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> - [ `NF ] Proofview.Goal.t -> clausenv * constr + ([ `NF ], 'r) Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 9c22beba27..8ee3ec9281 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -166,15 +166,17 @@ let e_give_exact flags poly (c,clenv) gl = let t1 = pf_unsafe_type_of gl c in tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl -let unify_e_resolve poly flags (c,clenv) gls = +let unify_e_resolve poly flags = { enter = begin fun gls (c,clenv) -> let clenv', c = connect_hint_clenv poly c clenv gls in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in Clenvtac.clenv_refine true ~with_classes:false clenv' + end } -let unify_resolve poly flags (c,clenv) gls = +let unify_resolve poly flags = { enter = begin fun gls (c,clenv) -> let clenv', _ = connect_hint_clenv poly c clenv gls in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in Clenvtac.clenv_refine false ~with_classes:false clenv' + end } let clenv_of_prods poly nprods (c, clenv) gl = let (c, _, _) = c in @@ -191,7 +193,7 @@ let with_prods nprods poly (c, clenv) f = Proofview.Goal.nf_enter { enter = begin fun gl -> match clenv_of_prods poly nprods (c, clenv) gl with | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some clenv' -> f (c, clenv') gl + | Some clenv' -> f.enter gl (c, clenv') end } (** Hack to properly solve dependent evars that are typeclasses *) @@ -902,5 +904,5 @@ let autoapply c i gl = (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - let tac = { enter = fun gl -> unify_e_resolve false flags ((c,cty,Univ.ContextSet.empty),ce) gl } in + let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),ce) } in Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/equality.ml b/tactics/equality.ml index e8f88fca10..0c487c4e63 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1795,6 +1795,7 @@ let rewrite_assumption_cond cond_eq_term cl = end in Proofview.Goal.nf_enter { enter = begin fun gl -> + let gl = Proofview.Goal.lift gl Sigma.Unsafe.le in let hyps = Proofview.Goal.hyps gl in arec hyps gl end } diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli index 4835156748..4496499229 100644 --- a/tactics/ftactic.mli +++ b/tactics/ftactic.mli @@ -37,12 +37,14 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t +val nf_enter : (([ `NF ], 'r) Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal. The resulting tactic is focussed. *) +(** FIXME: Should be polymorphic over the stage. *) -val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t +val enter : (([ `LZ ], 'r) Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) +(** FIXME: Should be polymorphic over the stage. *) val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 27d25056e1..281e6b9bb9 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -119,11 +119,11 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr -> +val find_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr -> coq_eq_data * Univ.universe_instance * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr -> +val find_this_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr -> coq_eq_data * Univ.universe_instance * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) @@ -144,7 +144,7 @@ val is_matching_sigma : constr -> bool val match_eqdec : constr -> bool * constr * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : [ `NF ] Proofview.Goal.t -> constr -> (constr * constr * constr) +val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) val is_matching_not : constr -> bool diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 3c56bbdc0d..c67053252b 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -560,7 +560,7 @@ module New = struct tac2 id end } - let onHyps find tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (find gl) end } + let onHyps find tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (find.enter gl) end } let afterHyp id tac = Proofview.Goal.nf_enter { enter = begin fun gl -> diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 4e860892d0..80e01a8d07 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -223,7 +223,7 @@ module New : sig val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : [ `NF ] Proofview.Goal.t -> int -> named_context + val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> named_context val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> @@ -234,7 +234,7 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic - val onHyps : ([ `NF ] Proofview.Goal.t -> named_context) -> + val onHyps : ([ `NF ], named_context) Proofview.Goal.enter -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic @@ -242,9 +242,9 @@ module New : sig val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic val onClause : (identifier option -> unit tactic) -> clause -> unit tactic - val elimination_sort_of_goal : 'a Proofview.Goal.t -> sorts_family - val elimination_sort_of_hyp : Id.t -> 'a Proofview.Goal.t -> sorts_family - val elimination_sort_of_clause : Id.t option -> 'a Proofview.Goal.t -> sorts_family + val elimination_sort_of_goal : ('a, 'r) Proofview.Goal.t -> sorts_family + val elimination_sort_of_hyp : Id.t -> ('a, 'r) Proofview.Goal.t -> sorts_family + val elimination_sort_of_clause : Id.t option -> ('a, 'r) Proofview.Goal.t -> sorts_family val elimination_then : (branch_args -> unit Proofview.tactic) -> -- cgit v1.2.3 From 2d747797c427818cdf85d0a0d701c7c9b0106b82 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 20 Oct 2015 16:12:39 +0200 Subject: Proofview.Goal.sigma returns an indexed evarmap. --- plugins/cc/cctac.ml | 2 +- plugins/quote/quote.ml | 2 +- plugins/setoid_ring/newring.ml | 4 +-- proofs/clenvtac.ml | 2 +- proofs/proofview.ml | 3 +- proofs/proofview.mli | 2 +- proofs/tacmach.ml | 12 ++++--- proofs/tacmach.mli | 1 + tactics/auto.ml | 16 ++++----- tactics/contradiction.ml | 4 +-- tactics/eauto.ml4 | 4 +-- tactics/elim.ml | 2 +- tactics/equality.ml | 22 ++++++------ tactics/extratactics.ml4 | 4 +-- tactics/rewrite.ml | 4 +-- tactics/tacinterp.ml | 80 +++++++++++++++++++++--------------------- tactics/tacticals.ml | 2 +- tactics/tactics.ml | 58 +++++++++++++++--------------- 18 files changed, 115 insertions(+), 109 deletions(-) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 35178aa1e4..8c15f54af8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -385,7 +385,7 @@ let discriminate_tac (cstr,u as cstru) p = let identity = Universes.constr_of_global (Lazy.force _I) in (* let trivial=pf_unsafe_type_of gls identity in *) let trivial = Universes.constr_of_global (Lazy.force _True) in - let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in + let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Tacmach.New.project gl) in let outtype = mkSort outtype in let pred=mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 8d60b8ba2a..04936cd835 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -228,7 +228,7 @@ let compute_ivs f cs gl = let (args3, body3) = decompose_lam body2 in let nargs3 = List.length args3 in let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let is_conv = Reductionops.is_conv env sigma in begin match decomp_term body3 with | Case(_,p,c,lci) -> (*

Case c of c1 ... cn end *) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 8ff4230e89..dbe7710eb7 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -749,7 +749,7 @@ let ltac_ring_structure e = let ring_lookup (f:glob_tactic_expr) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try (* find_ring_strucure can raise an exception *) let evdref = ref sigma in @@ -1021,7 +1021,7 @@ let ltac_field_structure e = let field_lookup (f:glob_tactic_expr) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try let evdref = ref sigma in diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 65bd325362..894b290f14 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -121,7 +121,7 @@ let unify ?(flags=fail_quick_unif_flags) m = Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in let n = Tacmach.New.pf_nf_concl gl in - let evd = clear_metas (Proofview.Goal.sigma gl) in + let evd = clear_metas (Tacmach.New.project gl) in try let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 826b4772a0..bded518e78 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -921,7 +921,7 @@ module Goal = struct let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) let env { env=env } = env - let sigma { sigma=sigma } = sigma + let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma let hyps { env=env } = Environ.named_context env let concl { concl=concl } = concl let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self @@ -1061,6 +1061,7 @@ struct let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl -> let sigma = Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in let env = Goal.env gl in let concl = Goal.concl gl in (** Save the [future_goals] state to restore them after the diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 5c97ada344..0b6c147f92 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -444,7 +444,7 @@ module Goal : sig val concl : ([ `NF ], 'r) t -> Term.constr val hyps : ([ `NF ], 'r) t -> Context.named_context val env : ('a, 'r) t -> Environ.env - val sigma : ('a, 'r) t -> Evd.evar_map + val sigma : ('a, 'r) t -> 'r Sigma.t val extra : ('a, 'r) t -> Evd.Store.t (** Returns the goal's conclusion even if the goal is not diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 8af28b6ab1..57c60cbeed 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -158,11 +158,15 @@ let pr_glls glls = (* Variants of [Tacmach] functions built with the new proof engine *) module New = struct + let project gl = + let sigma = Proofview.Goal.sigma gl in + Sigma.to_evar_map sigma + let pf_apply f gl = - f (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) + f (Proofview.Goal.env gl) (project gl) let of_old f gl = - f { Evd.it = Proofview.Goal.goal gl ; sigma = Proofview.Goal.sigma gl } + f { Evd.it = Proofview.Goal.goal gl ; sigma = project gl; } let pf_global id gl = (** We only check for the existence of an [id] in [hyps] *) @@ -216,7 +220,7 @@ module New = struct (** We normalize the conclusion just after *) let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = project gl in nf_evar sigma concl let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t @@ -235,6 +239,6 @@ module New = struct let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t let pf_compute gl t = pf_apply compute gl t - let pf_nf_evar gl t = nf_evar (Proofview.Goal.sigma gl) t + let pf_nf_evar gl t = nf_evar (project gl) t end diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 3ed6a2eeb1..c45fd250cb 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -111,6 +111,7 @@ module New : sig (** FIXME: encapsulate the level in an existential type. *) val of_old : (Proof_type.goal Evd.sigma -> 'a) -> ([ `NF ], 'r) Proofview.Goal.t -> 'a + val project : ('a, 'r) Proofview.Goal.t -> Evd.evar_map val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types diff --git a/tactics/auto.ml b/tactics/auto.ml index 4e4eafe4e5..4a520612f8 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -76,7 +76,7 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = (** [clenv] has been generated by a hint-making function, so the only relevant data in its evarmap is the set of metas. The [evar_reset_evd] function below just replaces the metas of sigma by those coming from the clenv. *) - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in (** Still, we need to update the universes *) let clenv, c = @@ -153,7 +153,7 @@ let conclPattern concl pat tac = in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in constr_bindings env sigma >>= fun constr_bindings -> Hook.get forward_interp_tactic constr_bindings tac end } @@ -322,7 +322,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let intro_tac = Tacticals.New.tclTHEN (dbg_intro dbg) ( Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in @@ -417,7 +417,7 @@ and trivial_resolve dbg mod_delta db_list local_db cl = let trivial ?(debug=Off) lems dbnames = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in let d = mk_trivial_dbg debug in let hints = make_local_hint_db env sigma false lems in @@ -428,7 +428,7 @@ let trivial ?(debug=Off) lems dbnames = let full_trivial ?(debug=Off) lems = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in let d = mk_trivial_dbg debug in let hints = make_local_hint_db env sigma false lems in @@ -459,7 +459,7 @@ let possible_resolve dbg mod_delta db_list local_db cl = let extend_local_db decl db gl = let env = Tacmach.New.pf_env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in Hint_db.add_list env sigma (make_resolve_hyp env sigma decl) db (* Introduce an hypothesis, then call the continuation tactic [kont] @@ -500,7 +500,7 @@ let default_search_depth = ref 5 let delta_auto debug mod_delta n lems dbnames = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in let d = mk_auto_dbg debug in let hints = make_local_hint_db env sigma false lems in @@ -523,7 +523,7 @@ let default_auto = auto !default_search_depth [] [] let delta_full_auto ?(debug=Off) mod_delta n lems = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in let d = mk_auto_dbg debug in let hints = make_local_hint_db env sigma false lems in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 34886d74d1..0cc74ff446 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -55,7 +55,7 @@ let filter_hyp f tac = let contradiction_context = Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rec seek_neg l = match l with | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") @@ -91,7 +91,7 @@ let is_negation_of env sigma typ t = let contradiction_term (c,lbind as cl) = Proofview.Goal.nf_enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 08502e0ccb..dbdfb3e922 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -154,8 +154,8 @@ let e_exact poly flags (c,clenv) = let rec e_trivial_fail_db db_list local_db = let next = Proofview.Goal.nf_enter { enter = begin fun gl -> let d = Tacmach.New.pf_last_hyp gl in - let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) d in - e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) hintl local_db) + let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in + e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) end } in Proofview.Goal.enter { enter = begin fun gl -> let tacl = diff --git a/tactics/elim.ml b/tactics/elim.ml index 27e96637d9..d3aa160925 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -97,7 +97,7 @@ let general_decompose recognizer c = let head_in indl t gl = let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in try let ity,_ = if !up_to_delta diff --git a/tactics/equality.ml b/tactics/equality.ml index 0c487c4e63..85bc50216e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -159,7 +159,7 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let try_occ (evd', c') = Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'} in - let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_unif_flags eqclause in + let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in let occs = w_unify_to_subterm_all ~flags env eqclause.evd ((if l2r then c1 else c2),concl) @@ -208,7 +208,7 @@ let rewrite_conv_closed_unif_flags = { let rewrite_elim with_evars frzevars cls c e = Proofview.Goal.enter { enter = begin fun gl -> - let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in + let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_conv_closed_unif_flags c in general_elim_clause with_evars flags cls c e end } @@ -276,7 +276,7 @@ let jmeq_same_dom gl = function let rels, t = decompose_prod_assum t in let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in match decompose_app t with - | _, [dom1; _; dom2;_] -> is_conv env (Proofview.Goal.sigma gl) dom1 dom2 + | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2 | _ -> false (* find_elim determines which elimination principle is necessary to @@ -317,7 +317,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = Logic.eq or Jmeq just before *) assert false in - let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + let sigma, elim = Evd.fresh_global (Global.env ()) (Tacmach.New.project gl) (ConstRef c) in sigma, elim, Declareops.no_seff else let scheme_name = match dep, lft2rgt, inccl with @@ -337,7 +337,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) let sigma, elim = - Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) + Evd.fresh_global (Global.env ()) (Tacmach.New.project gl) (ConstRef c) in sigma, elim, eff | _ -> assert false @@ -384,7 +384,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac) else Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in @@ -484,7 +484,7 @@ let general_rewrite_clause l2r with_evars ?tac c cl = let apply_special_clear_request clear_flag f = Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try let ((c, bl), sigma) = run_delayed env sigma f in @@ -496,7 +496,7 @@ let apply_special_clear_request clear_flag f = let general_multi_rewrite with_evars l cl tac = let do1 l2r f = Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in tclWITHHOLES with_evars @@ -569,9 +569,9 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let t1 = get_type_of c1 and t2 = get_type_of c2 in let evd = - if unsafe then Some (Proofview.Goal.sigma gl) + if unsafe then Some (Tacmach.New.project gl) else - try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl)) + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) with Evarconv.UnableToUnify _ -> None in match evd with @@ -965,7 +965,7 @@ let onEquality with_evars tac (c,lbindc) = let onNegatedEquality with_evars tac = Proofview.Goal.nf_enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in match kind_of_term (hnf_constr env sigma ccl) with diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index fa13234a63..e1997c7051 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -664,7 +664,7 @@ END let hget_evar n = Proofview.Goal.nf_enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evl = evar_list concl in if List.length evl < n then @@ -779,7 +779,7 @@ END let eq_constr x y = Proofview.Goal.enter { enter = begin fun gl -> - let evd = Proofview.Goal.sigma gl in + let evd = Tacmach.New.project gl in if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") end } diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 2667fa7ff9..648d68f276 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1566,7 +1566,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let ty = match clause with | None -> concl | Some id -> Environ.named_type id env @@ -2040,7 +2040,7 @@ let not_declared env ty rel = let setoid_proof ty fn fallback = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in Proofview.tclORELSE begin diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 1ea19bce09..da3ab737b6 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -633,7 +633,7 @@ let pf_interp_constr ist gl = let new_interp_constr ist c k = let open Proofview in Proofview.Goal.enter { enter = begin fun gl -> - let (sigma, c) = interp_constr ist (Goal.env gl) (Goal.sigma gl) c in + let (sigma, c) = interp_constr ist (Goal.env gl) (Tacmach.New.project gl) c in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c) end } @@ -790,11 +790,11 @@ let rec message_of_value v = Ftactic.return (str "") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) v) end + Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in Ftactic.nf_enter begin fun gl -> - Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Proofview.Goal.sigma gl) c) + Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Tacmach.New.project gl) c) end else if has_type v (topwit wit_unit) then Ftactic.return (str "()") @@ -804,16 +804,16 @@ let rec message_of_value v = let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in Ftactic.nf_enter begin fun gl -> - Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Proofview.Goal.sigma gl) c) p) + Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Tacmach.New.project gl) c) p) end else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) c) end + Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) - (Proofview.Goal.sigma gl) c) + (Tacmach.New.project gl) c) end else match Value.to_list v with | Some l -> @@ -1224,7 +1224,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | BindingsArgType | OptArgType _ | PairArgType _ -> (** generic handler *) Ftactic.nf_enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let goal = Proofview.Goal.goal gl in @@ -1233,7 +1233,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with end | _ as tag -> (** Special treatment. TODO: use generic handler *) Ftactic.nf_enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in match tag with | IntOrVarArgType -> @@ -1352,7 +1352,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let goal_sigma = Proofview.Goal.sigma gl in + let goal_sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let goal = Proofview.Goal.goal gl in let tac = Tacenv.interp_ml_tactic opn in @@ -1399,7 +1399,7 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = match arg with | TacGeneric arg -> Ftactic.nf_enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let goal = Proofview.Goal.goal gl in let (sigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} arg in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) @@ -1407,7 +1407,7 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> Ftactic.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) @@ -1427,12 +1427,12 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = interp_app loc ist fv largs | TacFreshId l -> Ftactic.enter begin fun gl -> - let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) l in + let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Tacmach.New.project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) end | TacPretype c -> Ftactic.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let {closure;term} = interp_uconstr ist env c in let vars = { @@ -1611,7 +1611,7 @@ and interp_match ist lz constr lmr = end end >>= fun constr -> Ftactic.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) @@ -1620,7 +1620,7 @@ and interp_match ist lz constr lmr = (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = Ftactic.nf_enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in let hyps = if lr then List.rev hyps else hyps in @@ -1767,7 +1767,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = end >>= fun result -> Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let result = Value.normalize result in try let cresult = coerce_to_closed_constr env result in @@ -1805,7 +1805,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacIntroPattern l -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in Tacticals.New.tclWITHHOLES false (name_atomic ~env @@ -1817,7 +1817,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacIntroMove (ido,hto) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let mloc = interp_move_location ist env sigma hto in let ido = Option.map (interp_ident ist env sigma) ido in name_atomic ~env @@ -1840,7 +1840,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let l = List.map (fun (k,c) -> let loc, f = interp_open_constr_with_bindings_loc ist c in (k,(loc,f))) cb @@ -1856,7 +1856,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacElim (ev,(keep,cb),cbo) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in let named_tac = @@ -1867,7 +1867,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacCase (ev,(keep,cb)) -> Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let named_tac = @@ -1879,7 +1879,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacFix (idopt,n) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacFix(idopt,n)) @@ -1905,7 +1905,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacCofix idopt -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacCofix (idopt)) @@ -1931,7 +1931,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacAssert (b,t,ipat,c) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let (sigma,c) = (if Option.is_empty t then interp_constr else interp_type) ist env sigma c in @@ -1944,7 +1944,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacGeneralize cl -> Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in Tacticals.New.tclWITHHOLES false @@ -1962,7 +1962,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let clp = interp_clause ist env sigma clp in let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in if Locusops.is_nowhere clp then @@ -2005,7 +2005,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end; Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let lems = interp_auto_lemmas ist env sigma lems in name_atomic ~env (TacTrivial(debug,List.map snd lems,l)) @@ -2022,7 +2022,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end; Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let lems = interp_auto_lemmas ist env sigma lems in name_atomic ~env (TacAuto(debug,n,List.map snd lems,l)) @@ -2038,7 +2038,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let sigma,l = List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> (* TODO: move sigma as a side-effect *) @@ -2071,7 +2071,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacClear (b,l) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let l = interp_hyp_list ist env sigma l in if b then name_atomic ~env (TacClear (b, l)) (Tactics.keep l) else @@ -2082,7 +2082,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacClearBody l -> Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let l = interp_hyp_list ist env sigma l in name_atomic ~env (TacClearBody l) @@ -2097,7 +2097,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacRename l -> Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let l = List.map (fun (id1,id2) -> interp_hyp ist env sigma id1, @@ -2112,7 +2112,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacSplit (ev,bll) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in let named_tac = let tac = Tactics.split_with_bindings ev bll in @@ -2165,7 +2165,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.nf_evar_goals <*> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in Proofview.V82.tactic begin fun gl -> let (sigma,sign,op) = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in @@ -2189,7 +2189,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacSymmetry c -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let cl = interp_clause ist env sigma c in name_atomic ~env (TacSymmetry cl) @@ -2207,7 +2207,7 @@ and interp_atomic ist tac : unit Proofview.tactic = } in (b,m,keep,f)) l in let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let cl = interp_clause ist env sigma cl in name_atomic ~env (TacRewrite (ev,l,cl,by)) @@ -2219,7 +2219,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (DepInversion (k,c,ids),hyp) -> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let (sigma,c_interp) = match c with | None -> sigma , None @@ -2239,7 +2239,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let hyps = interp_hyp_list ist env sigma idl in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in @@ -2251,7 +2251,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (InversionUsing (c,idl),hyp) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in @@ -2413,7 +2413,7 @@ let dummy_id = Id.of_string "_" let lift_constr_tac_to_ml_tac vars tac = let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let map = function | None -> None | Some id -> diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index c67053252b..bdbc0aa21f 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -696,7 +696,7 @@ module New = struct let pf_constr_of_global ref tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let (sigma, c) = Evd.fresh_global env sigma ref in Proofview.Unsafe.tclEVARS sigma <*> (tac c) end } diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 66053a314e..94e334914c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -187,7 +187,7 @@ let introduction ?(check=true) id = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let hyps = Proofview.Goal.hyps gl in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in @@ -226,7 +226,7 @@ let convert_concl ?(check=true) ty k = let convert_hyp ?(check=true) d = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in @@ -401,7 +401,7 @@ let find_name mayrepl decl naming gl = match naming with | NamingAvoid idl -> (* this case must be compatible with [find_intro_names] below. *) let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in new_fresh_id idl (default_id env sigma decl) gl | NamingBasedOn (id,idl) -> new_fresh_id idl id gl | NamingMustBe (loc,id) -> @@ -785,7 +785,7 @@ let build_intro_tac id dest tac = match dest with let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - let concl = nf_evar (Proofview.Goal.sigma gl) concl in + let concl = nf_evar (Tacmach.New.project gl) concl in match kind_of_term concl with | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) -> let name = find_name false (name,None,t) name_flag gl in @@ -999,7 +999,7 @@ let onOpenInductionArg env sigma tac = function (Tacticals.New.onLastHyp (fun c -> Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let pending = (sigma,sigma) in tac clear_flag (pending,(c,NoBindings)) end })) @@ -1008,7 +1008,7 @@ let onOpenInductionArg env sigma tac = function Tacticals.New.tclTHEN (try_intros_until_id_check id) (Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let pending = (sigma,sigma) in tac clear_flag (pending,(mkVar id,NoBindings)) end }) @@ -1038,7 +1038,7 @@ let map_induction_arg f = function let cut c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_nf_concl gl in let is_sort = try @@ -1173,7 +1173,7 @@ let enforce_prop_bound_names rename tac = let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in change_concl (aux env sigma i t) end } in @@ -1193,7 +1193,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags rename i (elim, elimty, bindings) indclause = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = @@ -1223,7 +1223,7 @@ type eliminator = { let general_elim_clause_gen elimtac indclause elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in let elimt = Retyping.get_type_of env sigma elimc in let i = @@ -1234,7 +1234,7 @@ let general_elim_clause_gen elimtac indclause elim = let general_elim with_evars clear_flag (c, lbindc) elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in @@ -1351,7 +1351,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id rename i (elim, elimty, bindings) indclause = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = destMeta (nth_arg i elimclause.templval.rebus) in @@ -1429,7 +1429,7 @@ let make_projection env sigma params cstr sign elim i n c u = let descend_in_conjunctions avoid tac (err, info) c = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in try let t = Retyping.get_type_of env sigma c in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in @@ -1450,7 +1450,7 @@ let descend_in_conjunctions avoid tac (err, info) c = (List.init n (fun i -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in match make_projection env sigma params cstr sign elim i n c u with | None -> Tacticals.New.tclFAIL 0 (mt()) | Some (p,pt) -> @@ -1506,7 +1506,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let rec try_main_apply with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = @@ -1578,7 +1578,7 @@ let rec apply_with_bindings_gen b e = function let apply_with_delayed_bindings_gen b e l = let one k (loc, f) = Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (cb, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES e @@ -1648,7 +1648,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let flags = if with_delta then default_unify_flags () else default_no_delta_unify_flags () in let t' = Tacmach.New.pf_get_hyp_typ id gl in @@ -1657,7 +1657,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in try let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause @@ -1681,7 +1681,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam id (clear_flag,(loc,f)) tac = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let (c, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars @@ -1768,7 +1768,7 @@ let assumption = else Tacticals.New.tclZEROMSG (str "No such assumption.") | (id, c, t)::rest -> let concl = Proofview.Goal.concl gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = if only_eq then (sigma, Constr.equal t concl) else @@ -2244,7 +2244,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with else Proofview.V82.tactic (clear [id]) in Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in Tacticals.New.tclWITHHOLES false @@ -3677,7 +3677,7 @@ let guess_elim isrec dep s hyp0 gl = let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in - Proofview.Goal.sigma gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess + Tacmach.New.project gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess type scheme_signature = (Id.t list * (elim_arg_kind * bool * Id.t) list) array @@ -3722,7 +3722,7 @@ let is_functional_induction elimc gl = let get_eliminator elim dep s gl = match elim with | ElimUsing (elim,indsign) -> - Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign + Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in @@ -4023,7 +4023,7 @@ let induction_gen clear_flag isrec with_evars elim | _ -> [] in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in let sigma = Sigma.Unsafe.of_evar_map sigma in @@ -4112,7 +4112,7 @@ let induction_destruct isrec with_evars (lc,elim) = | [c,(eqname,names as allnames),cls] -> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in match elim with | Some elim when is_functional_induction elim gl -> (* Standard induction on non-standard induction schemes *) @@ -4139,7 +4139,7 @@ let induction_destruct isrec with_evars (lc,elim) = | _ -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in match elim with | None -> (* Several arguments, without "using" clause *) @@ -4155,7 +4155,7 @@ let induction_destruct isrec with_evars (lc,elim) = (Tacticals.New.tclMAP (fun (a,b,cl) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in onOpenInductionArg env sigma (fun clear_flag a -> induction_gen clear_flag false with_evars None (a,b) cl) a end }) l) @@ -4267,7 +4267,7 @@ let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make () let maybe_betadeltaiota_concl allowred gl = let concl = Tacmach.New.pf_nf_concl gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in if not allowred then concl else let env = Proofview.Goal.env gl in @@ -4401,7 +4401,7 @@ let prove_transitivity hdcncl eq_kind t = mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]) | HeterogenousEq (typ1,c1,typ2,c2) -> let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in + let sigma = Tacmach.New.project gl in let type_of = Typing.unsafe_type_of env sigma in let typt = type_of t in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), -- cgit v1.2.3 From a1b828d31c73d3342345243e9fb4af69610616a0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 20 Oct 2015 18:15:04 +0200 Subject: Fix lemma-overloading Update the evar_source of the solution evar in evar/evar problems to propagate the information that it does not necessarily have to be solved in Program mode. --- pretyping/evarsolve.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index b384bdfe16..f06207c3b9 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1149,10 +1149,19 @@ let check_evar_instance evd evk1 body conv_algo = | Success evd -> evd | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) +let update_evar_source ev1 ev2 evd = + let loc, evs2 = evar_source ev2 evd in + match evs2 with + | (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) -> + let evi = Evd.find evd ev1 in + Evd.add evd ev1 {evi with evar_source = loc, evs2} + | _ -> evd + let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in let evd' = Evd.define evk2 body evd in + let evd' = update_evar_source (fst (destEvar body)) evk2 evd' in check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1164,8 +1173,8 @@ let preferred_orientation evd evk1 evk2 = let _,src2 = (Evd.find_undefined evd evk2).evar_source in (* This is a heuristic useful for program to work *) match src1,src2 with - | Evar_kinds.QuestionMark _, _ -> true - | _,Evar_kinds.QuestionMark _ -> false + | (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) , _ -> true + | _, (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) -> false | _ -> true let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = -- cgit v1.2.3 From ae7e8f8f66359a46e165e1eae6cf15eb09fd66de Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Wed, 21 Oct 2015 10:59:36 +0200 Subject: Fixed (and changed) infoH. The detection of new hypothesis was bugged. Now infoH behaves like "Show Intros": it performs tac, grab information on hypothesis names but let the state unchanged. FTR: infoH is fundamentally unable to be correct in presence of tactics that delete hypothesis and reuse there names. Like destruct or induction. Fortunately destruct and induction now come with a variant asking that the hypothesis is not deleted. To guess for the right as-close for [induction H], do [infoH induction !H]. This will not create the same names as induction would have by itself but at least there will be the right number of hypothesis. --- proofs/refiner.ml | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 974fa212f1..ba62b2cb2d 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -186,10 +186,15 @@ let tclNOTSAMEGOAL (tac : tactic) goal = (str"Tactic generated a subgoal identical to the original goal.") else rslt -(* Execute tac and show the names of hypothesis create by tac in - the "as" format. The resulting goals are printed *after* the - as-expression, which forces pg to some gymnastic. TODO: Have - something similar (better?) in the xml protocol. *) +(* Execute tac, show the names of new hypothesis names created by tac + in the "as" format and then forget everything. From the logical + point of view [tclSHOWHYPS tac] is therefore equivalent to idtac, + except that it takes the time and memory of tac and prints "as" + information). The resulting (unchanged) goals are printed *after* + the as-expression, which forces pg to some gymnastic. + TODO: Have something similar (better?) in the xml protocol. + NOTE: some tactics delete hypothesis and reuse names (induction, + destruct), this is not detected by this tactical. *) let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) :Proof_type.goal list Evd.sigma = let oldhyps:Context.named_context = pf_hyps goal in @@ -197,9 +202,10 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) let { it = gls; sigma = sigma; } = rslt in let hyps:Context.named_context list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in + let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in let newhyps = List.map - (fun hypl -> List.subtract Context.eq_named_declaration hypl oldhyps) + (fun hypl -> List.subtract cmp hypl oldhyps) hyps in let emacs_str s = @@ -215,7 +221,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) pp (str (emacs_str "") ++ (hov 0 (str s)) ++ (str (emacs_str "")) ++ fnl()); - rslt;; + tclIDTAC goal;; let catch_failerror (e, info) = -- cgit v1.2.3 From de2031b8fa2a7e236d734500294ebd5050fcb7d5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 11:56:37 +0200 Subject: Removing test for bug #3956. It breaks test-suite of trunk since Matthieu's fixes for the soundness of polymorphic universes, and I am unsure of the expected semantics. We should reintroduce it later on when we understand better the issue of simply fix it once and for all. --- test-suite/bugs/opened/3956.v | 141 ------------------------------------------ 1 file changed, 141 deletions(-) delete mode 100644 test-suite/bugs/opened/3956.v diff --git a/test-suite/bugs/opened/3956.v b/test-suite/bugs/opened/3956.v deleted file mode 100644 index 94c0c6744c..0000000000 --- a/test-suite/bugs/opened/3956.v +++ /dev/null @@ -1,141 +0,0 @@ -(* -*- mode: coq; mode: visual-line -*- *) -Set Universe Polymorphism. -Set Primitive Projections. -Close Scope nat_scope. - -Record prod (A B : Type) := pair { fst : A ; snd : B }. -Arguments pair {A B} _ _. -Arguments fst {A B} _ / . -Arguments snd {A B} _ / . -Notation "x * y" := (prod x y) : type_scope. -Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. - -Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. -Definition Type2 := Eval hnf in let gt := (Type1 : Type@{i}) in Type@{i}. - -Inductive paths {A : Type} (a : A) : A -> Type := - idpath : paths a a. -Arguments idpath {A a} , [A] a. -Notation "x = y" := (@paths _ x y) : type_scope. -Definition concat {A} {x y z : A} (p : x = y) (q : y = z) : x = z - := match p, q with idpath, idpath => idpath end. - -Definition path_prod {A B : Type} (z z' : A * B) -: (fst z = fst z') -> (snd z = snd z') -> (z = z'). -Proof. - destruct z, z'; simpl; intros [] []; reflexivity. -Defined. - -Module Type TypeM. - Parameter m : Type2. -End TypeM. - -Module ProdM (XM : TypeM) (YM : TypeM) <: TypeM. - Definition m := XM.m * YM.m. -End ProdM. - -Module Type FunctionM (XM YM : TypeM). - Parameter m : XM.m -> YM.m. -End FunctionM. - -Module IdmapM (XM : TypeM) <: FunctionM XM XM. - Definition m := (fun x => x) : XM.m -> XM.m. -End IdmapM. - -Module Type HomotopyM (XM YM : TypeM) (fM gM : FunctionM XM YM). - Parameter m : forall x, fM.m x = gM.m x. -End HomotopyM. - -Module ComposeM (XM YM ZM : TypeM) - (gM : FunctionM YM ZM) (fM : FunctionM XM YM) - <: FunctionM XM ZM. - Definition m := (fun x => gM.m (fM.m x)). -End ComposeM. - -Module Type CorecM (YM ZM : TypeM) (fM : FunctionM YM ZM) - (XM : TypeM) (gM : FunctionM XM ZM). - Parameter m : XM.m -> YM.m. - Parameter m_beta : forall x, fM.m (m x) = gM.m x. -End CorecM. - -Module Type CoindpathsM (YM ZM : TypeM) (fM : FunctionM YM ZM) - (XM : TypeM) (hM kM : FunctionM XM YM). - Module fhM := ComposeM XM YM ZM fM hM. - Module fkM := ComposeM XM YM ZM fM kM. - Declare Module mM (pM : HomotopyM XM ZM fhM fkM) - : HomotopyM XM YM hM kM. -End CoindpathsM. - -Module Type Comodality (XM : TypeM). - Parameter m : Type2. - Module mM <: TypeM. - Definition m := m. - End mM. - Parameter from : m -> XM.m. - Module fromM <: FunctionM mM XM. - Definition m := from. - End fromM. - Declare Module corecM : CorecM mM XM fromM. - Declare Module coindpathsM : CoindpathsM mM XM fromM. -End Comodality. - -Module Comodality_Theory (F : Comodality). - - Module F_functor_M (XM YM : TypeM) (fM : FunctionM XM YM) - (FXM : Comodality XM) (FYM : Comodality YM). - Module f_o_from_M <: FunctionM FXM.mM YM. - Definition m := fun x => fM.m (FXM.from x). - End f_o_from_M. - Module mM := FYM.corecM FXM.mM f_o_from_M. - Definition m := mM.m. - End F_functor_M. - - Module F_prod_cmp_M (XM YM : TypeM) - (FXM : Comodality XM) (FYM : Comodality YM). - Module PM := ProdM XM YM. - Module PFM := ProdM FXM FYM. - Module fstM <: FunctionM PM XM. - Definition m := @fst XM.m YM.m. - End fstM. - Module sndM <: FunctionM PM YM. - Definition m := @snd XM.m YM.m. - End sndM. - Module FPM := F PM. - Module FfstM := F_functor_M PM XM fstM FPM FXM. - Module FsndM := F_functor_M PM YM sndM FPM FYM. - Definition m : FPM.m -> PFM.m - := fun z => (FfstM.m z , FsndM.m z). - End F_prod_cmp_M. - - Module isequiv_F_prod_cmp_M - (XM YM : TypeM) - (FXM : Comodality XM) (FYM : Comodality YM). - (** The comparison map *) - Module cmpM := F_prod_cmp_M XM YM FXM FYM. - Module FPM := cmpM.FPM. - (** We construct an inverse to it using corecursion. *) - Module prod_from_M <: FunctionM cmpM.PFM cmpM.PM. - Definition m : cmpM.PFM.m -> cmpM.PM.m - := fun z => ( FXM.from (fst z) , FYM.from (snd z) ). - End prod_from_M. - Module cmpinvM <: FunctionM cmpM.PFM FPM - := FPM.corecM cmpM.PFM prod_from_M. - (** We prove the first homotopy *) - Module cmpinv_o_cmp_M <: FunctionM FPM FPM - := ComposeM FPM cmpM.PFM FPM cmpinvM cmpM. - Module idmap_FPM <: FunctionM FPM FPM - := IdmapM FPM. - Module cip_FPM := FPM.coindpathsM FPM cmpinv_o_cmp_M idmap_FPM. - Module cip_FPHM <: HomotopyM FPM cmpM.PM cip_FPM.fhM cip_FPM.fkM. - Definition m : forall x, cip_FPM.fhM.m@{i j} x = cip_FPM.fkM.m@{i j} x. - Proof. - intros x. - refine (concat (cmpinvM.m_beta@{i j} (cmpM.m@{i j} x)) _). - apply path_prod@{i i i}; simpl. - - exact (cmpM.FfstM.mM.m_beta@{i j} x). - - exact (cmpM.FsndM.mM.m_beta@{i j} x). - Defined. - Fail End cip_FPHM. -(* End isequiv_F_prod_cmp_M. - -End Comodality_Theory.*) -- cgit v1.2.3 From 05be0a2eee49174c92f355edbdc0ffa6b44f0fac Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 21 Oct 2015 12:42:29 +0200 Subject: Bug #3956 is fixed. --- test-suite/bugs/closed/3956.v | 143 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 143 insertions(+) create mode 100644 test-suite/bugs/closed/3956.v diff --git a/test-suite/bugs/closed/3956.v b/test-suite/bugs/closed/3956.v new file mode 100644 index 0000000000..c19a2d4a06 --- /dev/null +++ b/test-suite/bugs/closed/3956.v @@ -0,0 +1,143 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter"); mode: visual-line -*- *) +Set Universe Polymorphism. +Set Primitive Projections. +Close Scope nat_scope. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Arguments pair {A B} _ _. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +Unset Strict Universe Declaration. + +Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. +Definition Type2 := Eval hnf in let gt := (Type1 : Type@{i}) in Type@{i}. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition concat {A} {x y z : A} (p : x = y) (q : y = z) : x = z + := match p, q with idpath, idpath => idpath end. + +Definition path_prod {A B : Type} (z z' : A * B) +: (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Proof. + destruct z, z'; simpl; intros [] []; reflexivity. +Defined. + +Module Type TypeM. + Parameter m : Type2. +End TypeM. + +Module ProdM (XM : TypeM) (YM : TypeM) <: TypeM. + Definition m := XM.m * YM.m. +End ProdM. + +Module Type FunctionM (XM YM : TypeM). + Parameter m : XM.m -> YM.m. +End FunctionM. + +Module IdmapM (XM : TypeM) <: FunctionM XM XM. + Definition m := (fun x => x) : XM.m -> XM.m. +End IdmapM. + +Module Type HomotopyM (XM YM : TypeM) (fM gM : FunctionM XM YM). + Parameter m : forall x, fM.m x = gM.m x. +End HomotopyM. + +Module ComposeM (XM YM ZM : TypeM) + (gM : FunctionM YM ZM) (fM : FunctionM XM YM) + <: FunctionM XM ZM. + Definition m := (fun x => gM.m (fM.m x)). +End ComposeM. + +Module Type CorecM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (gM : FunctionM XM ZM). + Parameter m : XM.m -> YM.m. + Parameter m_beta : forall x, fM.m (m x) = gM.m x. +End CorecM. + +Module Type CoindpathsM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (hM kM : FunctionM XM YM). + Module fhM := ComposeM XM YM ZM fM hM. + Module fkM := ComposeM XM YM ZM fM kM. + Declare Module mM (pM : HomotopyM XM ZM fhM fkM) + : HomotopyM XM YM hM kM. +End CoindpathsM. + +Module Type Comodality (XM : TypeM). + Parameter m : Type2. + Module mM <: TypeM. + Definition m := m. + End mM. + Parameter from : m -> XM.m. + Module fromM <: FunctionM mM XM. + Definition m := from. + End fromM. + Declare Module corecM : CorecM mM XM fromM. + Declare Module coindpathsM : CoindpathsM mM XM fromM. +End Comodality. + +Module Comodality_Theory (F : Comodality). + + Module F_functor_M (XM YM : TypeM) (fM : FunctionM XM YM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module f_o_from_M <: FunctionM FXM.mM YM. + Definition m := fun x => fM.m (FXM.from x). + End f_o_from_M. + Module mM := FYM.corecM FXM.mM f_o_from_M. + Definition m := mM.m. + End F_functor_M. + + Module F_prod_cmp_M (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module PM := ProdM XM YM. + Module PFM := ProdM FXM FYM. + Module fstM <: FunctionM PM XM. + Definition m := @fst XM.m YM.m. + End fstM. + Module sndM <: FunctionM PM YM. + Definition m := @snd XM.m YM.m. + End sndM. + Module FPM := F PM. + Module FfstM := F_functor_M PM XM fstM FPM FXM. + Module FsndM := F_functor_M PM YM sndM FPM FYM. + Definition m : FPM.m -> PFM.m + := fun z => (FfstM.m z , FsndM.m z). + End F_prod_cmp_M. + + Module isequiv_F_prod_cmp_M + (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + (** The comparison map *) + Module cmpM := F_prod_cmp_M XM YM FXM FYM. + Module FPM := cmpM.FPM. + (** We construct an inverse to it using corecursion. *) + Module prod_from_M <: FunctionM cmpM.PFM cmpM.PM. + Definition m : cmpM.PFM.m -> cmpM.PM.m + := fun z => ( FXM.from (fst z) , FYM.from (snd z) ). + End prod_from_M. + Module cmpinvM <: FunctionM cmpM.PFM FPM + := FPM.corecM cmpM.PFM prod_from_M. + (** We prove the first homotopy *) + Module cmpinv_o_cmp_M <: FunctionM FPM FPM + := ComposeM FPM cmpM.PFM FPM cmpinvM cmpM. + Module idmap_FPM <: FunctionM FPM FPM + := IdmapM FPM. + Module cip_FPM := FPM.coindpathsM FPM cmpinv_o_cmp_M idmap_FPM. + Module cip_FPHM <: HomotopyM FPM cmpM.PM cip_FPM.fhM cip_FPM.fkM. + Definition m : forall x, cip_FPM.fhM.m@{i j} x = cip_FPM.fkM.m@{i j} x. + Proof. + intros x. + refine (concat (cmpinvM.m_beta@{i j} (cmpM.m@{i j} x)) _). + apply path_prod@{i i i}; simpl. + - exact (cmpM.FfstM.mM.m_beta@{i j} x). + - exact (cmpM.FsndM.mM.m_beta@{i j} x). + Defined. + End cip_FPHM. + End isequiv_F_prod_cmp_M. + +End Comodality_Theory. \ No newline at end of file -- cgit v1.2.3 From 426ba79b270299f64a4498187adad717760d11bc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 12:50:38 +0200 Subject: Expliciting some uses of Compat module. --- parsing/lexer.ml4 | 11 +++++------ parsing/pcoq.mli | 3 +-- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index c6d5f3b925..23bd74da95 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -8,7 +8,6 @@ open Pp open Util -open Compat open Tok (* Dictionaries: trees annotated with string options, each node being a map @@ -565,7 +564,7 @@ let loct_add loct i loc = Hashtbl.add loct i loc let current_location_table = ref (loct_create ()) -type location_table = (int, CompatLoc.t) Hashtbl.t +type location_table = (int, Compat.CompatLoc.t) Hashtbl.t let location_table () = !current_location_table let restore_location_table t = current_location_table := t @@ -602,7 +601,7 @@ let func cs = Stream.from (fun i -> let (tok, loc) = next_token cs in - loct_add loct i (make_loc loc); Some tok) + loct_add loct i (Compat.make_loc loc); Some tok) in current_location_table := loct; (ts, loct_func loct) @@ -622,10 +621,10 @@ ELSE (* official camlp4 for ocaml >= 3.10 *) module M_ = Camlp4.ErrorHandler.Register (Error) -module Loc = CompatLoc +module Loc = Compat.CompatLoc module Token = struct include Tok (* Cf. tok.ml *) - module Loc = CompatLoc + module Loc = Compat.CompatLoc module Error = Camlp4.Struct.EmptyError module Filter = struct type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t @@ -643,7 +642,7 @@ let mk () _init_loc(*FIXME*) cs = let rec self = parser i [< (tok, loc) = next_token; s >] -> - let loc = make_loc loc in + let loc = Compat.make_loc loc in loct_add loct i loc; [< '(tok, loc); self s >] | [< >] -> [< >] diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 2146ad964f..6e9cf263f2 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -14,13 +14,12 @@ open Genarg open Constrexpr open Tacexpr open Libnames -open Compat open Misctypes open Genredexpr (** The parser of Coq *) -module Gram : GrammarSig +module Gram : Compat.GrammarSig (** The parser of Coq is built from three kinds of rule declarations: -- cgit v1.2.3 From 95b04506542064fbda7a61c4b6ce276a668d25bd Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 21 Oct 2015 16:40:51 +0200 Subject: Mention bug 3199 fix as a source of incompatibilities. --- CHANGES | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES b/CHANGES index 9f46131363..cf0f4446f4 100644 --- a/CHANGES +++ b/CHANGES @@ -33,6 +33,9 @@ Tactics already do. - Importing Program no longer overrides the "exists" tactic (potential source of incompatibilities). +- Hints costs are now correctly taken into account (potential source of + incompatibilities). + API -- cgit v1.2.3 From 0935b4565a8c1760570d0037b8b4cff745c3885c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 14:55:12 +0200 Subject: Removing the dependencies of Pcoq in IFDEF macros. --- parsing/compat.ml4 | 71 ++++++++++++++++++++++++++++++++++++++++ parsing/pcoq.ml4 | 95 ++++++++++++++++++++---------------------------------- 2 files changed, 106 insertions(+), 60 deletions(-) diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index eba1d2b8f0..4208fd364e 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -238,6 +238,69 @@ end END +(** Some definitions are grammar-specific in Camlp4, so we use a functor to + depend on it while taking a dummy argument in Camlp5. *) + +module GramextMake (G : GrammarSig) : +sig + val stoken : Tok.t -> G.symbol + val sself : G.symbol + val snext : G.symbol + val slist0 : G.symbol -> G.symbol + val slist0sep : G.symbol * G.symbol -> G.symbol + val slist1 : G.symbol -> G.symbol + val slist1sep : G.symbol * G.symbol -> G.symbol + val sopt : G.symbol -> G.symbol + val snterml : G.internal_entry * string -> G.symbol + val snterm : G.internal_entry -> G.symbol + val snterml_level : G.symbol -> string +end = +struct + +IFDEF CAMLP5 THEN + let stoken tok = + let pattern = match tok with + | Tok.KEYWORD s -> "", s + | Tok.IDENT s -> "IDENT", s + | Tok.METAIDENT s -> "METAIDENT", s + | Tok.PATTERNIDENT s -> "PATTERNIDENT", s + | Tok.FIELD s -> "FIELD", s + | Tok.INT s -> "INT", s + | Tok.STRING s -> "STRING", s + | Tok.LEFTQMARK -> "LEFTQMARK", "" + | Tok.BULLET s -> "BULLET", s + | Tok.EOI -> "EOI", "" + in + Gramext.Stoken pattern +ELSE + module Gramext = G + let stoken tok = match tok with + | Tok.KEYWORD s -> Gramext.Skeyword s + | tok -> Gramext.Stoken ((=) tok, G.Token.to_string tok) +END + +IFDEF CAMLP5_6_00 THEN + let slist0sep (x, y) = Gramext.Slist0sep (x, y, false) + let slist1sep (x, y) = Gramext.Slist1sep (x, y, false) +ELSE + let slist0sep (x, y) = Gramext.Slist0sep (x, y) + let slist1sep (x, y) = Gramext.Slist1sep (x, y) +END + + let snterml (x, y) = Gramext.Snterml (x, y) + let snterm x = Gramext.Snterm x + let sself = Gramext.Sself + let snext = Gramext.Snext + let slist0 x = Gramext.Slist0 x + let slist1 x = Gramext.Slist1 x + let sopt x = Gramext.Sopt x + + let snterml_level = function + | Gramext.Snterml (_, l) -> l + | _ -> failwith "snterml_level" + +end + (** Misc functional adjustments *) @@ -323,3 +386,11 @@ let qualified_name loc path name = let path = List.fold_right fold path (Ast.IdLid (loc, name)) in Ast.ExId (loc, path) END + +IFDEF CAMLP5 THEN +let warning_verbose = Gramext.warning_verbose +ELSE +(* TODO: this is a workaround, since there isn't such + [warning_verbose] in new camlp4. *) +let warning_verbose = ref true +END diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 2e47e07a36..ff50eb5c70 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -20,37 +20,11 @@ open Tok (* necessary for camlp4 *) module G = GrammarMake (Lexer) -(* TODO: this is a workaround, since there isn't such - [warning_verbose] in new camlp4. In camlp5, this ref - gets hidden by [Gramext.warning_verbose] *) -let warning_verbose = ref true - -IFDEF CAMLP5 THEN -open Gramext -ELSE -open PcamlSig.Grammar -open G -END - -(** Compatibility with Camlp5 6.x *) - -IFDEF CAMLP5_6_00 THEN -let slist0sep x y = Slist0sep (x, y, false) -let slist1sep x y = Slist1sep (x, y, false) -ELSE -let slist0sep x y = Slist0sep (x, y) -let slist1sep x y = Slist1sep (x, y) -END - -let gram_token_of_token tok = -IFDEF CAMLP5 THEN - Stoken (Tok.to_pattern tok) -ELSE - match tok with - | KEYWORD s -> Skeyword s - | tok -> Stoken ((=) tok, to_string tok) -END +let warning_verbose = Compat.warning_verbose +module Symbols = GramextMake(G) + +let gram_token_of_token = Symbols.stoken let gram_token_of_string s = gram_token_of_token (Lexer.terminal s) let camlp4_verbosity silent f x = @@ -158,7 +132,10 @@ let grammar_delete e reinit (pos,rls) = (List.rev rls); match reinit with | Some (a,ext) -> - let lev = match pos with Some (Level n) -> n | _ -> assert false in + let lev = match Option.map Compat.to_coq_position pos with + | Some (Level n) -> n + | _ -> assert false + in maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]]) | None -> () @@ -679,56 +656,56 @@ let make_sep_rules tkl = let rec symbol_of_constr_prod_entry_key assoc from forpat typ = if is_binder_level from typ then if forpat then - Snterml (Gram.Entry.obj Constr.pattern,"200") + Symbols.snterml (Gram.Entry.obj Constr.pattern,"200") else - Snterml (Gram.Entry.obj Constr.operconstr,"200") + Symbols.snterml (Gram.Entry.obj Constr.operconstr,"200") else if is_self from typ then - Sself + Symbols.sself else match typ with | ETConstrList (typ',[]) -> - Slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) + Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) | ETConstrList (typ',tkl) -> - slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) - (make_sep_rules tkl) + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'), + make_sep_rules tkl) | ETBinderList (false,[]) -> - Slist1 + Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) | ETBinderList (false,tkl) -> - slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) - (make_sep_rules tkl) + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false), + make_sep_rules tkl) | _ -> match interp_constr_prod_entry_key assoc from forpat typ with - | (eobj,None,_) -> Snterm (Gram.Entry.obj eobj) - | (eobj,Some None,_) -> Snext + | (eobj,None,_) -> Symbols.snterm (Gram.Entry.obj eobj) + | (eobj,Some None,_) -> Symbols.snext | (eobj,Some (Some (lev,cur)),_) -> - Snterml (Gram.Entry.obj eobj,constr_level lev) + Symbols.snterml (Gram.Entry.obj eobj,constr_level lev) (** Binding general entry keys to symbol *) let rec symbol_of_prod_entry_key = function - | Alist1 s -> Slist1 (symbol_of_prod_entry_key s) + | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> - slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string sep) - | Alist0 s -> Slist0 (symbol_of_prod_entry_key s) + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) | Alist0sep (s,sep) -> - slist0sep (symbol_of_prod_entry_key s) (gram_token_of_string sep) - | Aopt s -> Sopt (symbol_of_prod_entry_key s) + Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) | Amodifiers s -> Gram.srules' [([], Gram.action (fun _loc -> [])); ([gram_token_of_string "("; - slist1sep (symbol_of_prod_entry_key s) (gram_token_of_string ","); + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); gram_token_of_string ")"], Gram.action (fun _ l _ _loc -> l))] - | Aself -> Sself - | Anext -> Snext - | Atactic 5 -> Snterm (Gram.Entry.obj Tactic.binder_tactic) + | Aself -> Symbols.sself + | Anext -> Symbols.snext + | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) | Atactic n -> - Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) + Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) | Agram s -> let e = try @@ -742,14 +719,12 @@ let rec symbol_of_prod_entry_key = function with Not_found -> Errors.anomaly (str "Unregistered grammar entry: " ++ str s) in - Snterm (Gram.Entry.obj (object_of_typed_entry e)) + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) | Aentry (u,s) -> let e = get_entry (get_univ u) s in - Snterm (Gram.Entry.obj (object_of_typed_entry e)) + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) -let level_of_snterml = function - | Snterml (_,l) -> int_of_string l - | _ -> failwith "level_of_snterml" +let level_of_snterml e = int_of_string (Symbols.snterml_level e) (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) -- cgit v1.2.3 From 9d9b91f683cb698e7d6cdf97dc60cc89735a6597 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 17:19:16 +0200 Subject: Expanding the grammar extensions of Pcoq. --- parsing/pcoq.ml4 | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index ff50eb5c70..48dc1372ce 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -192,22 +192,22 @@ let rec remove_grammars n = redo(); camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) +let make_rule r = [None, None, r] + (** An entry that checks we reached the end of the input. *) let eoi_entry en = let e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in - GEXTEND Gram - e: [ [ x = en; EOI -> x ] ] - ; - END; + let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in + let act = Gram.action (fun _ x loc -> x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); e let map_entry f en = let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in - GEXTEND Gram - e: [ [ x = en -> f x ] ] - ; - END; + let symbs = [Symbols.snterm (Gram.Entry.obj en)] in + let act = Gram.action (fun x loc -> f x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); e (* Parse a string, does NOT check if the entire string was read @@ -397,11 +397,14 @@ module Vernac_ = (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" - GEXTEND Gram - main_entry: - [ [ a = vernac -> Some (!@loc, a) | EOI -> None ] ] - ; - END + let () = + let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in + let act_eoi = Gram.action (fun _ loc -> None) in + let rule = [ + ([ Symbols.stoken Tok.EOI ], act_eoi); + ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac ); + ] in + maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) end -- cgit v1.2.3 From 513344627bbdf4d822ca93156d2e2943408ec50d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 17:42:00 +0200 Subject: Turn Pcoq into a regular ML file. --- parsing/pcoq.ml | 814 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ parsing/pcoq.ml4 | 814 ------------------------------------------------------- 2 files changed, 814 insertions(+), 814 deletions(-) create mode 100644 parsing/pcoq.ml delete mode 100644 parsing/pcoq.ml4 diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml new file mode 100644 index 0000000000..48dc1372ce --- /dev/null +++ b/parsing/pcoq.ml @@ -0,0 +1,814 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* grammar_object G.entry +end + +module Gramobj : Gramobj = +struct + type grammar_object = Obj.t + let weaken_entry e = Obj.magic e +end + +(** Grammar entries with associated types *) + +type entry_type = argument_type +type grammar_object = Gramobj.grammar_object +type typed_entry = argument_type * grammar_object G.entry +let in_typed_entry t e = (t,Gramobj.weaken_entry e) +let type_of_typed_entry (t,e) = t +let object_of_typed_entry (t,e) = e +let weaken_entry x = Gramobj.weaken_entry x + +module type Gramtypes = +sig + val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry + val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry +end + +module Gramtypes : Gramtypes = +struct + let inGramObj rawwit = in_typed_entry (unquote rawwit) + let outGramObj (a:'a raw_abstract_argument_type) o = + if not (argument_type_eq (type_of_typed_entry o) (unquote a)) + then anomaly ~label:"outGramObj" (str "wrong type"); + (* downcast from grammar_object *) + Obj.magic (object_of_typed_entry o) +end + +open Gramtypes + +(** Grammar extensions *) + +(** NB: [extend_statment = + gram_position option * single_extend_statment list] + and [single_extend_statment = + string option * gram_assoc option * production_rule list] + and [production_rule = symbol list * action] + + In [single_extend_statement], first two parameters are name and + assoc iff a level is created *) + +(** Type of reinitialization data *) +type gram_reinit = gram_assoc * gram_position + +type ext_kind = + | ByGrammar of + grammar_object G.entry + * gram_reinit option (** for reinitialization if ever needed *) + * G.extend_statment + | ByEXTEND of (unit -> unit) * (unit -> unit) + +(** The list of extensions *) + +let camlp4_state = ref [] + +(** Deletion *) + +let grammar_delete e reinit (pos,rls) = + List.iter + (fun (n,ass,lev) -> + List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) + (List.rev rls); + match reinit with + | Some (a,ext) -> + let lev = match Option.map Compat.to_coq_position pos with + | Some (Level n) -> n + | _ -> assert false + in + maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]]) + | None -> () + +(** The apparent parser of Coq; encapsulate G to keep track + of the extensions. *) + +module Gram = + struct + include G + let extend e = + maybe_curry + (fun ext -> + camlp4_state := + (ByEXTEND ((fun () -> grammar_delete e None ext), + (fun () -> maybe_uncurry (G.extend e) ext))) + :: !camlp4_state; + maybe_uncurry (G.extend e) ext) + let delete_rule e pil = + (* spiwack: if you use load an ML module which contains GDELETE_RULE + in a section, God kills a kitty. As it would corrupt remove_grammars. + There does not seem to be a good way to undo a delete rule. As deleting + takes fewer arguments than extending. The production rule isn't returned + by delete_rule. If we could retrieve the necessary information, then + ByEXTEND provides just the framework we need to allow this in section. + I'm not entirely sure it makes sense, but at least it would be more correct. + *) + G.delete_rule e pil + end + +(** This extension command is used by the Grammar constr *) + +let grammar_extend e reinit ext = + camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state; + camlp4_verbose (maybe_uncurry (G.extend e)) ext + +(** Remove extensions + + [n] is the number of extended entries (not the number of Grammar commands!) + to remove. *) + +let rec remove_grammars n = + if n>0 then + (match !camlp4_state with + | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove") + | ByGrammar(g,reinit,ext)::t -> + let f (a,b) = (of_coq_assoc a, of_coq_position b) in + grammar_delete g (Option.map f reinit) ext; + camlp4_state := t; + remove_grammars (n-1) + | ByEXTEND (undo,redo)::t -> + undo(); + camlp4_state := t; + remove_grammars n; + redo(); + camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) + +let make_rule r = [None, None, r] + +(** An entry that checks we reached the end of the input. *) + +let eoi_entry en = + let e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in + let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in + let act = Gram.action (fun _ x loc -> x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); + e + +let map_entry f en = + let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in + let symbs = [Symbols.snterm (Gram.Entry.obj en)] in + let act = Gram.action (fun x loc -> f x) in + maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); + e + +(* Parse a string, does NOT check if the entire string was read + (use eoi_entry) *) + +let parse_string f x = + let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) + +type gram_universe = string * (string, typed_entry) Hashtbl.t + +let trace = ref false + +(* The univ_tab is not part of the state. It contains all the grammars that + exist or have existed before in the session. *) + +let univ_tab = (Hashtbl.create 7 : (string, gram_universe) Hashtbl.t) + +let create_univ s = + let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u + +let uprim = create_univ "prim" +let uconstr = create_univ "constr" +let utactic = create_univ "tactic" +let uvernac = create_univ "vernac" + +let get_univ s = + try + Hashtbl.find univ_tab s + with Not_found -> + anomaly (Pp.str ("Unknown grammar universe: "^s)) + +let get_entry (u, utab) s = Hashtbl.find utab s + +let new_entry etyp (u, utab) s = + if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr); + let ename = u ^ ":" ^ s in + let e = in_typed_entry etyp (Gram.entry_create ename) in + Hashtbl.add utab s e; e + +let create_entry (u, utab) s etyp = + try + let e = Hashtbl.find utab s in + if not (argument_type_eq (type_of_typed_entry e) etyp) then + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); + e + with Not_found -> + new_entry etyp (u, utab) s + +let create_constr_entry s = + outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) + +let create_generic_entry s wit = + outGramObj wit (create_entry utactic s (unquote wit)) + +(* [make_gen_entry] builds entries extensible by giving its name (a string) *) +(* For entries extensible only via the ML name, Gram.entry_create is enough *) + +let make_gen_entry (u,univ) rawwit s = + let e = Gram.entry_create (u ^ ":" ^ s) in + Hashtbl.add univ s (inGramObj rawwit e); e + +(* Initial grammar entries *) + +module Prim = + struct + let gec_gen x = make_gen_entry uprim x + + (* Entries that can be referred via the string -> Gram.entry table *) + (* Typically for tactic or vernac extensions *) + let preident = gec_gen (rawwit wit_pre_ident) "preident" + let ident = gec_gen (rawwit wit_ident) "ident" + let natural = gec_gen (rawwit wit_int) "natural" + let integer = gec_gen (rawwit wit_int) "integer" + let bigint = Gram.entry_create "Prim.bigint" + let string = gec_gen (rawwit wit_string) "string" + let reference = make_gen_entry uprim (rawwit wit_ref) "reference" + let by_notation = Gram.entry_create "by_notation" + let smart_global = Gram.entry_create "smart_global" + + (* parsed like ident but interpreted as a term *) + let var = gec_gen (rawwit wit_var) "var" + + let name = Gram.entry_create "Prim.name" + let identref = Gram.entry_create "Prim.identref" + let pattern_ident = Gram.entry_create "pattern_ident" + let pattern_identref = Gram.entry_create "pattern_identref" + + (* A synonym of ident - maybe ident will be located one day *) + let base_ident = Gram.entry_create "Prim.base_ident" + + let qualid = Gram.entry_create "Prim.qualid" + let fullyqualid = Gram.entry_create "Prim.fullyqualid" + let dirpath = Gram.entry_create "Prim.dirpath" + + let ne_string = Gram.entry_create "Prim.ne_string" + let ne_lstring = Gram.entry_create "Prim.ne_lstring" + + end + +module Constr = + struct + let gec_constr = make_gen_entry uconstr (rawwit wit_constr) + + (* Entries that can be referred via the string -> Gram.entry table *) + let constr = gec_constr "constr" + let operconstr = gec_constr "operconstr" + let constr_eoi = eoi_entry constr + let lconstr = gec_constr "lconstr" + let binder_constr = create_constr_entry "binder_constr" + let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" + let global = make_gen_entry uconstr (rawwit wit_ref) "global" + let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" + let pattern = Gram.entry_create "constr:pattern" + let constr_pattern = gec_constr "constr_pattern" + let lconstr_pattern = gec_constr "lconstr_pattern" + let closed_binder = Gram.entry_create "constr:closed_binder" + let binder = Gram.entry_create "constr:binder" + let binders = Gram.entry_create "constr:binders" + let open_binders = Gram.entry_create "constr:open_binders" + let binders_fixannot = Gram.entry_create "constr:binders_fixannot" + let typeclass_constraint = Gram.entry_create "constr:typeclass_constraint" + let record_declaration = Gram.entry_create "constr:record_declaration" + let appl_arg = Gram.entry_create "constr:appl_arg" + end + +module Module = + struct + let module_expr = Gram.entry_create "module_expr" + let module_type = Gram.entry_create "module_type" + end + +module Tactic = + struct + (* Main entry for extensions *) + let simple_tactic = Gram.entry_create "tactic:simple_tactic" + + (* Entries that can be referred via the string -> Gram.entry table *) + (* Typically for tactic user extensions *) + let open_constr = + make_gen_entry utactic (rawwit wit_open_constr) "open_constr" + let constr_with_bindings = + make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings" + let bindings = + make_gen_entry utactic (rawwit wit_bindings) "bindings" + let hypident = Gram.entry_create "hypident" + let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let uconstr = + make_gen_entry utactic (rawwit wit_uconstr) "uconstr" + let quantified_hypothesis = + make_gen_entry utactic (rawwit wit_quant_hyp) "quantified_hypothesis" + let int_or_var = make_gen_entry utactic (rawwit wit_int_or_var) "int_or_var" + let red_expr = make_gen_entry utactic (rawwit wit_red_expr) "red_expr" + let simple_intropattern = + make_gen_entry utactic (rawwit wit_intro_pattern) "simple_intropattern" + let clause_dft_concl = + make_gen_entry utactic (rawwit wit_clause_dft_concl) "clause" + + + (* Main entries for ltac *) + let tactic_arg = Gram.entry_create "tactic:tactic_arg" + let tactic_expr = Gram.entry_create "tactic:tactic_expr" + let binder_tactic = Gram.entry_create "tactic:binder_tactic" + + let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic" + + (* Main entry for quotations *) + let tactic_eoi = eoi_entry tactic + + (* For Ltac definition *) + let tacdef_body = Gram.entry_create "tactic:tacdef_body" + + end + +module Vernac_ = + struct + let gec_vernac s = Gram.entry_create ("vernac:" ^ s) + + (* The different kinds of vernacular commands *) + let gallina = gec_vernac "gallina" + let gallina_ext = gec_vernac "gallina_ext" + let command = gec_vernac "command" + let syntax = gec_vernac "syntax_command" + let vernac = gec_vernac "Vernac.vernac" + let vernac_eoi = eoi_entry vernac + let rec_definition = gec_vernac "Vernac.rec_definition" + (* Main vernac entry *) + let main_entry = Gram.entry_create "vernac" + + let () = + let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in + let act_eoi = Gram.action (fun _ loc -> None) in + let rule = [ + ([ Symbols.stoken Tok.EOI ], act_eoi); + ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac ); + ] in + maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) + + end + +let main_entry = Vernac_.main_entry + +(**********************************************************************) +(* This determines (depending on the associativity of the current + level and on the expected associativity) if a reference to constr_n is + a reference to the current level (to be translated into "SELF" on the + left border and into "constr LEVEL n" elsewhere), to the level below + (to be translated into "NEXT") or to an below wrt associativity (to be + translated in camlp4 into "constr" without level) or to another level + (to be translated into "constr LEVEL n") + + The boolean is true if the entry was existing _and_ empty; this to + circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the + converse of the extension mechanism *) + +let constr_level = string_of_int + +let default_levels = + [200,Extend.RightA,false; + 100,Extend.RightA,false; + 99,Extend.RightA,true; + 10,Extend.RightA,false; + 9,Extend.RightA,false; + 8,Extend.RightA,true; + 1,Extend.LeftA,false; + 0,Extend.RightA,false] + +let default_pattern_levels = + [200,Extend.RightA,true; + 100,Extend.RightA,false; + 99,Extend.RightA,true; + 11,Extend.LeftA,false; + 10,Extend.RightA,false; + 1,Extend.LeftA,false; + 0,Extend.RightA,false] + +let level_stack = + ref [(default_levels, default_pattern_levels)] + +(* At a same level, LeftA takes precedence over RightA and NoneA *) +(* In case, several associativity exists for a level, we make two levels, *) +(* first LeftA, then RightA and NoneA together *) + +let admissible_assoc = function + | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false + | Extend.RightA, Some Extend.LeftA -> false + | _ -> true + +let create_assoc = function + | None -> Extend.RightA + | Some a -> a + +let error_level_assoc p current expected = + let pr_assoc = function + | Extend.LeftA -> str "left" + | Extend.RightA -> str "right" + | Extend.NonA -> str "non" in + errorlabstrm "" + (str "Level " ++ int p ++ str " is already declared " ++ + pr_assoc current ++ str " associative while it is now expected to be " ++ + pr_assoc expected ++ str " associative.") + +let create_pos = function + | None -> Extend.First + | Some lev -> Extend.After (constr_level lev) + +let find_position_gen forpat ensure assoc lev = + let ccurrent,pcurrent as current = List.hd !level_stack in + match lev with + | None -> + level_stack := current :: !level_stack; + None, None, None, None + | Some n -> + let after = ref None in + let init = ref None in + let rec add_level q = function + | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l + | (p,a,reinit)::l when Int.equal p n -> + if reinit then + let a' = create_assoc assoc in + (init := Some (a',create_pos q); (p,a',false)::l) + else if admissible_assoc (a,assoc) then + raise Exit + else + error_level_assoc p a (Option.get assoc) + | l -> after := q; (n,create_assoc assoc,ensure)::l + in + try + let updated = + if forpat then (ccurrent, add_level None pcurrent) + else (add_level None ccurrent, pcurrent) in + level_stack := updated:: !level_stack; + let assoc = create_assoc assoc in + begin match !init with + | None -> + (* Create the entry *) + Some (create_pos !after), Some assoc, Some (constr_level n), None + | _ -> + (* The reinit flag has been updated *) + Some (Extend.Level (constr_level n)), None, None, !init + end + with + (* Nothing has changed *) + Exit -> + level_stack := current :: !level_stack; + (* Just inherit the existing associativity and name (None) *) + Some (Extend.Level (constr_level n)), None, None, None + +let remove_levels n = + level_stack := List.skipn n !level_stack + +let rec list_mem_assoc_triple x = function + | [] -> false + | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l + +let register_empty_levels forpat levels = + let filter n = + try + let levels = (if forpat then snd else fst) (List.hd !level_stack) in + if not (list_mem_assoc_triple n levels) then + Some (find_position_gen forpat true None (Some n)) + else None + with Failure _ -> None + in + List.map_filter filter levels + +let find_position forpat assoc level = + find_position_gen forpat false assoc level + +(* Synchronise the stack of level updates *) +let synchronize_level_positions () = + let _ = find_position true None None in () + +(**********************************************************************) +(* Binding constr entry keys to entries *) + +(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) +let camlp4_assoc = function + | Some Extend.NonA | Some Extend.RightA -> Extend.RightA + | None | Some Extend.LeftA -> Extend.LeftA + +let assoc_eq al ar = match al, ar with +| Extend.NonA, Extend.NonA +| Extend.RightA, Extend.RightA +| Extend.LeftA, Extend.LeftA -> true +| _, _ -> false + +(* [adjust_level assoc from prod] where [assoc] and [from] are the name + and associativity of the level where to add the rule; the meaning of + the result is + + None = SELF + Some None = NEXT + Some (Some (n,cur)) = constr LEVEL n + s.t. if [cur] is set then [n] is the same as the [from] level *) +let adjust_level assoc from = function +(* Associativity is None means force the level *) + | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true)) +(* Compute production name on the right side *) + (* If NonA or LeftA on the right-hand side, set to NEXT *) + | (NumLevel n,BorderProd (Right,Some (Extend.NonA|Extend.LeftA))) -> + Some None + (* If RightA on the right-hand side, set to the explicit (current) level *) + | (NumLevel n,BorderProd (Right,Some Extend.RightA)) -> + Some (Some (n,true)) +(* Compute production name on the left side *) + (* If NonA on the left-hand side, adopt the current assoc ?? *) + | (NumLevel n,BorderProd (Left,Some Extend.NonA)) -> None + (* If the expected assoc is the current one, set to SELF *) + | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp4_assoc assoc) -> + None + (* Otherwise, force the level, n or n-1, according to expected assoc *) + | (NumLevel n,BorderProd (Left,Some a)) -> + begin match a with + | Extend.LeftA -> Some (Some (n, true)) + | _ -> Some None + end + (* None means NEXT *) + | (NextLevel,_) -> Some None +(* Compute production name elsewhere *) + | (NumLevel n,InternalProd) -> + match from with + | ETConstr (p,()) when Int.equal p (n + 1) -> Some None + | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) + | _ -> Some (Some (n,false)) + +let compute_entry allow_create adjust forpat = function + | ETConstr (n,q) -> + (if forpat then weaken_entry Constr.pattern + else weaken_entry Constr.operconstr), + adjust (n,q), false + | ETName -> weaken_entry Prim.name, None, false + | ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList") + | ETBinder false -> weaken_entry Constr.binder, None, false + | ETBinderList (true,tkl) -> + let () = match tkl with [] -> () | _ -> assert false in + weaken_entry Constr.open_binders, None, false + | ETBinderList (false,_) -> anomaly (Pp.str "List of entries cannot be registered.") + | ETBigint -> weaken_entry Prim.bigint, None, false + | ETReference -> weaken_entry Constr.global, None, false + | ETPattern -> weaken_entry Constr.pattern, None, false + | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") + | ETOther (u,n) -> + let u = get_univ u in + let e = + try get_entry u n + with Not_found when allow_create -> create_entry u n ConstrArgType in + object_of_typed_entry e, None, true + +(* This computes the name of the level where to add a new rule *) +let interp_constr_entry_key forpat = function + | ETConstr(200,()) when not forpat -> + weaken_entry Constr.binder_constr, None + | e -> + let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in + (e, level) + +(* This computes the name to give to a production knowing the name and + associativity of the level where it must be added *) +let interp_constr_prod_entry_key ass from forpat en = + compute_entry false (adjust_level ass from) forpat en + +(**********************************************************************) +(* Binding constr entry keys to symbols *) + +let is_self from e = + match from, e with + ETConstr(n,()), ETConstr(NumLevel n', + BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false + | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> Int.equal n n' + | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint + | ETPattern, ETPattern) -> true + | ETOther(s1,s2), ETOther(s1',s2') -> + String.equal s1 s1' && String.equal s2 s2' + | _ -> false + +let is_binder_level from e = + match from, e with + ETConstr(200,()), + ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true + | _ -> false + +let make_sep_rules tkl = + Gram.srules' + [List.map gram_token_of_token tkl, + List.fold_right (fun _ v -> Gram.action (fun _ -> v)) tkl + (Gram.action (fun loc -> ()))] + +let rec symbol_of_constr_prod_entry_key assoc from forpat typ = + if is_binder_level from typ then + if forpat then + Symbols.snterml (Gram.Entry.obj Constr.pattern,"200") + else + Symbols.snterml (Gram.Entry.obj Constr.operconstr,"200") + else if is_self from typ then + Symbols.sself + else + match typ with + | ETConstrList (typ',[]) -> + Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) + | ETConstrList (typ',tkl) -> + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'), + make_sep_rules tkl) + | ETBinderList (false,[]) -> + Symbols.slist1 + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) + | ETBinderList (false,tkl) -> + Symbols.slist1sep + (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false), + make_sep_rules tkl) + + | _ -> + match interp_constr_prod_entry_key assoc from forpat typ with + | (eobj,None,_) -> Symbols.snterm (Gram.Entry.obj eobj) + | (eobj,Some None,_) -> Symbols.snext + | (eobj,Some (Some (lev,cur)),_) -> + Symbols.snterml (Gram.Entry.obj eobj,constr_level lev) + +(** Binding general entry keys to symbol *) + +let rec symbol_of_prod_entry_key = function + | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) + | Alist1sep (s,sep) -> + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) + | Alist0sep (s,sep) -> + Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) + | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) + | Amodifiers s -> + Gram.srules' + [([], Gram.action (fun _loc -> [])); + ([gram_token_of_string "("; + Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); + gram_token_of_string ")"], + Gram.action (fun _ l _ _loc -> l))] + | Aself -> Symbols.sself + | Anext -> Symbols.snext + | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) + | Atactic n -> + Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) + | Agram s -> + let e = + try + (** ppedrot: we should always generate Agram entries which have already + been registered, so this should not fail. *) + let (u, s) = match String.split ':' s with + | u :: s :: [] -> (u, s) + | _ -> raise Not_found + in + get_entry (get_univ u) s + with Not_found -> + Errors.anomaly (str "Unregistered grammar entry: " ++ str s) + in + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + | Aentry (u,s) -> + let e = get_entry (get_univ u) s in + Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + +let level_of_snterml e = int_of_string (Symbols.snterml_level e) + +(**********************************************************************) +(* Interpret entry names of the form "ne_constr_list" as entry keys *) + +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let tactic_level s = + if Int.equal (String.length s) 7 && coincide s "tactic" 0 then + let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) + else None + else None + +let type_of_entry u s = + type_of_typed_entry (get_entry u s) + +let rec interp_entry_name static up_level s sep = + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in + ListArgType t, Alist1 g + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in + ListArgType t, Alist1sep (g,sep) + else if l > 5 && coincide s "_list" (l-5) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in + ListArgType t, Alist0 g + else if l > 9 && coincide s "_list_sep" (l-9) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in + ListArgType t, Alist0sep (g,sep) + else if l > 4 && coincide s "_opt" (l-4) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in + OptArgType t, Aopt g + else if l > 5 && coincide s "_mods" (l-5) then + let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in + ListArgType t, Amodifiers g + else + let s = match s with "hyp" -> "var" | _ -> s in + let check_lvl n = match up_level with + | None -> false + | Some m -> Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + let t, se = + match tactic_level s with + | Some n -> + (** Quite ad-hoc *) + let t = unquote (rawwit wit_tactic) in + let se = + if check_lvl n then Aself + else if check_lvl (n + 1) then Anext + else Atactic n + in + (Some t, se) + | None -> + try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found -> + try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found -> + try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found -> + if static then + error ("Unknown entry "^s^".") + else + None, Aentry ("",s) in + let t = + match t with + | Some t -> t + | None -> ExtraArgType s in + t, se + +let list_entry_names () = + let add_entry key (entry, _) accu = (key, entry) :: accu in + let ans = Hashtbl.fold add_entry (snd uprim) [] in + let ans = Hashtbl.fold add_entry (snd uconstr) ans in + Hashtbl.fold add_entry (snd utactic) ans diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 deleted file mode 100644 index 48dc1372ce..0000000000 --- a/parsing/pcoq.ml4 +++ /dev/null @@ -1,814 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* grammar_object G.entry -end - -module Gramobj : Gramobj = -struct - type grammar_object = Obj.t - let weaken_entry e = Obj.magic e -end - -(** Grammar entries with associated types *) - -type entry_type = argument_type -type grammar_object = Gramobj.grammar_object -type typed_entry = argument_type * grammar_object G.entry -let in_typed_entry t e = (t,Gramobj.weaken_entry e) -let type_of_typed_entry (t,e) = t -let object_of_typed_entry (t,e) = e -let weaken_entry x = Gramobj.weaken_entry x - -module type Gramtypes = -sig - val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry - val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry -end - -module Gramtypes : Gramtypes = -struct - let inGramObj rawwit = in_typed_entry (unquote rawwit) - let outGramObj (a:'a raw_abstract_argument_type) o = - if not (argument_type_eq (type_of_typed_entry o) (unquote a)) - then anomaly ~label:"outGramObj" (str "wrong type"); - (* downcast from grammar_object *) - Obj.magic (object_of_typed_entry o) -end - -open Gramtypes - -(** Grammar extensions *) - -(** NB: [extend_statment = - gram_position option * single_extend_statment list] - and [single_extend_statment = - string option * gram_assoc option * production_rule list] - and [production_rule = symbol list * action] - - In [single_extend_statement], first two parameters are name and - assoc iff a level is created *) - -(** Type of reinitialization data *) -type gram_reinit = gram_assoc * gram_position - -type ext_kind = - | ByGrammar of - grammar_object G.entry - * gram_reinit option (** for reinitialization if ever needed *) - * G.extend_statment - | ByEXTEND of (unit -> unit) * (unit -> unit) - -(** The list of extensions *) - -let camlp4_state = ref [] - -(** Deletion *) - -let grammar_delete e reinit (pos,rls) = - List.iter - (fun (n,ass,lev) -> - List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) - (List.rev rls); - match reinit with - | Some (a,ext) -> - let lev = match Option.map Compat.to_coq_position pos with - | Some (Level n) -> n - | _ -> assert false - in - maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]]) - | None -> () - -(** The apparent parser of Coq; encapsulate G to keep track - of the extensions. *) - -module Gram = - struct - include G - let extend e = - maybe_curry - (fun ext -> - camlp4_state := - (ByEXTEND ((fun () -> grammar_delete e None ext), - (fun () -> maybe_uncurry (G.extend e) ext))) - :: !camlp4_state; - maybe_uncurry (G.extend e) ext) - let delete_rule e pil = - (* spiwack: if you use load an ML module which contains GDELETE_RULE - in a section, God kills a kitty. As it would corrupt remove_grammars. - There does not seem to be a good way to undo a delete rule. As deleting - takes fewer arguments than extending. The production rule isn't returned - by delete_rule. If we could retrieve the necessary information, then - ByEXTEND provides just the framework we need to allow this in section. - I'm not entirely sure it makes sense, but at least it would be more correct. - *) - G.delete_rule e pil - end - -(** This extension command is used by the Grammar constr *) - -let grammar_extend e reinit ext = - camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state; - camlp4_verbose (maybe_uncurry (G.extend e)) ext - -(** Remove extensions - - [n] is the number of extended entries (not the number of Grammar commands!) - to remove. *) - -let rec remove_grammars n = - if n>0 then - (match !camlp4_state with - | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove") - | ByGrammar(g,reinit,ext)::t -> - let f (a,b) = (of_coq_assoc a, of_coq_position b) in - grammar_delete g (Option.map f reinit) ext; - camlp4_state := t; - remove_grammars (n-1) - | ByEXTEND (undo,redo)::t -> - undo(); - camlp4_state := t; - remove_grammars n; - redo(); - camlp4_state := ByEXTEND (undo,redo) :: !camlp4_state) - -let make_rule r = [None, None, r] - -(** An entry that checks we reached the end of the input. *) - -let eoi_entry en = - let e = Gram.entry_create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in - let act = Gram.action (fun _ x loc -> x) in - maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); - e - -let map_entry f en = - let e = Gram.entry_create ((Gram.Entry.name en) ^ "_map") in - let symbs = [Symbols.snterm (Gram.Entry.obj en)] in - let act = Gram.action (fun x loc -> f x) in - maybe_uncurry (Gram.extend e) (None, make_rule [symbs, act]); - e - -(* Parse a string, does NOT check if the entire string was read - (use eoi_entry) *) - -let parse_string f x = - let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) - -type gram_universe = string * (string, typed_entry) Hashtbl.t - -let trace = ref false - -(* The univ_tab is not part of the state. It contains all the grammars that - exist or have existed before in the session. *) - -let univ_tab = (Hashtbl.create 7 : (string, gram_universe) Hashtbl.t) - -let create_univ s = - let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u - -let uprim = create_univ "prim" -let uconstr = create_univ "constr" -let utactic = create_univ "tactic" -let uvernac = create_univ "vernac" - -let get_univ s = - try - Hashtbl.find univ_tab s - with Not_found -> - anomaly (Pp.str ("Unknown grammar universe: "^s)) - -let get_entry (u, utab) s = Hashtbl.find utab s - -let new_entry etyp (u, utab) s = - if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr); - let ename = u ^ ":" ^ s in - let e = in_typed_entry etyp (Gram.entry_create ename) in - Hashtbl.add utab s e; e - -let create_entry (u, utab) s etyp = - try - let e = Hashtbl.find utab s in - if not (argument_type_eq (type_of_typed_entry e) etyp) then - failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - e - with Not_found -> - new_entry etyp (u, utab) s - -let create_constr_entry s = - outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) - -let create_generic_entry s wit = - outGramObj wit (create_entry utactic s (unquote wit)) - -(* [make_gen_entry] builds entries extensible by giving its name (a string) *) -(* For entries extensible only via the ML name, Gram.entry_create is enough *) - -let make_gen_entry (u,univ) rawwit s = - let e = Gram.entry_create (u ^ ":" ^ s) in - Hashtbl.add univ s (inGramObj rawwit e); e - -(* Initial grammar entries *) - -module Prim = - struct - let gec_gen x = make_gen_entry uprim x - - (* Entries that can be referred via the string -> Gram.entry table *) - (* Typically for tactic or vernac extensions *) - let preident = gec_gen (rawwit wit_pre_ident) "preident" - let ident = gec_gen (rawwit wit_ident) "ident" - let natural = gec_gen (rawwit wit_int) "natural" - let integer = gec_gen (rawwit wit_int) "integer" - let bigint = Gram.entry_create "Prim.bigint" - let string = gec_gen (rawwit wit_string) "string" - let reference = make_gen_entry uprim (rawwit wit_ref) "reference" - let by_notation = Gram.entry_create "by_notation" - let smart_global = Gram.entry_create "smart_global" - - (* parsed like ident but interpreted as a term *) - let var = gec_gen (rawwit wit_var) "var" - - let name = Gram.entry_create "Prim.name" - let identref = Gram.entry_create "Prim.identref" - let pattern_ident = Gram.entry_create "pattern_ident" - let pattern_identref = Gram.entry_create "pattern_identref" - - (* A synonym of ident - maybe ident will be located one day *) - let base_ident = Gram.entry_create "Prim.base_ident" - - let qualid = Gram.entry_create "Prim.qualid" - let fullyqualid = Gram.entry_create "Prim.fullyqualid" - let dirpath = Gram.entry_create "Prim.dirpath" - - let ne_string = Gram.entry_create "Prim.ne_string" - let ne_lstring = Gram.entry_create "Prim.ne_lstring" - - end - -module Constr = - struct - let gec_constr = make_gen_entry uconstr (rawwit wit_constr) - - (* Entries that can be referred via the string -> Gram.entry table *) - let constr = gec_constr "constr" - let operconstr = gec_constr "operconstr" - let constr_eoi = eoi_entry constr - let lconstr = gec_constr "lconstr" - let binder_constr = create_constr_entry "binder_constr" - let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" - let global = make_gen_entry uconstr (rawwit wit_ref) "global" - let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" - let pattern = Gram.entry_create "constr:pattern" - let constr_pattern = gec_constr "constr_pattern" - let lconstr_pattern = gec_constr "lconstr_pattern" - let closed_binder = Gram.entry_create "constr:closed_binder" - let binder = Gram.entry_create "constr:binder" - let binders = Gram.entry_create "constr:binders" - let open_binders = Gram.entry_create "constr:open_binders" - let binders_fixannot = Gram.entry_create "constr:binders_fixannot" - let typeclass_constraint = Gram.entry_create "constr:typeclass_constraint" - let record_declaration = Gram.entry_create "constr:record_declaration" - let appl_arg = Gram.entry_create "constr:appl_arg" - end - -module Module = - struct - let module_expr = Gram.entry_create "module_expr" - let module_type = Gram.entry_create "module_type" - end - -module Tactic = - struct - (* Main entry for extensions *) - let simple_tactic = Gram.entry_create "tactic:simple_tactic" - - (* Entries that can be referred via the string -> Gram.entry table *) - (* Typically for tactic user extensions *) - let open_constr = - make_gen_entry utactic (rawwit wit_open_constr) "open_constr" - let constr_with_bindings = - make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings" - let bindings = - make_gen_entry utactic (rawwit wit_bindings) "bindings" - let hypident = Gram.entry_create "hypident" - let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" - let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" - let uconstr = - make_gen_entry utactic (rawwit wit_uconstr) "uconstr" - let quantified_hypothesis = - make_gen_entry utactic (rawwit wit_quant_hyp) "quantified_hypothesis" - let int_or_var = make_gen_entry utactic (rawwit wit_int_or_var) "int_or_var" - let red_expr = make_gen_entry utactic (rawwit wit_red_expr) "red_expr" - let simple_intropattern = - make_gen_entry utactic (rawwit wit_intro_pattern) "simple_intropattern" - let clause_dft_concl = - make_gen_entry utactic (rawwit wit_clause_dft_concl) "clause" - - - (* Main entries for ltac *) - let tactic_arg = Gram.entry_create "tactic:tactic_arg" - let tactic_expr = Gram.entry_create "tactic:tactic_expr" - let binder_tactic = Gram.entry_create "tactic:binder_tactic" - - let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic" - - (* Main entry for quotations *) - let tactic_eoi = eoi_entry tactic - - (* For Ltac definition *) - let tacdef_body = Gram.entry_create "tactic:tacdef_body" - - end - -module Vernac_ = - struct - let gec_vernac s = Gram.entry_create ("vernac:" ^ s) - - (* The different kinds of vernacular commands *) - let gallina = gec_vernac "gallina" - let gallina_ext = gec_vernac "gallina_ext" - let command = gec_vernac "command" - let syntax = gec_vernac "syntax_command" - let vernac = gec_vernac "Vernac.vernac" - let vernac_eoi = eoi_entry vernac - let rec_definition = gec_vernac "Vernac.rec_definition" - (* Main vernac entry *) - let main_entry = Gram.entry_create "vernac" - - let () = - let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in - let act_eoi = Gram.action (fun _ loc -> None) in - let rule = [ - ([ Symbols.stoken Tok.EOI ], act_eoi); - ([ Symbols.snterm (Gram.Entry.obj vernac) ], act_vernac ); - ] in - maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) - - end - -let main_entry = Vernac_.main_entry - -(**********************************************************************) -(* This determines (depending on the associativity of the current - level and on the expected associativity) if a reference to constr_n is - a reference to the current level (to be translated into "SELF" on the - left border and into "constr LEVEL n" elsewhere), to the level below - (to be translated into "NEXT") or to an below wrt associativity (to be - translated in camlp4 into "constr" without level) or to another level - (to be translated into "constr LEVEL n") - - The boolean is true if the entry was existing _and_ empty; this to - circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the - converse of the extension mechanism *) - -let constr_level = string_of_int - -let default_levels = - [200,Extend.RightA,false; - 100,Extend.RightA,false; - 99,Extend.RightA,true; - 10,Extend.RightA,false; - 9,Extend.RightA,false; - 8,Extend.RightA,true; - 1,Extend.LeftA,false; - 0,Extend.RightA,false] - -let default_pattern_levels = - [200,Extend.RightA,true; - 100,Extend.RightA,false; - 99,Extend.RightA,true; - 11,Extend.LeftA,false; - 10,Extend.RightA,false; - 1,Extend.LeftA,false; - 0,Extend.RightA,false] - -let level_stack = - ref [(default_levels, default_pattern_levels)] - -(* At a same level, LeftA takes precedence over RightA and NoneA *) -(* In case, several associativity exists for a level, we make two levels, *) -(* first LeftA, then RightA and NoneA together *) - -let admissible_assoc = function - | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false - | Extend.RightA, Some Extend.LeftA -> false - | _ -> true - -let create_assoc = function - | None -> Extend.RightA - | Some a -> a - -let error_level_assoc p current expected = - let pr_assoc = function - | Extend.LeftA -> str "left" - | Extend.RightA -> str "right" - | Extend.NonA -> str "non" in - errorlabstrm "" - (str "Level " ++ int p ++ str " is already declared " ++ - pr_assoc current ++ str " associative while it is now expected to be " ++ - pr_assoc expected ++ str " associative.") - -let create_pos = function - | None -> Extend.First - | Some lev -> Extend.After (constr_level lev) - -let find_position_gen forpat ensure assoc lev = - let ccurrent,pcurrent as current = List.hd !level_stack in - match lev with - | None -> - level_stack := current :: !level_stack; - None, None, None, None - | Some n -> - let after = ref None in - let init = ref None in - let rec add_level q = function - | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l - | (p,a,reinit)::l when Int.equal p n -> - if reinit then - let a' = create_assoc assoc in - (init := Some (a',create_pos q); (p,a',false)::l) - else if admissible_assoc (a,assoc) then - raise Exit - else - error_level_assoc p a (Option.get assoc) - | l -> after := q; (n,create_assoc assoc,ensure)::l - in - try - let updated = - if forpat then (ccurrent, add_level None pcurrent) - else (add_level None ccurrent, pcurrent) in - level_stack := updated:: !level_stack; - let assoc = create_assoc assoc in - begin match !init with - | None -> - (* Create the entry *) - Some (create_pos !after), Some assoc, Some (constr_level n), None - | _ -> - (* The reinit flag has been updated *) - Some (Extend.Level (constr_level n)), None, None, !init - end - with - (* Nothing has changed *) - Exit -> - level_stack := current :: !level_stack; - (* Just inherit the existing associativity and name (None) *) - Some (Extend.Level (constr_level n)), None, None, None - -let remove_levels n = - level_stack := List.skipn n !level_stack - -let rec list_mem_assoc_triple x = function - | [] -> false - | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l - -let register_empty_levels forpat levels = - let filter n = - try - let levels = (if forpat then snd else fst) (List.hd !level_stack) in - if not (list_mem_assoc_triple n levels) then - Some (find_position_gen forpat true None (Some n)) - else None - with Failure _ -> None - in - List.map_filter filter levels - -let find_position forpat assoc level = - find_position_gen forpat false assoc level - -(* Synchronise the stack of level updates *) -let synchronize_level_positions () = - let _ = find_position true None None in () - -(**********************************************************************) -(* Binding constr entry keys to entries *) - -(* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) -let camlp4_assoc = function - | Some Extend.NonA | Some Extend.RightA -> Extend.RightA - | None | Some Extend.LeftA -> Extend.LeftA - -let assoc_eq al ar = match al, ar with -| Extend.NonA, Extend.NonA -| Extend.RightA, Extend.RightA -| Extend.LeftA, Extend.LeftA -> true -| _, _ -> false - -(* [adjust_level assoc from prod] where [assoc] and [from] are the name - and associativity of the level where to add the rule; the meaning of - the result is - - None = SELF - Some None = NEXT - Some (Some (n,cur)) = constr LEVEL n - s.t. if [cur] is set then [n] is the same as the [from] level *) -let adjust_level assoc from = function -(* Associativity is None means force the level *) - | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true)) -(* Compute production name on the right side *) - (* If NonA or LeftA on the right-hand side, set to NEXT *) - | (NumLevel n,BorderProd (Right,Some (Extend.NonA|Extend.LeftA))) -> - Some None - (* If RightA on the right-hand side, set to the explicit (current) level *) - | (NumLevel n,BorderProd (Right,Some Extend.RightA)) -> - Some (Some (n,true)) -(* Compute production name on the left side *) - (* If NonA on the left-hand side, adopt the current assoc ?? *) - | (NumLevel n,BorderProd (Left,Some Extend.NonA)) -> None - (* If the expected assoc is the current one, set to SELF *) - | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp4_assoc assoc) -> - None - (* Otherwise, force the level, n or n-1, according to expected assoc *) - | (NumLevel n,BorderProd (Left,Some a)) -> - begin match a with - | Extend.LeftA -> Some (Some (n, true)) - | _ -> Some None - end - (* None means NEXT *) - | (NextLevel,_) -> Some None -(* Compute production name elsewhere *) - | (NumLevel n,InternalProd) -> - match from with - | ETConstr (p,()) when Int.equal p (n + 1) -> Some None - | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) - | _ -> Some (Some (n,false)) - -let compute_entry allow_create adjust forpat = function - | ETConstr (n,q) -> - (if forpat then weaken_entry Constr.pattern - else weaken_entry Constr.operconstr), - adjust (n,q), false - | ETName -> weaken_entry Prim.name, None, false - | ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList") - | ETBinder false -> weaken_entry Constr.binder, None, false - | ETBinderList (true,tkl) -> - let () = match tkl with [] -> () | _ -> assert false in - weaken_entry Constr.open_binders, None, false - | ETBinderList (false,_) -> anomaly (Pp.str "List of entries cannot be registered.") - | ETBigint -> weaken_entry Prim.bigint, None, false - | ETReference -> weaken_entry Constr.global, None, false - | ETPattern -> weaken_entry Constr.pattern, None, false - | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") - | ETOther (u,n) -> - let u = get_univ u in - let e = - try get_entry u n - with Not_found when allow_create -> create_entry u n ConstrArgType in - object_of_typed_entry e, None, true - -(* This computes the name of the level where to add a new rule *) -let interp_constr_entry_key forpat = function - | ETConstr(200,()) when not forpat -> - weaken_entry Constr.binder_constr, None - | e -> - let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in - (e, level) - -(* This computes the name to give to a production knowing the name and - associativity of the level where it must be added *) -let interp_constr_prod_entry_key ass from forpat en = - compute_entry false (adjust_level ass from) forpat en - -(**********************************************************************) -(* Binding constr entry keys to symbols *) - -let is_self from e = - match from, e with - ETConstr(n,()), ETConstr(NumLevel n', - BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false - | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> Int.equal n n' - | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint - | ETPattern, ETPattern) -> true - | ETOther(s1,s2), ETOther(s1',s2') -> - String.equal s1 s1' && String.equal s2 s2' - | _ -> false - -let is_binder_level from e = - match from, e with - ETConstr(200,()), - ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true - | _ -> false - -let make_sep_rules tkl = - Gram.srules' - [List.map gram_token_of_token tkl, - List.fold_right (fun _ v -> Gram.action (fun _ -> v)) tkl - (Gram.action (fun loc -> ()))] - -let rec symbol_of_constr_prod_entry_key assoc from forpat typ = - if is_binder_level from typ then - if forpat then - Symbols.snterml (Gram.Entry.obj Constr.pattern,"200") - else - Symbols.snterml (Gram.Entry.obj Constr.operconstr,"200") - else if is_self from typ then - Symbols.sself - else - match typ with - | ETConstrList (typ',[]) -> - Symbols.slist1 (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ')) - | ETConstrList (typ',tkl) -> - Symbols.slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'), - make_sep_rules tkl) - | ETBinderList (false,[]) -> - Symbols.slist1 - (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false)) - | ETBinderList (false,tkl) -> - Symbols.slist1sep - (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false), - make_sep_rules tkl) - - | _ -> - match interp_constr_prod_entry_key assoc from forpat typ with - | (eobj,None,_) -> Symbols.snterm (Gram.Entry.obj eobj) - | (eobj,Some None,_) -> Symbols.snext - | (eobj,Some (Some (lev,cur)),_) -> - Symbols.snterml (Gram.Entry.obj eobj,constr_level lev) - -(** Binding general entry keys to symbol *) - -let rec symbol_of_prod_entry_key = function - | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) - | Alist1sep (s,sep) -> - Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) - | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) - | Alist0sep (s,sep) -> - Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) - | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) - | Amodifiers s -> - Gram.srules' - [([], Gram.action (fun _loc -> [])); - ([gram_token_of_string "("; - Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); - gram_token_of_string ")"], - Gram.action (fun _ l _ _loc -> l))] - | Aself -> Symbols.sself - | Anext -> Symbols.snext - | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) - | Atactic n -> - Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) - | Agram s -> - let e = - try - (** ppedrot: we should always generate Agram entries which have already - been registered, so this should not fail. *) - let (u, s) = match String.split ':' s with - | u :: s :: [] -> (u, s) - | _ -> raise Not_found - in - get_entry (get_univ u) s - with Not_found -> - Errors.anomaly (str "Unregistered grammar entry: " ++ str s) - in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) - | Aentry (u,s) -> - let e = get_entry (get_univ u) s in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) - -let level_of_snterml e = int_of_string (Symbols.snterml_level e) - -(**********************************************************************) -(* Interpret entry names of the form "ne_constr_list" as entry keys *) - -let coincide s pat off = - let len = String.length pat in - let break = ref true in - let i = ref 0 in - while !break && !i < len do - let c = Char.code s.[off + !i] in - let d = Char.code pat.[!i] in - break := Int.equal c d; - incr i - done; - !break - -let tactic_level s = - if Int.equal (String.length s) 7 && coincide s "tactic" 0 then - let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) - else None - else None - -let type_of_entry u s = - type_of_typed_entry (get_entry u s) - -let rec interp_entry_name static up_level s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - ListArgType t, Alist1 g - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - ListArgType t, Alist1sep (g,sep) - else if l > 5 && coincide s "_list" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - ListArgType t, Alist0 g - else if l > 9 && coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - ListArgType t, Alist0sep (g,sep) - else if l > 4 && coincide s "_opt" (l-4) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - OptArgType t, Aopt g - else if l > 5 && coincide s "_mods" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - ListArgType t, Amodifiers g - else - let s = match s with "hyp" -> "var" | _ -> s in - let check_lvl n = match up_level with - | None -> false - | Some m -> Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - let t, se = - match tactic_level s with - | Some n -> - (** Quite ad-hoc *) - let t = unquote (rawwit wit_tactic) in - let se = - if check_lvl n then Aself - else if check_lvl (n + 1) then Anext - else Atactic n - in - (Some t, se) - | None -> - try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found -> - try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found -> - try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found -> - if static then - error ("Unknown entry "^s^".") - else - None, Aentry ("",s) in - let t = - match t with - | Some t -> t - | None -> ExtraArgType s in - t, se - -let list_entry_names () = - let add_entry key (entry, _) accu = (key, entry) :: accu in - let ans = Hashtbl.fold add_entry (snd uprim) [] in - let ans = Hashtbl.fold add_entry (snd uconstr) ans in - Hashtbl.fold add_entry (snd utactic) ans -- cgit v1.2.3 From 1b2a1f0229b485496497ebd1ddbbc561825d61e6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 17:52:41 +0200 Subject: Pcoq.prod_entry_key now uses a GADT to statically enforce typedness. --- grammar/argextend.ml4 | 27 ++++++++++++------- grammar/q_util.ml4 | 2 +- grammar/q_util.mli | 2 +- grammar/tacextend.ml4 | 4 +-- grammar/vernacextend.ml4 | 4 +-- parsing/egramml.ml | 4 +-- parsing/egramml.mli | 4 +-- parsing/pcoq.ml | 70 +++++++++++++++++++++++++----------------------- parsing/pcoq.mli | 30 +++++++++++---------- toplevel/metasyntax.ml | 2 +- 10 files changed, 81 insertions(+), 68 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index fe0959ddbc..7c20ff18e9 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -54,15 +54,22 @@ let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> let has_extraarg = List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false) -let rec is_possibly_empty = function -| Aopt _ | Alist0 _ | Alist0sep _ | Amodifiers _ -> true -| Alist1 t | Alist1sep (t, _) -> is_possibly_empty t +let rec is_possibly_empty : type s a. (s, a) entry_key -> bool = function +| Aopt _ -> true +| Alist0 _ -> true +| Alist0sep _ -> true +| Amodifiers _ -> true +| Alist1 t -> is_possibly_empty t +| Alist1sep (t, _) -> is_possibly_empty t | _ -> false -let rec get_empty_entry = function +let rec get_empty_entry : type s a. (s, a) entry_key -> _ = function | Aopt _ -> <:expr< None >> -| Alist0 _ | Alist0sep _ | Amodifiers _ -> <:expr< [] >> -| Alist1 t | Alist1sep (t, _) -> <:expr< [$get_empty_entry t$] >> +| Alist0 _ -> <:expr< [] >> +| Alist0sep _ -> <:expr< [] >> +| Amodifiers _ -> <:expr< [] >> +| Alist1 t -> <:expr< [$get_empty_entry t$] >> +| Alist1sep (t, _) -> <:expr< [$get_empty_entry t$] >> | _ -> assert false let statically_known_possibly_empty s (prods,_) = @@ -272,7 +279,9 @@ EXTEND [ e = argtype; LIDENT "list" -> ListArgType e | e = argtype; LIDENT "option" -> OptArgType e ] | "0" - [ e = LIDENT -> fst (interp_entry_name false None e "") + [ e = LIDENT -> + let EntryName (t, _) = interp_entry_name false None e "" in + t | "("; e = argtype; ")" -> e ] ] ; argrule: @@ -280,10 +289,10 @@ EXTEND ; genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name false None e "" in + let EntryName (t, g) = interp_entry_name false None e "" in GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let t, g = interp_entry_name false None e sep in + let EntryName (t, g) = interp_entry_name false None e sep in GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 18b1ccd3be..b1eabdd98b 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -49,7 +49,7 @@ let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> -let rec mlexpr_of_prod_entry_key = function +let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = function | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 7393a0d588..d01fb1e9a0 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -30,4 +30,4 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr -val mlexpr_of_prod_entry_key : Pcoq.prod_entry_key -> MLast.expr +val mlexpr_of_prod_entry_key : ('self, 'a) Pcoq.entry_key -> MLast.expr diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 2e725b46c3..70151cef1b 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -257,10 +257,10 @@ EXTEND ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name false None e "" in + let EntryName (t, g) = interp_entry_name false None e "" in GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let t, g = interp_entry_name false None e sep in + let EntryName (t, g) = interp_entry_name false None e sep in GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 03061d8bde..d99af6a33d 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -181,10 +181,10 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let t, g = interp_entry_name false None e "" in + let EntryName (t, g) = interp_entry_name false None e "" in GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let t, g = interp_entry_name false None e sep in + let EntryName (t, g) = interp_entry_name false None e sep in GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> GramTerminal s diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 8fe03b3632..8f07087085 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -30,8 +30,8 @@ let make_generic_action type grammar_prod_item = | GramTerminal of string - | GramNonTerminal of - Loc.t * argument_type * prod_entry_key * Id.t option + | GramNonTerminal : + Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> grammar_prod_item let make_prod_item = function | GramTerminal s -> (gram_token_of_string s, None) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 9ebb5b83b5..60ec6a05a8 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -13,8 +13,8 @@ type grammar_prod_item = | GramTerminal of string - | GramNonTerminal of Loc.t * Genarg.argument_type * - Pcoq.prod_entry_key * Names.Id.t option + | GramNonTerminal : Loc.t * Genarg.argument_type * + ('s, 'a) Pcoq.entry_key * Names.Id.t option -> grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.entry option -> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 48dc1372ce..63662a9561 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -36,26 +36,6 @@ let camlp4_verbosity silent f x = let camlp4_verbose f x = camlp4_verbosity (Flags.is_verbose ()) f x -(** General entry keys *) - -(** This intermediate abstract representation of entries can - both be reified into mlexpr for the ML extensions and - dynamically interpreted as entries for the Coq level extensions -*) - -type prod_entry_key = - | Alist1 of prod_entry_key - | Alist1sep of prod_entry_key * string - | Alist0 of prod_entry_key - | Alist0sep of prod_entry_key * string - | Aopt of prod_entry_key - | Amodifiers of prod_entry_key - | Aself - | Anext - | Atactic of int - | Agram of string - | Aentry of string * string - (** [grammar_object] is the superclass of all grammar entries *) module type Gramobj = @@ -80,6 +60,28 @@ let type_of_typed_entry (t,e) = t let object_of_typed_entry (t,e) = e let weaken_entry x = Gramobj.weaken_entry x +(** General entry keys *) + +(** This intermediate abstract representation of entries can + both be reified into mlexpr for the ML extensions and + dynamically interpreted as entries for the Coq level extensions +*) + +type ('self, _) entry_key = +| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key +| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Aself : ('self, 'self) entry_key +| Anext : ('self, 'self) entry_key +| Atactic : int -> ('self, Tacexpr.raw_tactic_expr) entry_key +| Agram : string -> ('self, 'a) entry_key +| Aentry : string * string -> ('self, 'a) entry_key + +type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name + module type Gramtypes = sig val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry @@ -689,7 +691,7 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) -let rec symbol_of_prod_entry_key = function +let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) @@ -756,24 +758,24 @@ let type_of_entry u s = let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - ListArgType t, Alist1 g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in + EntryName (ListArgType t, Alist1 g) else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - ListArgType t, Alist1sep (g,sep) + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in + EntryName (ListArgType t, Alist1sep (g,sep)) else if l > 5 && coincide s "_list" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - ListArgType t, Alist0 g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in + EntryName (ListArgType t, Alist0 g) else if l > 9 && coincide s "_list_sep" (l-9) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - ListArgType t, Alist0sep (g,sep) + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in + EntryName (ListArgType t, Alist0sep (g,sep)) else if l > 4 && coincide s "_opt" (l-4) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - OptArgType t, Aopt g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in + EntryName (OptArgType t, Aopt g) else if l > 5 && coincide s "_mods" (l-5) then - let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - ListArgType t, Amodifiers g + let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in + EntryName (ListArgType t, Amodifiers g) else let s = match s with "hyp" -> "var" | _ -> s in let check_lvl n = match up_level with @@ -805,7 +807,7 @@ let rec interp_entry_name static up_level s sep = match t with | Some t -> t | None -> ExtraArgType s in - t, se + EntryName (t, se) let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 6e9cf263f2..cdffbcba50 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -264,28 +264,30 @@ val symbol_of_constr_prod_entry_key : gram_assoc option -> dynamically interpreted as entries for the Coq level extensions *) -type prod_entry_key = - | Alist1 of prod_entry_key - | Alist1sep of prod_entry_key * string - | Alist0 of prod_entry_key - | Alist0sep of prod_entry_key * string - | Aopt of prod_entry_key - | Amodifiers of prod_entry_key - | Aself - | Anext - | Atactic of int - | Agram of string - | Aentry of string * string +type ('self, _) entry_key = +| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key +| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Aself : ('self, 'self) entry_key +| Anext : ('self, 'self) entry_key +| Atactic : int -> ('self, raw_tactic_expr) entry_key +| Agram : string -> ('self, 'a) entry_key +| Aentry : string * string -> ('self, 'a) entry_key (** Binding general entry keys to symbols *) val symbol_of_prod_entry_key : - prod_entry_key -> Gram.symbol + ('self, 'a) entry_key -> Gram.symbol + +type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name (** Interpret entry names of the form "ne_constr_list" as entry keys *) val interp_entry_name : bool (** true to fail on unknown entry *) -> - int option -> string -> string -> entry_type * prod_entry_key + int option -> string -> string -> entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * entry_type) list diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 9864182a07..780a8f111c 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -49,7 +49,7 @@ let interp_prod_item lev = function | TacTerm s -> GramTerminal s | TacNonTerm (loc, nt, po) -> let sep = match po with Some (_,sep) -> sep | _ -> "" in - let (etyp, e) = interp_entry_name true (Some lev) nt sep in + let EntryName (etyp, e) = interp_entry_name true (Some lev) nt sep in GramNonTerminal (loc, etyp, e, Option.map fst po) let make_terminal_status = function -- cgit v1.2.3 From d0530179206ff98a327bc189139f75b83ece35ed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 22 Oct 2015 15:43:52 +0200 Subject: Using GADTs in Xmlprotocol. This removes 109 Obj.magic in one patch! --- ide/ide_slave.ml | 2 +- ide/xmlprotocol.ml | 394 +++++++++++++++++++++++++++------------------------- ide/xmlprotocol.mli | 4 +- 3 files changed, 206 insertions(+), 194 deletions(-) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 1dcef22b91..a6c42b28c2 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -474,7 +474,7 @@ let loop () = try let xml_query = Xml_parser.parse xml_ic in (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) - let q = Xmlprotocol.to_call xml_query in + let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in let () = pr_debug_call q in let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in let () = pr_debug_answer q r in diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 32c39e20d4..bb6a18158d 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -221,22 +221,31 @@ module ReifType : sig end = struct - type value_type = - | Unit | String | Int | Bool | Xml - - | Option of value_type - | List of value_type - | Pair of value_type * value_type - | Union of value_type * value_type - - | Goals | Evar | State | Option_state | Option_value | Coq_info - | Coq_object of value_type - | State_id - | Search_cst - - type 'a val_t = value_type - - let erase (x : 'a val_t) : value_type = x + type _ val_t = + | Unit : unit val_t + | String : string val_t + | Int : int val_t + | Bool : bool val_t + | Xml : Xml_datatype.xml val_t + + | Option : 'a val_t -> 'a option val_t + | List : 'a val_t -> 'a list val_t + | Pair : 'a val_t * 'b val_t -> ('a * 'b) val_t + | Union : 'a val_t * 'b val_t -> ('a, 'b) union val_t + + | Goals : goals val_t + | Evar : evar val_t + | State : status val_t + | Option_state : option_state val_t + | Option_value : option_value val_t + | Coq_info : coq_info val_t + | Coq_object : 'a val_t -> 'a coq_object val_t + | State_id : state_id val_t + | Search_cst : search_constraint val_t + + type value_type = Value_type : 'a val_t -> value_type + + let erase (x : 'a val_t) = Value_type x let unit_t = Unit let string_t = String @@ -260,48 +269,48 @@ end = struct let search_cst_t = Search_cst let of_value_type (ty : 'a val_t) : 'a -> xml = - let rec convert ty : 'a -> xml = match ty with - | Unit -> Obj.magic of_unit - | Bool -> Obj.magic of_bool - | Xml -> Obj.magic (fun x -> x) - | String -> Obj.magic of_string - | Int -> Obj.magic of_int - | State -> Obj.magic of_status - | Option_state -> Obj.magic of_option_state - | Option_value -> Obj.magic of_option_value - | Coq_info -> Obj.magic of_coq_info - | Goals -> Obj.magic of_goals - | Evar -> Obj.magic of_evar - | List t -> Obj.magic (of_list (convert t)) - | Option t -> Obj.magic (of_option (convert t)) - | Coq_object t -> Obj.magic (of_coq_object (convert t)) - | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2)) - | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2)) - | State_id -> Obj.magic Stateid.to_xml - | Search_cst -> Obj.magic of_search_cst + let rec convert : type a. a val_t -> a -> xml = function + | Unit -> of_unit + | Bool -> of_bool + | Xml -> (fun x -> x) + | String -> of_string + | Int -> of_int + | State -> of_status + | Option_state -> of_option_state + | Option_value -> of_option_value + | Coq_info -> of_coq_info + | Goals -> of_goals + | Evar -> of_evar + | List t -> (of_list (convert t)) + | Option t -> (of_option (convert t)) + | Coq_object t -> (of_coq_object (convert t)) + | Pair (t1,t2) -> (of_pair (convert t1) (convert t2)) + | Union (t1,t2) -> (of_union (convert t1) (convert t2)) + | State_id -> Stateid.to_xml + | Search_cst -> of_search_cst in convert ty let to_value_type (ty : 'a val_t) : xml -> 'a = - let rec convert ty : xml -> 'a = match ty with - | Unit -> Obj.magic to_unit - | Bool -> Obj.magic to_bool - | Xml -> Obj.magic (fun x -> x) - | String -> Obj.magic to_string - | Int -> Obj.magic to_int - | State -> Obj.magic to_status - | Option_state -> Obj.magic to_option_state - | Option_value -> Obj.magic to_option_value - | Coq_info -> Obj.magic to_coq_info - | Goals -> Obj.magic to_goals - | Evar -> Obj.magic to_evar - | List t -> Obj.magic (to_list (convert t)) - | Option t -> Obj.magic (to_option (convert t)) - | Coq_object t -> Obj.magic (to_coq_object (convert t)) - | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2)) - | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2)) - | State_id -> Obj.magic Stateid.of_xml - | Search_cst -> Obj.magic to_search_cst + let rec convert : type a. a val_t -> xml -> a = function + | Unit -> to_unit + | Bool -> to_bool + | Xml -> (fun x -> x) + | String -> to_string + | Int -> to_int + | State -> to_status + | Option_state -> to_option_state + | Option_value -> to_option_value + | Coq_info -> to_coq_info + | Goals -> to_goals + | Evar -> to_evar + | List t -> (to_list (convert t)) + | Option t -> (to_option (convert t)) + | Coq_object t -> (to_coq_object (convert t)) + | Pair (t1,t2) -> (to_pair (convert t1) (convert t2)) + | Union (t1,t2) -> (to_union (convert t1) (convert t2)) + | State_id -> Stateid.of_xml + | Search_cst -> to_search_cst in convert ty @@ -350,6 +359,7 @@ end = struct let pr_coq_object (o : 'a coq_object) = "FIXME" let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")" let pr_union pr1 pr2 = function Inl x -> "Inl "^pr1 x | Inr x -> "Inr "^pr2 x + let pr_state_id = Stateid.to_string let pr_search_cst = function | Name_Pattern s -> "Name_Pattern " ^ s @@ -358,30 +368,30 @@ end = struct | In_Module s -> "In_Module " ^ String.concat "." s | Include_Blacklist -> "Include_Blacklist" - let rec print = function - | Unit -> Obj.magic pr_unit - | Bool -> Obj.magic pr_bool - | String -> Obj.magic pr_string - | Xml -> Obj.magic Xml_printer.to_string_fmt - | Int -> Obj.magic pr_int - | State -> Obj.magic pr_status - | Option_state -> Obj.magic pr_option_state - | Option_value -> Obj.magic pr_option_value - | Search_cst -> Obj.magic pr_search_cst - | Coq_info -> Obj.magic pr_coq_info - | Goals -> Obj.magic pr_goal - | Evar -> Obj.magic pr_evar - | List t -> Obj.magic (pr_list (print t)) - | Option t -> Obj.magic (pr_option (print t)) - | Coq_object t -> Obj.magic pr_coq_object - | Pair (t1,t2) -> Obj.magic (pr_pair (print t1) (print t2)) - | Union (t1,t2) -> Obj.magic (pr_union (print t1) (print t2)) - | State_id -> Obj.magic pr_int + let rec print : type a. a val_t -> a -> string = function + | Unit -> pr_unit + | Bool -> pr_bool + | String -> pr_string + | Xml -> Xml_printer.to_string_fmt + | Int -> pr_int + | State -> pr_status + | Option_state -> pr_option_state + | Option_value -> pr_option_value + | Search_cst -> pr_search_cst + | Coq_info -> pr_coq_info + | Goals -> pr_goal + | Evar -> pr_evar + | List t -> (pr_list (print t)) + | Option t -> (pr_option (print t)) + | Coq_object t -> pr_coq_object + | Pair (t1,t2) -> (pr_pair (print t1) (print t2)) + | Union (t1,t2) -> (pr_union (print t1) (print t2)) + | State_id -> pr_state_id (* This is to break if a rename/refactoring makes the strings below outdated *) type 'a exists = bool - let rec print_type = function + let rec print_val_t : type a. a val_t -> string = function | Unit -> "unit" | Bool -> "bool" | String -> "string" @@ -394,33 +404,35 @@ end = struct | Coq_info -> assert(true : coq_info exists); "Interface.coq_info" | Goals -> assert(true : goals exists); "Interface.goals" | Evar -> assert(true : evar exists); "Interface.evar" - | List t -> Printf.sprintf "(%s list)" (print_type t) - | Option t -> Printf.sprintf "(%s option)" (print_type t) + | List t -> Printf.sprintf "(%s list)" (print_val_t t) + | Option t -> Printf.sprintf "(%s option)" (print_val_t t) | Coq_object t -> assert(true : 'a coq_object exists); - Printf.sprintf "(%s Interface.coq_object)" (print_type t) - | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_type t1) (print_type t2) + Printf.sprintf "(%s Interface.coq_object)" (print_val_t t) + | Pair (t1,t2) -> Printf.sprintf "(%s * %s)" (print_val_t t1) (print_val_t t2) | Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists); - Printf.sprintf "((%s, %s) CSig.union)" (print_type t1) (print_type t2) + Printf.sprintf "((%s, %s) CSig.union)" (print_val_t t1) (print_val_t t2) | State_id -> assert(true : Stateid.t exists); "Stateid.t" + let print_type = function Value_type ty -> print_val_t ty + let document_type_encoding pr_xml = Printf.printf "\n=== Data encoding by examples ===\n\n"; - Printf.printf "%s:\n\n%s\n\n" (print_type Unit) (pr_xml (of_unit ())); - Printf.printf "%s:\n\n%s\n%s\n\n" (print_type Bool) + Printf.printf "%s:\n\n%s\n\n" (print_val_t Unit) (pr_xml (of_unit ())); + Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t Bool) (pr_xml (of_bool true)) (pr_xml (of_bool false)); - Printf.printf "%s:\n\n%s\n\n" (print_type String) (pr_xml (of_string "hello")); - Printf.printf "%s:\n\n%s\n\n" (print_type Int) (pr_xml (of_int 256)); - Printf.printf "%s:\n\n%s\n\n" (print_type State_id) (pr_xml (Stateid.to_xml Stateid.initial)); - Printf.printf "%s:\n\n%s\n\n" (print_type (List Int)) (pr_xml (of_list of_int [3;4;5])); - Printf.printf "%s:\n\n%s\n%s\n\n" (print_type (Option Int)) + Printf.printf "%s:\n\n%s\n\n" (print_val_t String) (pr_xml (of_string "hello")); + Printf.printf "%s:\n\n%s\n\n" (print_val_t Int) (pr_xml (of_int 256)); + Printf.printf "%s:\n\n%s\n\n" (print_val_t State_id) (pr_xml (Stateid.to_xml Stateid.initial)); + Printf.printf "%s:\n\n%s\n\n" (print_val_t (List Int)) (pr_xml (of_list of_int [3;4;5])); + Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t (Option Int)) (pr_xml (of_option of_int (Some 3))) (pr_xml (of_option of_int None)); - Printf.printf "%s:\n\n%s\n\n" (print_type (Pair (Bool,Int))) + Printf.printf "%s:\n\n%s\n\n" (print_val_t (Pair (Bool,Int))) (pr_xml (of_pair of_bool of_int (false,3))); - Printf.printf "%s:\n\n%s\n\n" (print_type (Union (Bool,Int))) + Printf.printf "%s:\n\n%s\n\n" (print_val_t (Union (Bool,Int))) (pr_xml (of_union of_bool of_int (Inl false))); print_endline ("All other types are records represented by a node named like the OCaml\n"^ "type which contains a flattened n-tuple. We provide one example.\n"); - Printf.printf "%s:\n\n%s\n\n" (print_type Option_state) + Printf.printf "%s:\n\n%s\n\n" (print_val_t Option_state) (pr_xml (of_option_state { opt_sync = true; opt_depr = false; opt_name = "name1"; opt_value = IntValue (Some 37) })); @@ -496,27 +508,27 @@ let calls = [| |] type 'a call = - | Add of add_sty - | Edit_at of edit_at_sty - | Query of query_sty - | Goal of goals_sty - | Evars of evars_sty - | Hints of hints_sty - | Status of status_sty - | Search of search_sty - | GetOptions of get_options_sty - | SetOptions of set_options_sty - | MkCases of mkcases_sty - | Quit of quit_sty - | About of about_sty - | Init of init_sty - | StopWorker of stop_worker_sty + | Add : add_sty -> add_rty call + | Edit_at : edit_at_sty -> edit_at_rty call + | Query : query_sty -> query_rty call + | Goal : goals_sty -> goals_rty call + | Evars : evars_sty -> evars_rty call + | Hints : hints_sty -> hints_rty call + | Status : status_sty -> status_rty call + | Search : search_sty -> search_rty call + | GetOptions : get_options_sty -> get_options_rty call + | SetOptions : set_options_sty -> set_options_rty call + | MkCases : mkcases_sty -> mkcases_rty call + | Quit : quit_sty -> quit_rty call + | About : about_sty -> about_rty call + | Init : init_sty -> init_rty call + | StopWorker : stop_worker_sty -> stop_worker_rty call (* retrocompatibility *) - | Interp of interp_sty - | PrintAst of print_ast_sty - | Annotate of annotate_sty + | Interp : interp_sty -> interp_rty call + | PrintAst : print_ast_sty -> print_ast_rty call + | Annotate : annotate_sty -> annotate_rty call -let id_of_call = function +let id_of_call : type a. a call -> int = function | Add _ -> 0 | Edit_at _ -> 1 | Query _ -> 2 @@ -538,7 +550,7 @@ let id_of_call = function let str_of_call c = pi1 calls.(id_of_call c) -type unknown +type unknown_call = Unknown : 'a call -> unknown_call (** We use phantom types and GADT to protect ourselves against wild casts *) let add x : add_rty call = Add x @@ -559,8 +571,8 @@ let stop_worker x : stop_worker_rty call = StopWorker x let print_ast x : print_ast_rty call = PrintAst x let annotate x : annotate_rty call = Annotate x -let abstract_eval_call handler (c : 'a call) : 'a value = - let mkGood x : 'a value = Good (Obj.magic x) in +let abstract_eval_call : type a. _ -> a call -> a value = fun handler c -> + let mkGood : type a. a -> a value = fun x -> Good x in try match c with | Add x -> mkGood (handler.add x) @@ -586,47 +598,47 @@ let abstract_eval_call handler (c : 'a call) : 'a value = Fail (handler.handle_exn any) (** brain dead code, edit if protocol messages are added/removed *) -let of_answer (q : 'a call) (v : 'a value) : xml = match q with - | Add _ -> of_value (of_value_type add_rty_t ) (Obj.magic v) - | Edit_at _ -> of_value (of_value_type edit_at_rty_t ) (Obj.magic v) - | Query _ -> of_value (of_value_type query_rty_t ) (Obj.magic v) - | Goal _ -> of_value (of_value_type goals_rty_t ) (Obj.magic v) - | Evars _ -> of_value (of_value_type evars_rty_t ) (Obj.magic v) - | Hints _ -> of_value (of_value_type hints_rty_t ) (Obj.magic v) - | Status _ -> of_value (of_value_type status_rty_t ) (Obj.magic v) - | Search _ -> of_value (of_value_type search_rty_t ) (Obj.magic v) - | GetOptions _ -> of_value (of_value_type get_options_rty_t) (Obj.magic v) - | SetOptions _ -> of_value (of_value_type set_options_rty_t) (Obj.magic v) - | MkCases _ -> of_value (of_value_type mkcases_rty_t ) (Obj.magic v) - | Quit _ -> of_value (of_value_type quit_rty_t ) (Obj.magic v) - | About _ -> of_value (of_value_type about_rty_t ) (Obj.magic v) - | Init _ -> of_value (of_value_type init_rty_t ) (Obj.magic v) - | Interp _ -> of_value (of_value_type interp_rty_t ) (Obj.magic v) - | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) (Obj.magic v) - | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) (Obj.magic v) - | Annotate _ -> of_value (of_value_type annotate_rty_t ) (Obj.magic v) - -let to_answer (q : 'a call) (x : xml) : 'a value = match q with - | Add _ -> Obj.magic (to_value (to_value_type add_rty_t ) x) - | Edit_at _ -> Obj.magic (to_value (to_value_type edit_at_rty_t ) x) - | Query _ -> Obj.magic (to_value (to_value_type query_rty_t ) x) - | Goal _ -> Obj.magic (to_value (to_value_type goals_rty_t ) x) - | Evars _ -> Obj.magic (to_value (to_value_type evars_rty_t ) x) - | Hints _ -> Obj.magic (to_value (to_value_type hints_rty_t ) x) - | Status _ -> Obj.magic (to_value (to_value_type status_rty_t ) x) - | Search _ -> Obj.magic (to_value (to_value_type search_rty_t ) x) - | GetOptions _ -> Obj.magic (to_value (to_value_type get_options_rty_t) x) - | SetOptions _ -> Obj.magic (to_value (to_value_type set_options_rty_t) x) - | MkCases _ -> Obj.magic (to_value (to_value_type mkcases_rty_t ) x) - | Quit _ -> Obj.magic (to_value (to_value_type quit_rty_t ) x) - | About _ -> Obj.magic (to_value (to_value_type about_rty_t ) x) - | Init _ -> Obj.magic (to_value (to_value_type init_rty_t ) x) - | Interp _ -> Obj.magic (to_value (to_value_type interp_rty_t ) x) - | StopWorker _ -> Obj.magic (to_value (to_value_type stop_worker_rty_t) x) - | PrintAst _ -> Obj.magic (to_value (to_value_type print_ast_rty_t ) x) - | Annotate _ -> Obj.magic (to_value (to_value_type annotate_rty_t ) x) - -let of_call (q : 'a call) : xml = +let of_answer : type a. a call -> a value -> xml = function + | Add _ -> of_value (of_value_type add_rty_t ) + | Edit_at _ -> of_value (of_value_type edit_at_rty_t ) + | Query _ -> of_value (of_value_type query_rty_t ) + | Goal _ -> of_value (of_value_type goals_rty_t ) + | Evars _ -> of_value (of_value_type evars_rty_t ) + | Hints _ -> of_value (of_value_type hints_rty_t ) + | Status _ -> of_value (of_value_type status_rty_t ) + | Search _ -> of_value (of_value_type search_rty_t ) + | GetOptions _ -> of_value (of_value_type get_options_rty_t) + | SetOptions _ -> of_value (of_value_type set_options_rty_t) + | MkCases _ -> of_value (of_value_type mkcases_rty_t ) + | Quit _ -> of_value (of_value_type quit_rty_t ) + | About _ -> of_value (of_value_type about_rty_t ) + | Init _ -> of_value (of_value_type init_rty_t ) + | Interp _ -> of_value (of_value_type interp_rty_t ) + | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) + | PrintAst _ -> of_value (of_value_type print_ast_rty_t ) + | Annotate _ -> of_value (of_value_type annotate_rty_t ) + +let to_answer : type a. a call -> xml -> a value = function + | Add _ -> to_value (to_value_type add_rty_t ) + | Edit_at _ -> to_value (to_value_type edit_at_rty_t ) + | Query _ -> to_value (to_value_type query_rty_t ) + | Goal _ -> to_value (to_value_type goals_rty_t ) + | Evars _ -> to_value (to_value_type evars_rty_t ) + | Hints _ -> to_value (to_value_type hints_rty_t ) + | Status _ -> to_value (to_value_type status_rty_t ) + | Search _ -> to_value (to_value_type search_rty_t ) + | GetOptions _ -> to_value (to_value_type get_options_rty_t) + | SetOptions _ -> to_value (to_value_type set_options_rty_t) + | MkCases _ -> to_value (to_value_type mkcases_rty_t ) + | Quit _ -> to_value (to_value_type quit_rty_t ) + | About _ -> to_value (to_value_type about_rty_t ) + | Init _ -> to_value (to_value_type init_rty_t ) + | Interp _ -> to_value (to_value_type interp_rty_t ) + | StopWorker _ -> to_value (to_value_type stop_worker_rty_t) + | PrintAst _ -> to_value (to_value_type print_ast_rty_t ) + | Annotate _ -> to_value (to_value_type annotate_rty_t ) + +let of_call : type a. a call -> xml = fun q -> let mkCall x = constructor "call" (str_of_call q) [x] in match q with | Add x -> mkCall (of_value_type add_sty_t x) @@ -648,28 +660,28 @@ let of_call (q : 'a call) : xml = | PrintAst x -> mkCall (of_value_type print_ast_sty_t x) | Annotate x -> mkCall (of_value_type annotate_sty_t x) -let to_call : xml -> unknown call = +let to_call : xml -> unknown_call = do_match "call" (fun s a -> let mkCallArg vt a = to_value_type vt (singleton a) in match s with - | "Add" -> Add (mkCallArg add_sty_t a) - | "Edit_at" -> Edit_at (mkCallArg edit_at_sty_t a) - | "Query" -> Query (mkCallArg query_sty_t a) - | "Goal" -> Goal (mkCallArg goals_sty_t a) - | "Evars" -> Evars (mkCallArg evars_sty_t a) - | "Hints" -> Hints (mkCallArg hints_sty_t a) - | "Status" -> Status (mkCallArg status_sty_t a) - | "Search" -> Search (mkCallArg search_sty_t a) - | "GetOptions" -> GetOptions (mkCallArg get_options_sty_t a) - | "SetOptions" -> SetOptions (mkCallArg set_options_sty_t a) - | "MkCases" -> MkCases (mkCallArg mkcases_sty_t a) - | "Quit" -> Quit (mkCallArg quit_sty_t a) - | "About" -> About (mkCallArg about_sty_t a) - | "Init" -> Init (mkCallArg init_sty_t a) - | "Interp" -> Interp (mkCallArg interp_sty_t a) - | "StopWorker" -> StopWorker (mkCallArg stop_worker_sty_t a) - | "PrintAst" -> PrintAst (mkCallArg print_ast_sty_t a) - | "Annotate" -> Annotate (mkCallArg annotate_sty_t a) + | "Add" -> Unknown (Add (mkCallArg add_sty_t a)) + | "Edit_at" -> Unknown (Edit_at (mkCallArg edit_at_sty_t a)) + | "Query" -> Unknown (Query (mkCallArg query_sty_t a)) + | "Goal" -> Unknown (Goal (mkCallArg goals_sty_t a)) + | "Evars" -> Unknown (Evars (mkCallArg evars_sty_t a)) + | "Hints" -> Unknown (Hints (mkCallArg hints_sty_t a)) + | "Status" -> Unknown (Status (mkCallArg status_sty_t a)) + | "Search" -> Unknown (Search (mkCallArg search_sty_t a)) + | "GetOptions" -> Unknown (GetOptions (mkCallArg get_options_sty_t a)) + | "SetOptions" -> Unknown (SetOptions (mkCallArg set_options_sty_t a)) + | "MkCases" -> Unknown (MkCases (mkCallArg mkcases_sty_t a)) + | "Quit" -> Unknown (Quit (mkCallArg quit_sty_t a)) + | "About" -> Unknown (About (mkCallArg about_sty_t a)) + | "Init" -> Unknown (Init (mkCallArg init_sty_t a)) + | "Interp" -> Unknown (Interp (mkCallArg interp_sty_t a)) + | "StopWorker" -> Unknown (StopWorker (mkCallArg stop_worker_sty_t a)) + | "PrintAst" -> Unknown (PrintAst (mkCallArg print_ast_sty_t a)) + | "Annotate" -> Unknown (Annotate (mkCallArg annotate_sty_t a)) | _ -> raise Marshal_error) (** Debug printing *) @@ -681,26 +693,26 @@ let pr_value_gen pr = function "FAIL "^Stateid.to_string id^ " ("^string_of_int i^","^string_of_int j^")["^Richpp.raw_print str^"]" let pr_value v = pr_value_gen (fun _ -> "FIXME") v -let pr_full_value call value = match call with - | Add _ -> pr_value_gen (print add_rty_t ) (Obj.magic value) - | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) (Obj.magic value) - | Query _ -> pr_value_gen (print query_rty_t ) (Obj.magic value) - | Goal _ -> pr_value_gen (print goals_rty_t ) (Obj.magic value) - | Evars _ -> pr_value_gen (print evars_rty_t ) (Obj.magic value) - | Hints _ -> pr_value_gen (print hints_rty_t ) (Obj.magic value) - | Status _ -> pr_value_gen (print status_rty_t ) (Obj.magic value) - | Search _ -> pr_value_gen (print search_rty_t ) (Obj.magic value) - | GetOptions _ -> pr_value_gen (print get_options_rty_t) (Obj.magic value) - | SetOptions _ -> pr_value_gen (print set_options_rty_t) (Obj.magic value) - | MkCases _ -> pr_value_gen (print mkcases_rty_t ) (Obj.magic value) - | Quit _ -> pr_value_gen (print quit_rty_t ) (Obj.magic value) - | About _ -> pr_value_gen (print about_rty_t ) (Obj.magic value) - | Init _ -> pr_value_gen (print init_rty_t ) (Obj.magic value) - | Interp _ -> pr_value_gen (print interp_rty_t ) (Obj.magic value) - | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) (Obj.magic value) - | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) (Obj.magic value) - | Annotate _ -> pr_value_gen (print annotate_rty_t ) (Obj.magic value) -let pr_call call = +let pr_full_value : type a. a call -> a value -> string = fun call value -> match call with + | Add _ -> pr_value_gen (print add_rty_t ) value + | Edit_at _ -> pr_value_gen (print edit_at_rty_t ) value + | Query _ -> pr_value_gen (print query_rty_t ) value + | Goal _ -> pr_value_gen (print goals_rty_t ) value + | Evars _ -> pr_value_gen (print evars_rty_t ) value + | Hints _ -> pr_value_gen (print hints_rty_t ) value + | Status _ -> pr_value_gen (print status_rty_t ) value + | Search _ -> pr_value_gen (print search_rty_t ) value + | GetOptions _ -> pr_value_gen (print get_options_rty_t) value + | SetOptions _ -> pr_value_gen (print set_options_rty_t) value + | MkCases _ -> pr_value_gen (print mkcases_rty_t ) value + | Quit _ -> pr_value_gen (print quit_rty_t ) value + | About _ -> pr_value_gen (print about_rty_t ) value + | Init _ -> pr_value_gen (print init_rty_t ) value + | Interp _ -> pr_value_gen (print interp_rty_t ) value + | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) value + | PrintAst _ -> pr_value_gen (print print_ast_rty_t ) value + | Annotate _ -> pr_value_gen (print annotate_rty_t ) value +let pr_call : type a. a call -> string = fun call -> let return what x = str_of_call call ^ " " ^ print what x in match call with | Add x -> return add_sty_t x diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index 2c8ebc655a..7806550d1c 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -13,7 +13,7 @@ open Xml_datatype type 'a call -type unknown +type unknown_call = Unknown : 'a call -> unknown_call val add : add_sty -> add_rty call val edit_at : edit_at_sty -> edit_at_rty call @@ -43,7 +43,7 @@ val protocol_version : string (** * XML data marshalling *) val of_call : 'a call -> xml -val to_call : xml -> unknown call +val to_call : xml -> unknown_call val of_answer : 'a call -> 'a value -> xml val to_answer : 'a call -> xml -> 'a value -- cgit v1.2.3 From 273005ac85e9ae0c23328e243edeadfc8dcaf8bb Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 22 Oct 2015 22:25:35 +0200 Subject: Fixing a bug in reporting ill-formed inductive. Was introduced in b06d3badb (15 Jul 2015). --- kernel/indtypes.ml | 2 +- test-suite/output/Inductive.out | 3 +++ test-suite/output/Inductive.v | 3 +++ 3 files changed, 7 insertions(+), 1 deletion(-) create mode 100644 test-suite/output/Inductive.out create mode 100644 test-suite/output/Inductive.v diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 5d7a0bbf00..8b03df64c6 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -390,7 +390,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = | _::hyps -> match kind_of_term (whd_betadeltaiota env lpar.(k)) with | Rel w when Int.equal w index -> check (k-1) (index+1) hyps - | _ -> raise (IllFormedInd (LocalNonPar (k+1, index, l))) + | _ -> raise (IllFormedInd (LocalNonPar (k+1, index-n+nhyps+1, l))) in check (nparams-1) (n-nhyps) hyps; if not (Array.for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out new file mode 100644 index 0000000000..e912003f03 --- /dev/null +++ b/test-suite/output/Inductive.out @@ -0,0 +1,3 @@ +The command has indeed failed with message: +Last occurrence of "list'" must have "A" as 1st argument in + "A -> list' A -> list' (A * A)%type". diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v new file mode 100644 index 0000000000..8db8956e32 --- /dev/null +++ b/test-suite/output/Inductive.v @@ -0,0 +1,3 @@ +Fail Inductive list' (A:Set) : Set := +| nil' : list' A +| cons' : A -> list' A -> list' (A*A). -- cgit v1.2.3 From d30a7244b52e86c364320a8fa0794c7686f30074 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 23 Oct 2015 07:45:15 +0200 Subject: Support "Functional Scheme" in coqdoc. (Fix bug #4382) --- tools/coqdoc/cpretty.mll | 1 + 1 file changed, 1 insertion(+) diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index cb70414675..d28921674b 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -320,6 +320,7 @@ let def_token = | "Instance" | "Declare" space+ "Instance" | "Global" space+ "Instance" + | "Functional" space+ "Scheme" let decl_token = "Hypothesis" -- cgit v1.2.3 From 3df7e2a89ae931207781c6f5cbc9e196235b1dc3 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 24 Oct 2015 09:57:50 +0200 Subject: Backtracking on interpreting toplevel calls to exact in scope determined by the type to prove (was introduced in 35846ec22, r15978, Nov 2012). Not only it does not work when exact is called via a Ltac definition, but, also, it does not scale easily to refine which is a TACTIC EXTEND. Ideally, one may then want to propagate scope interpretations through ltac variables, as well as supporting refine... See #4034 for a discussion. --- tactics/tacinterp.ml | 4 +++- test-suite/bugs/closed/4034.v | 25 +++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4034.v diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 5a0d26a1cb..6c125ed2d9 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -557,7 +557,9 @@ let interp_gen kind ist allow_patvar flags env sigma (c,ce) = ltac_vars = constr_context; ltac_bound = Id.Map.domain ist.lfun; } in - intern_gen kind ~allow_patvar ~ltacvars env c + let kind_for_intern = + match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in + intern_gen kind_for_intern ~allow_patvar ~ltacvars env c in let trace = push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist in diff --git a/test-suite/bugs/closed/4034.v b/test-suite/bugs/closed/4034.v new file mode 100644 index 0000000000..3f7be4d1c7 --- /dev/null +++ b/test-suite/bugs/closed/4034.v @@ -0,0 +1,25 @@ +(* This checks compatibility of interpretation scope used for exact + between 8.4 and 8.5. See discussion at + https://coq.inria.fr/bugs/show_bug.cgi?id=4034. It is not clear + what we would like exactly, but certainly, if exact is interpreted + in a special scope, it should be interpreted consistently so also + in ltac code. *) + +Record Foo := {}. +Bind Scope foo_scope with Foo. +Notation "!" := Build_Foo : foo_scope. +Notation "!" := 1 : core_scope. +Open Scope foo_scope. +Open Scope core_scope. + +Goal Foo. + Fail exact !. +(* ... but maybe will we want it to succeed eventually if we ever + would be able to make it working the same in + +Ltac myexact e := exact e. + +Goal Foo. + myexact !. +Defined. +*) -- cgit v1.2.3 From 1b029b2163386f20179a61f6bdb68e5532f4c306 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 24 Oct 2015 12:01:26 +0200 Subject: Fixing a loop in checking hints with holes. For instance, "Hint Resolve (fst _ _)." was looping (bug in 841bc461). --- tactics/hints.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/hints.ml b/tactics/hints.ml index 2755ed9cb0..4ba9adafec 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1071,7 +1071,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = (* We skip the test whether args is the identity or not *) let t = Evarutil.nf_evar sigma (existential_type sigma ev) in let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in - if not (Int.Set.is_empty (free_rels t)) then + if not (closed0 c) then error "Hints with holes dependent on a bound variable not supported."; if occur_existential t then (* Not clever enough to construct dependency graph of evars *) -- cgit v1.2.3 From 06e10609b3bb04c3f42a2211c9f782f130ffd7dd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 24 Oct 2015 23:58:28 +0200 Subject: Getting rid of the Agram entry. --- grammar/q_util.ml4 | 3 +-- parsing/egramcoq.ml | 2 +- parsing/pcoq.ml | 21 +++++---------------- parsing/pcoq.mli | 5 +++-- 4 files changed, 10 insertions(+), 21 deletions(-) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index b1eabdd98b..5b005186bd 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -59,6 +59,5 @@ let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = functi | Pcoq.Aself -> <:expr< Pcoq.Aself >> | Pcoq.Anext -> <:expr< Pcoq.Anext >> | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >> - | Pcoq.Agram s -> Errors.anomaly (Pp.str "Agram not supported") - | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Agram (Pcoq.Gram.Entry.name $lid:s$) >> + | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:s$) >> | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry $str:u$ $str:s$ >> diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index d9eb5d4126..fba754eaaf 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -378,7 +378,7 @@ let create_ltac_quotation name cast wit e = let rule = [ gram_token_of_string name; gram_token_of_string ":"; - symbol_of_prod_entry_key (Agram (Gram.Entry.name e)); + symbol_of_prod_entry_key (Aentry (name_of_entry e)); ] in let action v _ _ loc = let loc = !@loc in diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 63662a9561..b1692e9e2b 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -77,8 +77,7 @@ type ('self, _) entry_key = | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key | Atactic : int -> ('self, Tacexpr.raw_tactic_expr) entry_key -| Agram : string -> ('self, 'a) entry_key -| Aentry : string * string -> ('self, 'a) entry_key +| Aentry : (string * string) -> ('self, 'a) entry_key type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name @@ -711,20 +710,6 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) | Atactic n -> Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) - | Agram s -> - let e = - try - (** ppedrot: we should always generate Agram entries which have already - been registered, so this should not fail. *) - let (u, s) = match String.split ':' s with - | u :: s :: [] -> (u, s) - | _ -> raise Not_found - in - get_entry (get_univ u) s - with Not_found -> - Errors.anomaly (str "Unregistered grammar entry: " ++ str s) - in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) | Aentry (u,s) -> let e = get_entry (get_univ u) s in Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) @@ -809,6 +794,10 @@ let rec interp_entry_name static up_level s sep = | None -> ExtraArgType s in EntryName (t, se) +let name_of_entry e = match String.split ':' (Gram.Entry.name e) with +| u :: s :: [] -> (u, s) +| _ -> assert false + let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in let ans = Hashtbl.fold add_entry (snd uprim) [] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index cdffbcba50..d13ff548ca 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -274,8 +274,9 @@ type ('self, _) entry_key = | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key | Atactic : int -> ('self, raw_tactic_expr) entry_key -| Agram : string -> ('self, 'a) entry_key -| Aentry : string * string -> ('self, 'a) entry_key +| Aentry : (string * string) -> ('self, 'a) entry_key + +val name_of_entry : 'a Gram.entry -> string * string (** Binding general entry keys to symbols *) -- cgit v1.2.3 From c2de48c3f59415eaf0f2cbb5cfe78f23e908a459 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sun, 25 Oct 2015 12:14:12 +0100 Subject: Minor module cleanup : error HigherOrderInclude was never happening When F is a Functor, doing an 'Include F' triggers the 'Include Self' mechanism: the current context is used as an pseudo-argument to F. This may fail with a subtype error if the current context isn't adequate. --- kernel/mod_typing.ml | 2 +- kernel/mod_typing.mli | 3 +++ kernel/modops.ml | 4 ---- kernel/modops.mli | 3 --- kernel/safe_typing.ml | 8 ++------ toplevel/himsg.ml | 4 ---- 6 files changed, 6 insertions(+), 18 deletions(-) diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 922652287b..eef83ce743 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -359,4 +359,4 @@ let rec translate_mse_incl env mp inl = function |MEapply (fe,arg) -> let ftrans = translate_mse_incl env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> None) - |_ -> Modops.error_higher_order_include () + |MEwith _ -> assert false (* No 'with' syntax for modules *) diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index 80db12b0d3..0c3fb2ba79 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -36,6 +36,9 @@ val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation +(** [translate_mse_incl] translate the mse of a real module (no + module type here) given to an Include *) + val translate_mse_incl : env -> module_path -> inline -> module_struct_entry -> module_alg_expr translation diff --git a/kernel/modops.ml b/kernel/modops.ml index 8733ca8c2f..f0cb65c967 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -67,7 +67,6 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string - | HigherOrderInclude exception ModuleTypingError of module_typing_error @@ -113,9 +112,6 @@ let error_generative_module_expected l = let error_no_such_label_sub l l1 = raise (ModuleTypingError (LabelMissing (l,l1))) -let error_higher_order_include () = - raise (ModuleTypingError HigherOrderInclude) - (** {6 Operations on functors } *) let is_functor = function diff --git a/kernel/modops.mli b/kernel/modops.mli index 6fbcd81d03..a335ad9b4a 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -126,7 +126,6 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string - | HigherOrderInclude exception ModuleTypingError of module_typing_error @@ -153,5 +152,3 @@ val error_incorrect_with_constraint : Label.t -> 'a val error_generative_module_expected : Label.t -> 'a val error_no_such_label_sub : Label.t->string->'a - -val error_higher_order_include : unit -> 'a diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 9329b16861..fdacbb365c 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -706,17 +706,13 @@ let add_include me is_module inl senv = let subst = Mod_subst.map_mbid mbid mp_sup mpsup_delta in let resolver = Mod_subst.subst_codom_delta_resolver subst resolver in compute_sign (Modops.subst_signature subst str) mb resolver senv - | str -> resolver,str,senv + | NoFunctor str -> resolver,str,senv in - let resolver,sign,senv = + let resolver,str,senv = let struc = NoFunctor (List.rev senv.revstruct) in let mtb = build_mtb mp_sup struc Univ.ContextSet.empty senv.modresolver in compute_sign sign mtb resolver senv in - let str = match sign with - | NoFunctor struc -> struc - | MoreFunctor _ -> Modops.error_higher_order_include () - in let senv = update_resolver (Mod_subst.add_delta_resolver resolver) senv in let add senv ((l,elem) as field) = diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 8efc36df72..8f380830db 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -924,9 +924,6 @@ let explain_label_missing l s = str "The field " ++ str (Label.to_string l) ++ str " is missing in " ++ str s ++ str "." -let explain_higher_order_include () = - str "You cannot Include a higher-order structure." - let explain_module_error = function | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err | LabelAlreadyDeclared l -> explain_label_already_declared l @@ -943,7 +940,6 @@ let explain_module_error = function | IncorrectWithConstraint l -> explain_incorrect_label_constraint l | GenerativeModuleExpected l -> explain_generative_module_expected l | LabelMissing (l,s) -> explain_label_missing l s - | HigherOrderInclude -> explain_higher_order_include () (* Module internalization errors *) -- cgit v1.2.3 From 83e82ef7b42f47d63d3b40b2698695a0e7b2d685 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sun, 25 Oct 2015 14:58:39 +0100 Subject: Safe_typing: add clean_bounded_mod_expr in Include Self of modtype (fix #4331) --- kernel/mod_typing.ml | 12 ++++++++++-- kernel/mod_typing.mli | 14 +++++++------- kernel/safe_typing.ml | 9 ++------- 3 files changed, 19 insertions(+), 16 deletions(-) diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index eef83ce743..c03c5175fd 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -351,12 +351,20 @@ let translate_module env mp inl = function let restype = Option.map (fun ty -> ((params,ty),inl)) oty in finalize_module env mp t restype -let rec translate_mse_incl env mp inl = function +let rec translate_mse_inclmod env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in sign,None,mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> - let ftrans = translate_mse_incl env mp inl fe in + let ftrans = translate_mse_inclmod env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> None) |MEwith _ -> assert false (* No 'with' syntax for modules *) + +let translate_mse_incl is_mod env mp inl me = + if is_mod then + translate_mse_inclmod env mp inl me + else + let mtb = translate_modtype env mp inl ([],me) in + let sign = clean_bounded_mod_expr mtb.mod_type in + sign,None,mtb.mod_delta,mtb.mod_constraints diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index 0c3fb2ba79..bc0e20205a 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -36,14 +36,14 @@ val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation -(** [translate_mse_incl] translate the mse of a real module (no - module type here) given to an Include *) - -val translate_mse_incl : - env -> module_path -> inline -> module_struct_entry -> - module_alg_expr translation - val finalize_module : env -> module_path -> module_expression translation -> (module_type_entry * inline) option -> module_body + +(** [translate_mse_incl] translate the mse of a module or + module type given to an Include *) + +val translate_mse_incl : + bool -> env -> module_path -> inline -> module_struct_entry -> + module_alg_expr translation diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index fdacbb365c..ec245b0648 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -682,13 +682,8 @@ let end_modtype l senv = let add_include me is_module inl senv = let open Mod_typing in let mp_sup = senv.modpath in - let sign,cst,resolver = - if is_module then - let sign,_,reso,cst = translate_mse_incl senv.env mp_sup inl me in - sign,cst,reso - else - let mtb = translate_modtype senv.env mp_sup inl ([],me) in - mtb.mod_type,mtb.mod_constraints,mtb.mod_delta + let sign,_,resolver,cst = + translate_mse_incl is_module senv.env mp_sup inl me in let senv = add_constraints (Now (false, cst)) senv in (* Include Self support *) -- cgit v1.2.3 From af89d24f9d54b18068046545af1268dffbeb3e07 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 25 Oct 2015 16:27:44 +0100 Subject: Getting rid of the Atactic entry. --- grammar/q_util.ml4 | 4 ++-- parsing/pcoq.ml | 26 +++++++++++++++----------- parsing/pcoq.mli | 2 +- 3 files changed, 18 insertions(+), 14 deletions(-) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 5b005186bd..20c83dfafa 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -58,6 +58,6 @@ let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = functi | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> | Pcoq.Aself -> <:expr< Pcoq.Aself >> | Pcoq.Anext -> <:expr< Pcoq.Anext >> - | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >> | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:s$) >> - | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry $str:u$ $str:s$ >> + | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry ($str:u$, $str:s$) >> + | Pcoq.Aentryl ((u,s), l) -> <:expr< Pcoq.Aentryl ($str:u$, $str:s$) $mlexpr_of_int l$ >> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b1692e9e2b..b244a021e2 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -76,8 +76,8 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Atactic : int -> ('self, Tacexpr.raw_tactic_expr) entry_key | Aentry : (string * string) -> ('self, 'a) entry_key +| Aentryl : (string * string) * int -> ('self, 'a) entry_key type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name @@ -370,8 +370,8 @@ module Tactic = (* Main entries for ltac *) let tactic_arg = Gram.entry_create "tactic:tactic_arg" - let tactic_expr = Gram.entry_create "tactic:tactic_expr" - let binder_tactic = Gram.entry_create "tactic:binder_tactic" + let tactic_expr = make_gen_entry utactic (rawwit wit_tactic) "tactic_expr" + let binder_tactic = make_gen_entry utactic (rawwit wit_tactic) "binder_tactic" let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic" @@ -707,12 +707,12 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function Gram.action (fun _ l _ _loc -> l))] | Aself -> Symbols.sself | Anext -> Symbols.snext - | Atactic 5 -> Symbols.snterm (Gram.Entry.obj Tactic.binder_tactic) - | Atactic n -> - Symbols.snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n) | Aentry (u,s) -> let e = get_entry (get_univ u) s in Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + | Aentryl ((u, s), n) -> + let e = get_entry (get_univ u) s in + Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n) let level_of_snterml e = int_of_string (Symbols.snterml_level e) @@ -740,6 +740,14 @@ let tactic_level s = let type_of_entry u s = type_of_typed_entry (get_entry u s) +let name_of_entry e = match String.split ':' (Gram.Entry.name e) with +| u :: s :: [] -> (u, s) +| _ -> assert false + +let atactic n = + if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) + else Aentryl (name_of_entry Tactic.tactic_expr, n) + let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then @@ -777,7 +785,7 @@ let rec interp_entry_name static up_level s sep = let se = if check_lvl n then Aself else if check_lvl (n + 1) then Anext - else Atactic n + else atactic n in (Some t, se) | None -> @@ -794,10 +802,6 @@ let rec interp_entry_name static up_level s sep = | None -> ExtraArgType s in EntryName (t, se) -let name_of_entry e = match String.split ':' (Gram.Entry.name e) with -| u :: s :: [] -> (u, s) -| _ -> assert false - let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in let ans = Hashtbl.fold add_entry (snd uprim) [] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index d13ff548ca..959c039d30 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -273,8 +273,8 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Atactic : int -> ('self, raw_tactic_expr) entry_key | Aentry : (string * string) -> ('self, 'a) entry_key +| Aentryl : (string * string) * int -> ('self, 'a) entry_key val name_of_entry : 'a Gram.entry -> string * string -- cgit v1.2.3 From 6417a9e72feb39b87f0b456186100b11d1c87d5f Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sun, 25 Oct 2015 16:40:32 +0100 Subject: Declaremods: replace two anomalies by user errors (fix #3974 and #3975) As shown by the code snippets in these bug reports, I've been too hasty in considering these situations as anomalies in commit 466c4cb (at least the one at the last line of consistency_checks). So let's turn these anomalies back to regular user errors, as they were before this commit. --- library/declaremods.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/library/declaremods.ml b/library/declaremods.ml index f66656d09a..7f607a51c9 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -166,12 +166,14 @@ let consistency_checks exists dir dirinfo = let globref = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> - anomaly (pr_dirpath dir ++ str " should already exist!") + errorlabstrm "consistency_checks" + (pr_dirpath dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then - anomaly (pr_dirpath dir ++ str " already exists") + errorlabstrm "consistency_checks" + (pr_dirpath dir ++ str " already exists") let compute_visibility exists i = if exists then Nametab.Exactly i else Nametab.Until i -- cgit v1.2.3 From 010775eba60ea89645792b48a0686ff15c4ebcb5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 25 Oct 2015 18:43:32 +0100 Subject: Pcoq entries are given a proper module. Entries defined in the Pcoq AST of symbols must be marshallable, because they are present in the libstack. Yet, CAMLP4/5 entries are not marshallable as they contain functional values. This is why the Pcoq module used a pair [string * string] to describe entries. It is obviously type-unsafe, so we define a new abstract type in its own module. There is a little issue though, which is that our entries and CAMLP4/5 entries must be kept synchronized through an association table. The Pcoq module tries to maintain this invariant. --- dev/printers.mllib | 1 + dev/top_printers.ml | 4 +- grammar/grammar.mllib | 1 + grammar/q_util.ml4 | 13 +++++-- grammar/tacextend.ml4 | 6 ++- parsing/entry.ml | 63 ++++++++++++++++++++++++++++++ parsing/entry.mli | 50 ++++++++++++++++++++++++ parsing/parsing.mllib | 1 + parsing/pcoq.ml | 103 ++++++++++++++++++++++++++++++-------------------- parsing/pcoq.mli | 12 ++---- 10 files changed, 199 insertions(+), 55 deletions(-) create mode 100644 parsing/entry.ml create mode 100644 parsing/entry.mli diff --git a/dev/printers.mllib b/dev/printers.mllib index de43efa670..1a2819feb2 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -191,6 +191,7 @@ Pfedit Tactic_debug Decl_mode Ppconstr +Entry Pcoq Printer Pptactic diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 1d3d711ac7..7b807a343a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -519,7 +519,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,ConstrArgType,Aentry ("constr","constr"), + (Loc.ghost,ConstrArgType,Aentry (Entry.unsafe_of_name ("constr","constr")), Some (Names.Id.of_string "c"))] let _ = @@ -536,7 +536,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,ConstrArgType,Aentry ("constr","constr"), + (Loc.ghost,ConstrArgType,Aentry (Entry.unsafe_of_name ("constr","constr")), Some (Names.Id.of_string "c"))] (* Setting printer of unbound global reference *) diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 60ea0df026..7e4eea641b 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -51,6 +51,7 @@ Constrexpr_ops Compat Tok Lexer +Entry Pcoq G_prim G_tactic diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 20c83dfafa..5ec7510f79 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -58,6 +58,13 @@ let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = functi | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> | Pcoq.Aself -> <:expr< Pcoq.Aself >> | Pcoq.Anext -> <:expr< Pcoq.Anext >> - | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:s$) >> - | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry ($str:u$, $str:s$) >> - | Pcoq.Aentryl ((u,s), l) -> <:expr< Pcoq.Aentryl ($str:u$, $str:s$) $mlexpr_of_int l$ >> + | Pcoq.Aentry e -> + begin match Entry.repr e with + | Entry.Dynamic s -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:s$) >> + | Entry.Static (u, s) -> <:expr< Pcoq.Aentry (Entry.unsafe_of_name ($str:u$, $str:s$)) >> + end + | Pcoq.Aentryl (e, l) -> + begin match Entry.repr e with + | Entry.Dynamic s -> <:expr< Pcoq.Aentryl (Pcoq.name_of_entry $lid:s$) >> + | Entry.Static (u, s) -> <:expr< Pcoq.Aentryl (Entry.unsafe_of_name ($str:u$, $str:s$)) $mlexpr_of_int l$ >> + end diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 70151cef1b..4709a79989 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -162,7 +162,11 @@ let is_constr_gram = function | GramTerminal _ -> false | GramNonTerminal (_, _, e, _) -> match e with - | Aentry ("constr", "constr") -> true + | Aentry e -> + begin match Entry.repr e with + | Entry.Static ("constr", "constr") -> true + | _ -> false + end | _ -> false let make_var = function diff --git a/parsing/entry.ml b/parsing/entry.ml new file mode 100644 index 0000000000..97d601320d --- /dev/null +++ b/parsing/entry.ml @@ -0,0 +1,63 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + anomaly (Pp.str ("Unknown grammar universe: "^s)) + +(** Entries are registered with a unique name *) + +let entries = ref String.Set.empty + +let create u name = + let uname = u ^ ":" ^ name in + let () = + if String.Set.mem uname !entries then + anomaly (Pp.str ("Entry " ^ uname ^ " already defined")) + in + let () = entries := String.Set.add uname !entries in + (u, name) + +let dynamic name = ("", name) + +let unsafe_of_name (u, s) = + let uname = u ^ ":" ^ s in + assert (String.Set.mem uname !entries); + (u, s) + +let repr = function +| ("", u) -> Dynamic u +| (u, s) -> Static (u, s) diff --git a/parsing/entry.mli b/parsing/entry.mli new file mode 100644 index 0000000000..6854a5cb45 --- /dev/null +++ b/parsing/entry.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* universe +val univ_name : universe -> string + +val uprim : universe +val uconstr : universe +val utactic : universe +val uvernac : universe + +(** {5 Uniquely defined entries} *) + +val create : universe -> string -> 'a t +(** Create an entry. They should be synchronized with the entries defined in + {!Pcoq}. *) + +(** {5 Meta-programming} *) + +val dynamic : string -> 'a t +(** Dynamic entries. They refer to entries defined in the code source and may + only be used in meta-programming definitions from the grammar directory. *) + +val repr : 'a t -> repr + +val unsafe_of_name : (string * string) -> 'a t diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index a0cb831931..024d8607fc 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -1,6 +1,7 @@ Tok Compat Lexer +Entry Pcoq Egramml Egramcoq diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b244a021e2..5b980b3489 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -76,8 +76,8 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Aentry : (string * string) -> ('self, 'a) entry_key -| Aentryl : (string * string) * int -> ('self, 'a) entry_key +| Aentry : 'a Entry.t -> ('self, 'a) entry_key +| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name @@ -217,45 +217,58 @@ let map_entry f en = let parse_string f x = let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) -type gram_universe = string * (string, typed_entry) Hashtbl.t +type gram_universe = Entry.universe let trace = ref false -(* The univ_tab is not part of the state. It contains all the grammars that - exist or have existed before in the session. *) +let uprim = Entry.uprim +let uconstr = Entry.uconstr +let utactic = Entry.utactic +let uvernac = Entry.uvernac +let get_univ = Entry.get_univ -let univ_tab = (Hashtbl.create 7 : (string, gram_universe) Hashtbl.t) +let utables : (string, (string, typed_entry) Hashtbl.t) Hashtbl.t = + Hashtbl.create 97 -let create_univ s = - let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u - -let uprim = create_univ "prim" -let uconstr = create_univ "constr" -let utactic = create_univ "tactic" -let uvernac = create_univ "vernac" - -let get_univ s = - try - Hashtbl.find univ_tab s +let get_utable u = + let u = Entry.univ_name u in + try Hashtbl.find utables u with Not_found -> - anomaly (Pp.str ("Unknown grammar universe: "^s)) - -let get_entry (u, utab) s = Hashtbl.find utab s - -let new_entry etyp (u, utab) s = - if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr); - let ename = u ^ ":" ^ s in + let table = Hashtbl.create 97 in + Hashtbl.add utables u table; + table + +let get_entry u s = + let utab = get_utable u in + Hashtbl.find utab s + +let get_typed_entry e = + let (u, s) = match Entry.repr e with + | Entry.Dynamic _ -> assert false + | Entry.Static (u, s) -> (u, s) + in + let u = Entry.get_univ u in + get_entry u s + +let new_entry etyp u s = + let utab = get_utable u in + let uname = Entry.univ_name u in + if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr); + let _ = Entry.create u s in + let ename = uname ^ ":" ^ s in let e = in_typed_entry etyp (Gram.entry_create ename) in Hashtbl.add utab s e; e -let create_entry (u, utab) s etyp = +let create_entry u s etyp = + let utab = get_utable u in try let e = Hashtbl.find utab s in + let u = Entry.univ_name u in if not (argument_type_eq (type_of_typed_entry e) etyp) then failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); e with Not_found -> - new_entry etyp (u, utab) s + new_entry etyp u s let create_constr_entry s = outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) @@ -266,8 +279,11 @@ let create_generic_entry s wit = (* [make_gen_entry] builds entries extensible by giving its name (a string) *) (* For entries extensible only via the ML name, Gram.entry_create is enough *) -let make_gen_entry (u,univ) rawwit s = - let e = Gram.entry_create (u ^ ":" ^ s) in +let make_gen_entry u rawwit s = + let univ = get_utable u in + let uname = Entry.univ_name u in + let e = Gram.entry_create (uname ^ ":" ^ s) in + let _ = Entry.create u s in Hashtbl.add univ s (inGramObj rawwit e); e (* Initial grammar entries *) @@ -355,7 +371,7 @@ module Tactic = make_gen_entry utactic (rawwit wit_bindings) "bindings" let hypident = Gram.entry_create "hypident" let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" - let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_eval" let uconstr = make_gen_entry utactic (rawwit wit_uconstr) "uconstr" let quantified_hypothesis = @@ -707,11 +723,11 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function Gram.action (fun _ l _ _loc -> l))] | Aself -> Symbols.sself | Anext -> Symbols.snext - | Aentry (u,s) -> - let e = get_entry (get_univ u) s in + | Aentry e -> + let e = get_typed_entry e in Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) - | Aentryl ((u, s), n) -> - let e = get_entry (get_univ u) s in + | Aentryl (e, n) -> + let e = get_typed_entry e in Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n) let level_of_snterml e = int_of_string (Symbols.snterml_level e) @@ -741,13 +757,18 @@ let type_of_entry u s = type_of_typed_entry (get_entry u s) let name_of_entry e = match String.split ':' (Gram.Entry.name e) with -| u :: s :: [] -> (u, s) +| u :: s :: [] -> Entry.unsafe_of_name (u, s) | _ -> assert false let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) else Aentryl (name_of_entry Tactic.tactic_expr, n) +let try_get_entry u s = + (** Order the effects: type_of_entry can raise Not_found *) + let typ = type_of_entry u s in + Some typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s)) + let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then @@ -789,13 +810,13 @@ let rec interp_entry_name static up_level s sep = in (Some t, se) | None -> - try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found -> - try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found -> - try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found -> + try try_get_entry uprim s with Not_found -> + try try_get_entry uconstr s with Not_found -> + try try_get_entry utactic s with Not_found -> if static then error ("Unknown entry "^s^".") else - None, Aentry ("",s) in + None, Aentry (Entry.dynamic s) in let t = match t with | Some t -> t @@ -804,6 +825,6 @@ let rec interp_entry_name static up_level s sep = let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in - let ans = Hashtbl.fold add_entry (snd uprim) [] in - let ans = Hashtbl.fold add_entry (snd uconstr) ans in - Hashtbl.fold add_entry (snd utactic) ans + let ans = Hashtbl.fold add_entry (get_utable uprim) [] in + let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in + Hashtbl.fold add_entry (get_utable utactic) ans diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 959c039d30..18eb3eed34 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -137,11 +137,7 @@ val parse_string : 'a Gram.entry -> string -> 'a val eoi_entry : 'a Gram.entry -> 'a Gram.entry val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry -(** Table of Coq statically defined grammar entries *) - -type gram_universe - -(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *) +type gram_universe = Entry.universe val get_univ : string -> gram_universe @@ -273,10 +269,10 @@ type ('self, _) entry_key = | Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Aself : ('self, 'self) entry_key | Anext : ('self, 'self) entry_key -| Aentry : (string * string) -> ('self, 'a) entry_key -| Aentryl : (string * string) * int -> ('self, 'a) entry_key +| Aentry : 'a Entry.t -> ('self, 'a) entry_key +| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -val name_of_entry : 'a Gram.entry -> string * string +val name_of_entry : 'a Gram.entry -> 'a Entry.t (** Binding general entry keys to symbols *) -- cgit v1.2.3 From 23803338b26bb833e9e5254d5b7ce36ce832ee59 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 26 Oct 2015 19:41:51 +0100 Subject: Two test-suite files for bugs 3974 and 3975 --- test-suite/bugs/closed/3974.v | 7 +++++++ test-suite/bugs/closed/3975.v | 8 ++++++++ 2 files changed, 15 insertions(+) create mode 100644 test-suite/bugs/closed/3974.v create mode 100644 test-suite/bugs/closed/3975.v diff --git a/test-suite/bugs/closed/3974.v b/test-suite/bugs/closed/3974.v new file mode 100644 index 0000000000..b6be159595 --- /dev/null +++ b/test-suite/bugs/closed/3974.v @@ -0,0 +1,7 @@ +Module Type S. +End S. + +Module Type M (X : S). + Fail Module P (X : S). + (* Used to say: Anomaly: X already exists. Please report. *) + (* Should rather say now: Error: X already exists. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3975.v b/test-suite/bugs/closed/3975.v new file mode 100644 index 0000000000..95851c8137 --- /dev/null +++ b/test-suite/bugs/closed/3975.v @@ -0,0 +1,8 @@ +Module Type S. End S. + +Module M (X:S). End M. + +Module Type P (X : S). + Print M. + (* Used to say: Anomaly: X already exists. Please report. *) + (* Should rather : print something :-) *) \ No newline at end of file -- cgit v1.2.3 From d4edd135e7cb8b6f86d9d5a0d320e0b29ee20148 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 24 Oct 2015 17:57:24 +0200 Subject: Preserving goal name in revert/bring_hyps. --- tactics/tactics.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0d6a26a113..1437b24625 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2480,11 +2480,13 @@ let bring_hyps hyps = else Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in + let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (instance_from_named_context hyps) in Proofview.Refine.refine begin fun sigma -> - let (sigma, ev) = Evarutil.new_evar env sigma newcl in + let (sigma, ev) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in (sigma, (mkApp (ev, args))) end end -- cgit v1.2.3 From d1114c5f55fcb96a99a1a5562b014414ad8217ba Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 24 Oct 2015 18:10:24 +0200 Subject: Documenting a bit more interpretation functions in passing. --- interp/constrintern.mli | 8 +++++--- pretyping/pretyping.mli | 24 +++++++++++++++++------- 2 files changed, 22 insertions(+), 10 deletions(-) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 4d2c994679..b671c98815 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -95,7 +95,8 @@ val intern_context : bool -> env -> internalization_env -> local_binder list -> (** {6 Composing internalization with type inference (pretyping) } *) -(** Main interpretation functions expecting evars to be all resolved *) +(** Main interpretation functions, using type class inference, + expecting evars and pending problems to be all resolved *) val interp_constr : env -> evar_map -> ?impls:internalization_env -> constr_expr -> constr Evd.in_evar_universe_context @@ -106,9 +107,10 @@ val interp_casted_constr : env -> evar_map -> ?impls:internalization_env -> val interp_type : env -> evar_map -> ?impls:internalization_env -> constr_expr -> types Evd.in_evar_universe_context -(** Main interpretation function expecting evars to be all resolved *) +(** Main interpretation function expecting all postponed problems to + be resolved, but possibly leaving evars. *) -val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr +val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr (** Accepting unresolved evars *) diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index a6aa086579..5f0e19cf2b 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -66,9 +66,12 @@ val all_and_fail_flags : inference_flags (** Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) val allow_anonymous_refs : bool ref -(** Generic call to the interpreter from glob_constr to open_constr, leaving - unresolved holes as evars and returning the typing contexts of - these evars. Work as [understand_gen] for the rest. *) +(** Generic calls to the interpreter from glob_constr to open_constr; + by default, inference_flags tell to use type classes and + heuristics (but no external tactic solver hooks), as well as to + ensure that conversion problems are all solved and expand evars, + but unresolved evars can remain. The difference is in whether the + evar_map is modified explicitly or by side-effect. *) val understand_tcc : ?flags:inference_flags -> env -> evar_map -> ?expected_type:typing_constraint -> glob_constr -> open_constr @@ -92,7 +95,12 @@ val understand_ltac : inference_flags -> env -> evar_map -> ltac_var_map -> typing_constraint -> glob_constr -> pure_open_constr -(** Standard call to get a constr from a glob_constr, resolving implicit args *) +(** Standard call to get a constr from a glob_constr, resolving + implicit arguments and coercions, and compiling pattern-matching; + the default inference_flags tells to use type classes and + heuristics (but no external tactic solver hook), as well as to + ensure that conversion problems are all solved and that no + unresolved evar remains, expanding evars. *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context @@ -102,12 +110,13 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> val understand_judgment : env -> evar_map -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context -(** Idem but do not fail on unresolved evars *) +(** Idem but do not fail on unresolved evars (type cl*) val understand_judgment_tcc : env -> evar_map ref -> glob_constr -> unsafe_judgment (** Trying to solve remaining evars and remaining conversion problems - with type classes, heuristics, and possibly an external solver *) + possibly using type classes, heuristics, external tactic solver + hook depending on given flags. *) (* For simplicity, it is assumed that current map has no other evars with candidate and no other conversion problems that the one in [pending], however, it can contain more evars than the pending ones. *) @@ -115,7 +124,8 @@ val understand_judgment_tcc : env -> evar_map ref -> val solve_remaining_evars : inference_flags -> env -> (* initial map *) evar_map -> (* map to solve *) pending -> evar_map -(** Checking evars are all solved and reporting an appropriate error message *) +(** Checking evars and pending conversion problems are all solved, + reporting an appropriate error message *) val check_evars_are_solved : env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit -- cgit v1.2.3 From ee72fb2936a4ff5032aa6b8fba3165cdb6ca448e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 25 Oct 2015 15:20:28 +0100 Subject: Preventing using OCaml 4.02.0 for compiling Coq as compilation times are redhibitory. --- INSTALL | 10 ++++++---- configure.ml | 7 ++++++- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/INSTALL b/INSTALL index 955e605c39..83c1b9f3f1 100644 --- a/INSTALL +++ b/INSTALL @@ -55,10 +55,12 @@ QUICK INSTALLATION PROCEDURE. INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). ================================================= -1- Check that you have the Objective Caml compiler version 3.12.1 (or later) - installed on your computer and that "ocamlc" (or its native code version - "ocamlc.opt") lie in a directory which is present in your $PATH environment - variable. +1- Check that you have the Objective Caml compiler installed on your + computer and that "ocamlc" (or, better, its native code version + "ocamlc.opt") lies in a directory which is present in your $PATH + environment variable. At the time of writing this sentence, all + versions of Objective Caml later or equal to 3.12.1 are + supported to the exception of Objective Caml 4.02.0. To get Coq in native-code, (it runs 4 to 10 times faster than bytecode, but it takes more time to get compiled and the binary is diff --git a/configure.ml b/configure.ml index 806ac381b2..0573cced63 100644 --- a/configure.ml +++ b/configure.ml @@ -513,7 +513,12 @@ let caml_version_nums = let check_caml_version () = if caml_version_nums >= [3;12;1] then - printf "You have OCaml %s. Good!\n" caml_version + if caml_version_nums = [4;2;0] && not !Prefs.force_caml_version then + die ("Your version of OCaml is 4.02.0 which suffers from a bug inducing\n" ^ + "very slow compilation times. If you still want to use it, use \n" ^ + "option -force-caml-version.\n") + else + printf "You have OCaml %s. Good!\n" caml_version else let () = printf "Your version of OCaml is %s.\n" caml_version in if !Prefs.force_caml_version then -- cgit v1.2.3 From 032f1a4ba8b5655b4f2396671061613aa8e2cf48 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 25 Oct 2015 15:22:30 +0100 Subject: Fixing bugs in options of the configure. - usage ill-formed for -native-compiler - compatibility with the configure of 8.4 (-force-caml-version), though e.g. its force-ocaml-version alias is no longer supported (but at the same time not documented either, so...) --- configure.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/configure.ml b/configure.ml index 0573cced63..1945167168 100644 --- a/configure.ml +++ b/configure.ml @@ -332,11 +332,11 @@ let args_options = Arg.align [ "-makecmd", Arg.Set_string Prefs.makecmd, " Name of GNU Make command"; "-native-compiler", arg_bool Prefs.nativecompiler, - " (yes|no) Compilation to native code for conversion and normalization"; + "(yes|no) Compilation to native code for conversion and normalization"; "-coqwebsite", Arg.Set_string Prefs.coqwebsite, " URL of the coq website"; - "-force-caml-version", arg_bool Prefs.force_caml_version, - " Force OCaml version"; + "-force-caml-version", Arg.Set Prefs.force_caml_version, + "Force OCaml version"; ] let parse_args () = -- cgit v1.2.3 From 7bf9bbe2968802b48230d35d34c585201ee9e9b4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 25 Oct 2015 15:24:43 +0100 Subject: Seeing configure as a static resolution of path, hence hardwiring long paths for ocaml* executables in the generated config/Makefile. Hoping I'm not doing something wrong. E.g., I don't see why it would not be ok for windows or macosx too, since e.g. camlp5o was already with a full path. --- configure.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/configure.ml b/configure.ml index 1945167168..37c45f3e62 100644 --- a/configure.ml +++ b/configure.ml @@ -476,7 +476,10 @@ let camlbin, caml_version, camllib = rebase_camlexec dir camlexec; Filename.dirname camlexec.byte, camlexec.byte | None -> - try let camlc = which camlexec.byte in Filename.dirname camlc, camlc + try let camlc = which camlexec.byte in + let dir = Filename.dirname camlc in + rebase_camlexec dir camlexec; + dir, camlc with Not_found -> die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.byte ^ "Please adjust your path or use the -camldir option of ./configure") -- cgit v1.2.3 From fb50a8aaf8826349ac8c3a90a6d9b354b9cf34ca Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 26 Oct 2015 11:50:11 +0100 Subject: Type-safe grammar extensions. --- grammar/q_util.ml4 | 13 +++++++++++++ intf/extend.mli | 34 ++++++++++++++++++++++++++++++++++ parsing/egramcoq.ml | 8 ++++---- parsing/pcoq.ml | 29 +++++++++++++++++++++++++++-- parsing/pcoq.mli | 46 ++++++++++++++++++++++++++-------------------- 5 files changed, 104 insertions(+), 26 deletions(-) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 5ec7510f79..19f436f926 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -49,7 +49,20 @@ let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> +let mlexpr_of_token = function +| Tok.KEYWORD s -> <:expr< Tok.KEYWORD $mlexpr_of_string s$ >> +| Tok.METAIDENT s -> <:expr< Tok.METAIDENT $mlexpr_of_string s$ >> +| Tok.PATTERNIDENT s -> <:expr< Tok.PATTERNIDENT $mlexpr_of_string s$ >> +| Tok.IDENT s -> <:expr< Tok.IDENT $mlexpr_of_string s$ >> +| Tok.FIELD s -> <:expr< Tok.FIELD $mlexpr_of_string s$ >> +| Tok.INT s -> <:expr< Tok.INT $mlexpr_of_string s$ >> +| Tok.STRING s -> <:expr< Tok.STRING $mlexpr_of_string s$ >> +| Tok.LEFTQMARK -> <:expr< Tok.LEFTQMARK >> +| Tok.BULLET s -> <:expr< Tok.BULLET $mlexpr_of_string s$ >> +| Tok.EOI -> <:expr< Tok.EOI >> + let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = function + | Pcoq.Atoken t -> <:expr< Pcoq.Atoken $mlexpr_of_token t$ >> | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> diff --git a/intf/extend.mli b/intf/extend.mli index ad9706f3a5..aa0db52d7f 100644 --- a/intf/extend.mli +++ b/intf/extend.mli @@ -50,3 +50,37 @@ type constr_prod_entry_key = type simple_constr_prod_entry_key = (production_level,unit) constr_entry_key_gen + +(** {5 Type-safe grammar extension} *) + +type ('self, 'a) symbol = +| Atoken : Tok.t -> ('self, Tok.t) symbol +| Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol +| Alist1sep : ('self, 'a) symbol * string -> ('self, 'a list) symbol +| Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol +| Alist0sep : ('self, 'a) symbol * string -> ('self, 'a list) symbol +| Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol +| Amodifiers : ('self, 'a) symbol -> ('self, 'a list) symbol +| Aself : ('self, 'self) symbol +| Anext : ('self, 'self) symbol +| Aentry : 'a Entry.t -> ('self, 'a) symbol +| Aentryl : 'a Entry.t * int -> ('self, 'a) symbol + +type ('self, _, 'r) rule = +| Stop : ('self, 'r, 'r) rule +| Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule + +type 'a production_rule = +| Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule + +type 'a single_extend_statment = + string option * + (** Level *) + gram_assoc option * + (** Associativity *) + 'a production_rule list + (** Symbol list with the interpretation function *) + +type 'a extend_statment = + gram_position option * + 'a single_extend_statment list diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index fba754eaaf..7bfcf65e3e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -170,7 +170,7 @@ let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = let entry = if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr in - grammar_extend entry reinit (pos,[(name, p4assoc, [])]) + unsafe_grammar_extend entry reinit (pos,[(name, p4assoc, [])]) let pure_sublevels level symbs = let filter s = @@ -195,7 +195,7 @@ let extend_constr (entry,level) (n,assoc) mkact forpat rules = let pos,p4assoc,name,reinit = find_position forpat assoc level in let nb_decls = List.length needed_levels + 1 in List.iter (prepare_empty_levels forpat) needed_levels; - grammar_extend entry reinit (Option.map of_coq_position pos, + unsafe_grammar_extend entry reinit (Option.map of_coq_position pos, [(name, Option.map of_coq_assoc p4assoc, [symbs, mkact pt])]); nb_decls) 0 rules @@ -265,7 +265,7 @@ let add_ml_tactic_entry name prods = in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in synchronize_level_positions (); - grammar_extend entry None (None ,[(None, None, List.rev rules)]); + unsafe_grammar_extend entry None (None ,[(None, None, List.rev rules)]); 1 (* Declaration of the tactic grammar rule *) @@ -285,7 +285,7 @@ let add_tactic_entry kn tg = in let rules = make_rule mkact tg.tacgram_prods in synchronize_level_positions (); - grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]); + unsafe_grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]); 1 let (grammar_state : (int * all_grammar_command) list ref) = ref [] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 5b980b3489..1dea3497e4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -67,7 +67,8 @@ let weaken_entry x = Gramobj.weaken_entry x dynamically interpreted as entries for the Coq level extensions *) -type ('self, _) entry_key = +type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = +| Atoken : Tok.t -> ('self, Tok.t) entry_key | Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key | Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key @@ -168,7 +169,7 @@ module Gram = (** This extension command is used by the Grammar constr *) -let grammar_extend e reinit ext = +let unsafe_grammar_extend e reinit ext = camlp4_state := ByGrammar (weaken_entry e,reinit,ext) :: !camlp4_state; camlp4_verbose (maybe_uncurry (G.extend e)) ext @@ -707,6 +708,7 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function + | Atoken t -> Symbols.stoken t | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string sep) @@ -732,6 +734,29 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function let level_of_snterml e = int_of_string (Symbols.snterml_level e) +let rec of_coq_rule : type self a r. (self, a, r) Extend.rule -> _ = function +| Stop -> fun accu -> accu +| Next (r, tok) -> fun accu -> + let symb = symbol_of_prod_entry_key tok in + of_coq_rule r (symb :: accu) + +let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> Gram.action = function +| Stop -> fun f -> Gram.action (fun loc -> f (to_coqloc loc)) +| Next (r, _) -> fun f -> Gram.action (fun x -> of_coq_action r (f x)) + +let of_coq_production_rule : type a. a Extend.production_rule -> _ = function +| Rule (toks, act) -> (of_coq_rule toks [], of_coq_action toks act) + +let of_coq_single_extend_statement (lvl, assoc, rule) = + (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule) + +let of_coq_extend_statement (pos, st) = + (Option.map of_coq_position pos, List.map of_coq_single_extend_statement st) + +let grammar_extend e reinit ext = + let ext = of_coq_extend_statement ext in + unsafe_grammar_extend e reinit ext + (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 18eb3eed34..74b7bcc93f 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -105,12 +105,37 @@ type grammar_object (** Type of reinitialization data *) type gram_reinit = gram_assoc * gram_position +(** General entry keys *) + +(** This intermediate abstract representation of entries can + both be reified into mlexpr for the ML extensions and + dynamically interpreted as entries for the Coq level extensions +*) + +type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = +| Atoken : Tok.t -> ('self, Tok.t) entry_key +| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key +| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key +| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key +| Aself : ('self, 'self) entry_key +| Anext : ('self, 'self) entry_key +| Aentry : 'a Entry.t -> ('self, 'a) entry_key +| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key + (** Add one extension at some camlp4 position of some camlp4 entry *) -val grammar_extend : +val unsafe_grammar_extend : grammar_object Gram.entry -> gram_reinit option (** for reinitialization if ever needed *) -> Gram.extend_statment -> unit +val grammar_extend : + 'a Gram.entry -> + gram_reinit option (** for reinitialization if ever needed *) -> + 'a Extend.extend_statment -> unit + (** Remove the last n extensions *) val remove_grammars : int -> unit @@ -253,25 +278,6 @@ val symbol_of_constr_prod_entry_key : gram_assoc option -> constr_entry_key -> bool -> constr_prod_entry_key -> Gram.symbol -(** General entry keys *) - -(** This intermediate abstract representation of entries can - both be reified into mlexpr for the ML extensions and - dynamically interpreted as entries for the Coq level extensions -*) - -type ('self, _) entry_key = -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - val name_of_entry : 'a Gram.entry -> 'a Entry.t (** Binding general entry keys to symbols *) -- cgit v1.2.3 From 9b2bb33662a4a1e39202cb81f894b739782c3434 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 26 Oct 2015 14:35:02 +0100 Subject: Indexing existentially quantified entries returned by interp_entry_name. --- grammar/argextend.ml4 | 4 ++-- grammar/tacextend.ml4 | 6 +++--- grammar/vernacextend.ml4 | 2 +- parsing/egramcoq.ml | 4 ++-- parsing/egramcoq.mli | 4 ++-- parsing/egramml.ml | 4 ++-- parsing/egramml.mli | 14 ++++++++------ parsing/pcoq.ml | 2 +- parsing/pcoq.mli | 4 ++-- toplevel/metasyntax.ml | 2 +- toplevel/metasyntax.mli | 2 +- 11 files changed, 25 insertions(+), 23 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 7c20ff18e9..51949e8aad 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -51,8 +51,8 @@ let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >> let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >> let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> -let has_extraarg = - List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false) +let has_extraarg l = + List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false) l let rec is_possibly_empty : type s a. (s, a) entry_key -> bool = function | Aopt _ -> true diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 4709a79989..2c9a73a371 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -100,8 +100,8 @@ let make_prod_item = function <:expr< Egramml.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$ $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >> -let mlexpr_of_clause = - mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) +let mlexpr_of_clause cl = + mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) cl let rec make_tags loc = function | [] -> <:expr< [] >> @@ -120,7 +120,7 @@ let make_one_printing_rule (pt,_,e) = <:expr< { Pptactic.pptac_args = $make_tags loc pt$; pptac_prods = ($level$, $prods$) } >> -let make_printing_rule = mlexpr_of_list make_one_printing_rule +let make_printing_rule r = mlexpr_of_list make_one_printing_rule r let make_empty_check = function | GramNonTerminal(_, t, e, _)-> diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index d99af6a33d..f0fde2bf84 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -22,7 +22,7 @@ open Compat type rule = { r_head : string option; (** The first terminal grammar token *) - r_patt : grammar_prod_item list; + r_patt : Vernacexpr.vernac_expr grammar_prod_item list; (** The remaining tokens of the parsing rule *) r_class : MLast.expr option; (** An optional classifier for the STM *) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 7bfcf65e3e..14fe15e89e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -246,13 +246,13 @@ let get_tactic_entry n = type tactic_grammar = { tacgram_level : int; - tacgram_prods : grammar_prod_item list; + tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } type all_grammar_command = | Notation of Notation.level * notation_grammar | TacticGrammar of KerName.t * tactic_grammar - | MLTacticGrammar of ml_tactic_name * grammar_prod_item list list + | MLTacticGrammar of ml_tactic_name * Tacexpr.raw_tactic_expr grammar_prod_item list list (** ML Tactic grammar extensions *) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 2b0f7da8c2..cdd5fbd0f9 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -38,7 +38,7 @@ type notation_grammar = { type tactic_grammar = { tacgram_level : int; - tacgram_prods : grammar_prod_item list; + tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } (** {5 Adding notations} *) @@ -50,7 +50,7 @@ val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit (** Add a tactic notation rule to the parsing system. This produces a TacAlias tactic with the provided kernel name. *) -val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> grammar_prod_item list list -> unit +val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> Tacexpr.raw_tactic_expr grammar_prod_item list list -> unit (** Add a ML tactic notation rule to the parsing system. This produces a TacML tactic with the provided string as name. *) diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 8f07087085..77d60ff7d5 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -28,10 +28,10 @@ let make_generic_action (** Grammar extensions declared at ML level *) -type grammar_prod_item = +type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> grammar_prod_item + Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item let make_prod_item = function | GramTerminal s -> (gram_token_of_string s, None) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 60ec6a05a8..182a72086f 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -6,24 +6,26 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Vernacexpr + (** Mapping of grammar productions to camlp4 actions. *) (** This is the part specific to vernac extensions. For the Coq-level Notation and Tactic Notation, see Egramcoq. *) -type grammar_prod_item = +type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * Genarg.argument_type * - ('s, 'a) Pcoq.entry_key * Names.Id.t option -> grammar_prod_item + ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item val extend_vernac_command_grammar : - Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.entry option -> - grammar_prod_item list -> unit + Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> + vernac_expr grammar_prod_item list -> unit -val get_extend_vernac_rule : Vernacexpr.extend_name -> grammar_prod_item list +val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list (** Utility function reused in Egramcoq : *) val make_rule : (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'b) -> - grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action + 's grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 1dea3497e4..2227f7e9ce 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -80,7 +80,7 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = | Aentry : 'a Entry.t -> ('self, 'a) entry_key | Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name +type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name module type Gramtypes = sig diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 74b7bcc93f..8a1bc884a1 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -285,12 +285,12 @@ val name_of_entry : 'a Gram.entry -> 'a Entry.t val symbol_of_prod_entry_key : ('self, 'a) entry_key -> Gram.symbol -type entry_name = EntryName : entry_type * ('self, 'a) entry_key -> entry_name +type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name (** Interpret entry names of the form "ne_constr_list" as entry keys *) val interp_entry_name : bool (** true to fail on unknown entry *) -> - int option -> string -> string -> entry_name + int option -> string -> string -> 's entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * entry_type) list diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 780a8f111c..ca263e6cbb 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -160,7 +160,7 @@ type atomic_entry = string * Genarg.glob_generic_argument list option type ml_tactic_grammar_obj = { mltacobj_name : Tacexpr.ml_tactic_name; (** ML-side unique name *) - mltacobj_prod : grammar_prod_item list list; + mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list; (** Grammar rules generating the ML tactic. *) } diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index f22839f489..f7049999e1 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -24,7 +24,7 @@ val add_tactic_notation : type atomic_entry = string * Genarg.glob_generic_argument list option val add_ml_tactic_notation : ml_tactic_name -> - Egramml.grammar_prod_item list list -> atomic_entry list -> unit + Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> atomic_entry list -> unit (** Adding a (constr) notation in the environment*) -- cgit v1.2.3 From 7264b11ca63eeb57f3b42cd9869793308b6c552f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 26 Oct 2015 17:06:00 +0100 Subject: Type-safe Egramml.make_rule. --- parsing/egramml.ml | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 50 insertions(+), 2 deletions(-) diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 77d60ff7d5..96c1566c4f 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -43,6 +43,54 @@ let make_rule mkact pt = let act = make_generic_action mkact ntl in (symbs, act) +type 'a ty_arg = Id.t * ('a -> raw_generic_argument) + +type ('self, _, 'r) ty_rule = +| TyStop : ('self, 'r, 'r) ty_rule +| TyNext : ('self, 'a, 'r) ty_rule * ('self, 'b) Extend.symbol * 'b ty_arg option -> + ('self, 'b -> 'a, 'r) ty_rule + +type ('self, 'r) any_ty_rule = +| AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule + +let rec ty_rule_of_gram = function +| [] -> AnyTyRule TyStop +| GramTerminal s :: rem -> + let AnyTyRule rem = ty_rule_of_gram rem in + let tok = Atoken (Lexer.terminal s) in + let r = TyNext (rem, tok, None) in + AnyTyRule r +| GramNonTerminal (_, t, tok, idopt) :: rem -> + let AnyTyRule rem = ty_rule_of_gram rem in + let inj = match idopt with + | None -> None + | Some id -> + (** FIXME *) + Some (id, fun obj -> Genarg.Unsafe.inj t (Obj.repr obj)) + in + let r = TyNext (rem, tok, inj) in + AnyTyRule r + +let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = function +| TyStop -> Extend.Stop +| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) + +type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r + +let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +| TyStop -> fun f loc -> f loc [] +| TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f +| TyNext (rem, tok, Some (id, inj)) -> fun f x -> + let f loc args = f loc ((id, inj x) :: args) in + ty_eval rem f + +let make_rule' f prod = + let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in + let symb = ty_erase ty_rule in + let f loc l = f loc (List.rev l) in + let act = ty_eval ty_rule f in + Extend.Rule (symb, act) + (** Vernac grammar extensions *) let vernac_exts = ref [] @@ -59,5 +107,5 @@ let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s,List.map snd l) in - let rules = [make_rule mkact gl] in - maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)]) + let rules = [make_rule' mkact gl] in + grammar_extend nt None (None, [None, None, rules]) -- cgit v1.2.3 From 73c3dddc94dda003b1bb854d3b6ca9d15474e299 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 10:28:23 +0100 Subject: Getting rid of most uses of unsafe_grammar_extend. --- parsing/egramcoq.ml | 22 +++++++++------------- parsing/egramml.ml | 27 ++------------------------- parsing/egramml.mli | 4 ++-- 3 files changed, 13 insertions(+), 40 deletions(-) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 14fe15e89e..84736f8aba 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -167,10 +167,9 @@ let rec make_constr_prod_item assoc from forpat = function [] let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = - let entry = - if forpat then weaken_entry Constr.pattern - else weaken_entry Constr.operconstr in - unsafe_grammar_extend entry reinit (pos,[(name, p4assoc, [])]) + let empty = (pos, [(name, p4assoc, [])]) in + if forpat then grammar_extend Constr.pattern reinit empty + else grammar_extend Constr.operconstr reinit empty let pure_sublevels level symbs = let filter s = @@ -189,9 +188,6 @@ let extend_constr (entry,level) (n,assoc) mkact forpat rules = let symbs = make_constr_prod_item assoc n forpat pt in let pure_sublevels = pure_sublevels level symbs in let needed_levels = register_empty_levels forpat pure_sublevels in - let map_level (pos, ass1, name, ass2) = - (Option.map of_coq_position pos, Option.map of_coq_assoc ass1, name, ass2) in - let needed_levels = List.map map_level needed_levels in let pos,p4assoc,name,reinit = find_position forpat assoc level in let nb_decls = List.length needed_levels + 1 in List.iter (prepare_empty_levels forpat) needed_levels; @@ -233,11 +229,11 @@ let extend_constr_notation ng = let get_tactic_entry n = if Int.equal n 0 then - weaken_entry Tactic.simple_tactic, None + Tactic.simple_tactic, None else if Int.equal n 5 then - weaken_entry Tactic.binder_tactic, None + Tactic.binder_tactic, None else if 1<=n && n<5 then - weaken_entry Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) + Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) else error ("Invalid Tactic Notation level: "^(string_of_int n)^".") @@ -257,7 +253,7 @@ type all_grammar_command = (** ML Tactic grammar extensions *) let add_ml_tactic_entry name prods = - let entry = weaken_entry Tactic.simple_tactic in + let entry = Tactic.simple_tactic in let mkact i loc l : raw_tactic_expr = let open Tacexpr in let entry = { mltac_name = name; mltac_index = i } in @@ -265,7 +261,7 @@ let add_ml_tactic_entry name prods = in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in synchronize_level_positions (); - unsafe_grammar_extend entry None (None ,[(None, None, List.rev rules)]); + grammar_extend entry None (None, [(None, None, List.rev rules)]); 1 (* Declaration of the tactic grammar rule *) @@ -285,7 +281,7 @@ let add_tactic_entry kn tg = in let rules = make_rule mkact tg.tacgram_prods in synchronize_level_positions (); - unsafe_grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]); + grammar_extend entry None (pos, [(None, None, List.rev [rules])]); 1 let (grammar_state : (int * all_grammar_command) list ref) = ref [] diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 96c1566c4f..7a66b24f31 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -13,19 +13,6 @@ open Pcoq open Genarg open Vernacexpr -(** Making generic actions in type generic_argument *) - -let make_generic_action - (f:Loc.t -> ('b * raw_generic_argument) list -> 'a) pil = - let rec make env = function - | [] -> - Gram.action (fun loc -> f (to_coqloc loc) env) - | None :: tl -> (* parse a non-binding item *) - Gram.action (fun _ -> make env tl) - | Some (p, t) :: tl -> (* non-terminal *) - Gram.action (fun v -> make ((p, Unsafe.inj t v) :: env) tl) in - make [] (List.rev pil) - (** Grammar extensions declared at ML level *) type 's grammar_prod_item = @@ -33,16 +20,6 @@ type 's grammar_prod_item = | GramNonTerminal : Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item -let make_prod_item = function - | GramTerminal s -> (gram_token_of_string s, None) - | GramNonTerminal (_,t,e,po) -> - (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po) - -let make_rule mkact pt = - let (symbs,ntl) = List.split (List.map make_prod_item pt) in - let act = make_generic_action mkact ntl in - (symbs, act) - type 'a ty_arg = Id.t * ('a -> raw_generic_argument) type ('self, _, 'r) ty_rule = @@ -84,7 +61,7 @@ let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = fu let f loc args = f loc ((id, inj x) :: args) in ty_eval rem f -let make_rule' f prod = +let make_rule f prod = let AnyTyRule ty_rule = ty_rule_of_gram (List.rev prod) in let symb = ty_erase ty_rule in let f loc l = f loc (List.rev l) in @@ -107,5 +84,5 @@ let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s,List.map snd l) in - let rules = [make_rule' mkact gl] in + let rules = [make_rule mkact gl] in grammar_extend nt None (None, [None, None, rules]) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 182a72086f..32646cfafa 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -27,5 +27,5 @@ val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_ (** Utility function reused in Egramcoq : *) val make_rule : - (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'b) -> - 's grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action + (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'a) -> + 'a grammar_prod_item list -> 'a Extend.production_rule -- cgit v1.2.3 From d51e5688f521c8a77a1dbdb0b88d8f99d5ff8060 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 11:44:58 +0100 Subject: Finer type for Pcoq.interp_entry_name. --- grammar/argextend.ml4 | 12 ++++----- grammar/tacextend.ml4 | 8 +++--- grammar/vernacextend.ml4 | 8 +++--- parsing/pcoq.ml | 69 +++++++++++++++++++++++++++--------------------- parsing/pcoq.mli | 7 +++-- toplevel/metasyntax.ml | 4 +-- 6 files changed, 60 insertions(+), 48 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 51949e8aad..cfabd26889 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -280,8 +280,8 @@ EXTEND | e = argtype; LIDENT "option" -> OptArgType e ] | "0" [ e = LIDENT -> - let EntryName (t, _) = interp_entry_name false None e "" in - t + let EntryName (t, _) = interp_entry_name false TgAny e "" in + Genarg.unquote t | "("; e = argtype; ")" -> e ] ] ; argrule: @@ -289,11 +289,11 @@ EXTEND ; genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false None e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let EntryName (t, g) = interp_entry_name false TgAny e "" in + GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false None e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let EntryName (t, g) = interp_entry_name false TgAny e sep in + GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Lexer.add_keyword s; diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 2c9a73a371..8c2a45bae3 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -261,11 +261,11 @@ EXTEND ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false None e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let EntryName (t, g) = interp_entry_name false TgAny e "" in + GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false None e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let EntryName (t, g) = interp_entry_name false TgAny e sep in + GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); GramTerminal s diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index f0fde2bf84..5d4309aba0 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -181,11 +181,11 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false None e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let EntryName (t, g) = interp_entry_name false TgAny e "" in + GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false None e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let EntryName (t, g) = interp_entry_name false TgAny e sep in + GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) | s = STRING -> GramTerminal s ] ] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 2227f7e9ce..4bb1fd0a49 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -80,7 +80,8 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = | Aentry : 'a Entry.t -> ('self, 'a) entry_key | Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name +type 's entry_name = EntryName : + 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name module type Gramtypes = sig @@ -789,51 +790,64 @@ let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) else Aentryl (name_of_entry Tactic.tactic_expr, n) +let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type = + (** FIXME *) + Obj.magic + let try_get_entry u s = (** Order the effects: type_of_entry can raise Not_found *) let typ = type_of_entry u s in - Some typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s)) + let typ = unsafe_of_genarg typ in + EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) + +let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type = + fun t -> unsafe_of_genarg (ListArgType (unquote t)) + +let wit_opt : 'a raw_abstract_argument_type -> 'a option raw_abstract_argument_type = + fun t -> unsafe_of_genarg (OptArgType (unquote t)) + +type _ target = +| TgAny : 's target +| TgTactic : int -> Tacexpr.raw_tactic_expr target + +(** Quite ad-hoc *) +let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with +| TgAny -> EntryName (rawwit wit_tactic, atactic n) +| TgTactic m -> + let check_lvl n = + Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + if check_lvl n then EntryName (rawwit wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext) + else EntryName (rawwit wit_tactic, atactic n) let rec interp_entry_name static up_level s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - EntryName (ListArgType t, Alist1 g) + EntryName (wit_list t, Alist1 g) else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - EntryName (ListArgType t, Alist1sep (g,sep)) + EntryName (wit_list t, Alist1sep (g,sep)) else if l > 5 && coincide s "_list" (l-5) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - EntryName (ListArgType t, Alist0 g) + EntryName (wit_list t, Alist0 g) else if l > 9 && coincide s "_list_sep" (l-9) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - EntryName (ListArgType t, Alist0sep (g,sep)) + EntryName (wit_list t, Alist0sep (g,sep)) else if l > 4 && coincide s "_opt" (l-4) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - EntryName (OptArgType t, Aopt g) + EntryName (wit_opt t, Aopt g) else if l > 5 && coincide s "_mods" (l-5) then let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - EntryName (ListArgType t, Amodifiers g) + EntryName (wit_list t, Amodifiers g) else let s = match s with "hyp" -> "var" | _ -> s in - let check_lvl n = match up_level with - | None -> false - | Some m -> Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - let t, se = match tactic_level s with - | Some n -> - (** Quite ad-hoc *) - let t = unquote (rawwit wit_tactic) in - let se = - if check_lvl n then Aself - else if check_lvl (n + 1) then Anext - else atactic n - in - (Some t, se) + | Some n -> get_tacentry n up_level | None -> try try_get_entry uprim s with Not_found -> try try_get_entry uconstr s with Not_found -> @@ -841,12 +855,7 @@ let rec interp_entry_name static up_level s sep = if static then error ("Unknown entry "^s^".") else - None, Aentry (Entry.dynamic s) in - let t = - match t with - | Some t -> t - | None -> ExtraArgType s in - EntryName (t, se) + EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) let list_entry_names () = let add_entry key (entry, _) accu = (key, entry) :: accu in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 8a1bc884a1..69b25879bf 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -285,12 +285,15 @@ val name_of_entry : 'a Gram.entry -> 'a Entry.t val symbol_of_prod_entry_key : ('self, 'a) entry_key -> Gram.symbol -type 's entry_name = EntryName : entry_type * ('s, 'a) entry_key -> 's entry_name +type 's entry_name = EntryName : + 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name (** Interpret entry names of the form "ne_constr_list" as entry keys *) +type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target + val interp_entry_name : bool (** true to fail on unknown entry *) -> - int option -> string -> string -> 's entry_name + 's target -> string -> string -> 's entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * entry_type) list diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index ca263e6cbb..94b7fe5bc7 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -49,8 +49,8 @@ let interp_prod_item lev = function | TacTerm s -> GramTerminal s | TacNonTerm (loc, nt, po) -> let sep = match po with Some (_,sep) -> sep | _ -> "" in - let EntryName (etyp, e) = interp_entry_name true (Some lev) nt sep in - GramNonTerminal (loc, etyp, e, Option.map fst po) + let EntryName (etyp, e) = interp_entry_name true (TgTactic lev) nt sep in + GramNonTerminal (loc, Genarg.unquote etyp, e, Option.map fst po) let make_terminal_status = function | GramTerminal s -> Some s -- cgit v1.2.3 From 72bed859fb8d037044abd8a1518661c52502f7be Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 11:44:58 +0100 Subject: Type-safe Egramml.grammar_prod_item. --- dev/top_printers.ml | 4 ++-- grammar/argextend.ml4 | 28 ++++++++++++++++++++++------ grammar/tacextend.ml4 | 15 ++++++++++----- grammar/vernacextend.ml4 | 5 +++-- parsing/egramml.ml | 6 ++---- parsing/egramml.mli | 2 +- toplevel/metasyntax.ml | 4 ++-- 7 files changed, 42 insertions(+), 22 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 7b807a343a..b3b1ae0e91 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -519,7 +519,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,ConstrArgType,Aentry (Entry.unsafe_of_name ("constr","constr")), + (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), Some (Names.Id.of_string "c"))] let _ = @@ -536,7 +536,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,ConstrArgType,Aentry (Entry.unsafe_of_name ("constr","constr")), + (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), Some (Names.Id.of_string "c"))] (* Setting printer of unbound global reference *) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index cfabd26889..1fe66b3672 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -52,7 +52,15 @@ let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >> let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> let has_extraarg l = - List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false) l + let check = function + | GramNonTerminal(_, t, _, _) -> + begin match Genarg.unquote t with + | ExtraArgType _ -> true + | _ -> false + end + | _ -> false + in + List.exists check l let rec is_possibly_empty : type s a. (s, a) entry_key -> bool = function | Aopt _ -> true @@ -74,12 +82,15 @@ let rec get_empty_entry : type s a. (s, a) entry_key -> _ = function let statically_known_possibly_empty s (prods,_) = List.for_all (function - | GramNonTerminal(_,ExtraArgType s',_,_) -> + | GramNonTerminal(_,t,e,_) -> + begin match Genarg.unquote t with + | ExtraArgType s' -> (* For ExtraArg we don't know (we'll have to test dynamically) *) (* unless it is a recursive call *) s <> s' - | GramNonTerminal(_,_,e,_) -> + | _ -> is_possibly_empty e + end | GramTerminal _ -> (* This consumes a token for sure *) false) prods @@ -93,7 +104,11 @@ let possibly_empty_subentries loc (prods,act) = | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >> | GramNonTerminal(_,_,e,p) :: tl when is_possibly_empty e -> bind_name p (get_empty_entry e) (aux tl) - | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl -> + | GramNonTerminal(_,t,_,p) :: tl -> + let t = match Genarg.unquote t with + | ExtraArgType _ as t -> t + | _ -> assert false + in (* We check at runtime if extraarg s parses "epsilon" *) let s = match p with None -> "_" | Some id -> Names.Id.to_string id in <:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with @@ -129,6 +144,7 @@ let make_act loc act pil = let rec make = function | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >> | GramNonTerminal (_,t,_,Some p) :: tl -> + let t = Genarg.unquote t in let p = Names.Id.to_string p in <:expr< Pcoq.Gram.action @@ -290,10 +306,10 @@ EXTEND genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Lexer.add_keyword s; diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 8c2a45bae3..df2209606d 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -39,13 +39,14 @@ let rec make_when loc = function let p = Names.Id.to_string p in let l = make_when loc l in let loc = CompatLoc.merge loc' loc in - let t = mlexpr_of_argtype loc' t in + let t = mlexpr_of_argtype loc' (Genarg.unquote t) in <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >> | _::l -> make_when loc l let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> | GramNonTerminal(loc,t,_,Some p)::l -> + let t = Genarg.unquote t in let loc = of_coqloc loc in let p = Names.Id.to_string p in let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in @@ -58,7 +59,7 @@ let rec make_let raw e = function let rec extract_signature = function | [] -> [] - | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l + | GramNonTerminal (_,t,_,_) :: l -> Genarg.unquote t :: extract_signature l | _::l -> extract_signature l @@ -83,6 +84,7 @@ let make_fun_clauses loc s l = let rec make_args = function | [] -> <:expr< [] >> | GramNonTerminal(loc,t,_,Some p)::l -> + let t = Genarg.unquote t in let loc = of_coqloc loc in let p = Names.Id.to_string p in <:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >> @@ -97,7 +99,8 @@ let make_prod_item = function | GramTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> | GramNonTerminal (loc,nt,g,sopt) -> let loc = of_coqloc loc in - <:expr< Egramml.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$ + let nt = Genarg.unquote nt in + <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >> let mlexpr_of_clause cl = @@ -109,6 +112,7 @@ let rec make_tags loc = function let loc' = of_coqloc loc' in let l = make_tags loc l in let loc = CompatLoc.merge loc' loc in + let t = Genarg.unquote t in let t = mlexpr_of_argtype loc' t in <:expr< [ $t$ :: $l$ ] >> | _::l -> make_tags loc l @@ -124,6 +128,7 @@ let make_printing_rule r = mlexpr_of_list make_one_printing_rule r let make_empty_check = function | GramNonTerminal(_, t, e, _)-> + let t = Genarg.unquote t in let is_extra = match t with ExtraArgType _ -> true | _ -> false in if is_possibly_empty e || is_extra then (* This possibly parses epsilon *) @@ -262,10 +267,10 @@ EXTEND tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); GramTerminal s diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 5d4309aba0..54638556db 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -35,6 +35,7 @@ type rule = { let rec make_let e = function | [] -> e | GramNonTerminal(loc,t,_,Some p)::l -> + let t = Genarg.unquote t in let loc = of_coqloc loc in let p = Names.Id.to_string p in let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in @@ -182,10 +183,10 @@ EXTEND args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, Genarg.unquote t, g, Some (Names.Id.of_string s)) + GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) | s = STRING -> GramTerminal s ] ] diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 7a66b24f31..984027b815 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -18,7 +18,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item type 'a ty_arg = Id.t * ('a -> raw_generic_argument) @@ -41,9 +41,7 @@ let rec ty_rule_of_gram = function let AnyTyRule rem = ty_rule_of_gram rem in let inj = match idopt with | None -> None - | Some id -> - (** FIXME *) - Some (id, fun obj -> Genarg.Unsafe.inj t (Obj.repr obj)) + | Some id -> Some (id, fun obj -> Genarg.in_gen t obj) in let r = TyNext (rem, tok, inj) in AnyTyRule r diff --git a/parsing/egramml.mli b/parsing/egramml.mli index 32646cfafa..e3ae4e0118 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -15,7 +15,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string - | GramNonTerminal : Loc.t * Genarg.argument_type * + | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item val extend_vernac_command_grammar : diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 94b7fe5bc7..7714cc8108 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -50,7 +50,7 @@ let interp_prod_item lev = function | TacNonTerm (loc, nt, po) -> let sep = match po with Some (_,sep) -> sep | _ -> "" in let EntryName (etyp, e) = interp_entry_name true (TgTactic lev) nt sep in - GramNonTerminal (loc, Genarg.unquote etyp, e, Option.map fst po) + GramNonTerminal (loc, etyp, e, Option.map fst po) let make_terminal_status = function | GramTerminal s -> Some s @@ -58,7 +58,7 @@ let make_terminal_status = function let rec make_tags = function | GramTerminal s :: l -> make_tags l - | GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l + | GramNonTerminal (loc, etyp, _, po) :: l -> Genarg.unquote etyp :: make_tags l | [] -> [] let make_fresh_key = -- cgit v1.2.3 From 04b244a4ba8605a97cd96855b4c4e628ba27db7b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 14:08:54 +0100 Subject: Removing unused code in Pcoq. --- parsing/pcoq.ml | 1 - parsing/pcoq.mli | 16 +--------------- 2 files changed, 1 insertion(+), 16 deletions(-) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 4bb1fd0a49..b017fddc71 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -52,7 +52,6 @@ end (** Grammar entries with associated types *) -type entry_type = argument_type type grammar_object = Gramobj.grammar_object type typed_entry = argument_type * grammar_object G.entry let in_typed_entry t e = (t,Gramobj.weaken_entry e) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 69b25879bf..9a27b6e045 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -139,19 +139,6 @@ val grammar_extend : (** Remove the last n extensions *) val remove_grammars : int -> unit - - - -(** The type of typed grammar objects *) -type typed_entry - -(** The possible types for extensible grammars *) -type entry_type = argument_type - -val type_of_typed_entry : typed_entry -> entry_type -val object_of_typed_entry : typed_entry -> grammar_object Gram.entry -val weaken_entry : 'a Gram.entry -> grammar_object Gram.entry - (** Temporary activate camlp4 verbosity *) val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit @@ -171,7 +158,6 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe -val create_entry : gram_universe -> string -> entry_type -> typed_entry val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> 'a Gram.entry @@ -296,7 +282,7 @@ val interp_entry_name : bool (** true to fail on unknown entry *) -> 's target -> string -> string -> 's entry_name (** Recover the list of all known tactic notation entries. *) -val list_entry_names : unit -> (string * entry_type) list +val list_entry_names : unit -> (string * argument_type) list (** Registering/resetting the level of a constr entry *) -- cgit v1.2.3 From ed7af646f2e486b7e96812ba2335e644756b70fd Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 27 Oct 2015 13:55:45 -0400 Subject: Fix bugs 4389, 4390 and 4391 due to wrong handling of universe names structure. --- library/declare.ml | 93 +++++++++++++++++++++++++------------------ library/declare.mli | 4 +- library/lib.ml | 39 ++++++++++++------ library/lib.mli | 2 +- library/universes.ml | 3 +- test-suite/bugs/closed/4390.v | 37 +++++++++++++++++ toplevel/command.ml | 4 +- toplevel/command.mli | 5 ++- toplevel/vernacentries.ml | 25 ++++++++---- 9 files changed, 147 insertions(+), 65 deletions(-) create mode 100644 test-suite/bugs/closed/4390.v diff --git a/library/declare.ml b/library/declare.ml index 16803b3bfa..0004f45a29 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -27,7 +27,7 @@ open Decls open Decl_kinds (** flag for internal message display *) -type internal_flag = +type internal_flag = | UserAutomaticRequest (* kernel action, a message is displayed *) | InternalTacticRequest (* kernel action, no message is displayed *) | UserIndividualRequest (* user action, a message is displayed *) @@ -63,7 +63,7 @@ let cache_variable ((sp,_),o) = add_variable_data id (p,opaq,ctx,poly,mk) let discharge_variable (_,o) = match o with - | Inr (id,_) -> + | Inr (id,_) -> if variable_polymorphic id then None else Some (Inl (variable_context id)) | Inl _ -> Some o @@ -156,7 +156,7 @@ let discharge_constant ((sp, kn), obj) = Some { obj with cst_hyps = new_hyps; cst_decl = new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant_entry = +let dummy_constant_entry = ConstantEntry (ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) let dummy_constant cst = { @@ -185,7 +185,7 @@ let declare_constant_common id cst = Notation.declare_ref_arguments_scope (ConstRef c); c -let definition_entry ?(opaque=false) ?(inline=false) ?types +let definition_entry ?(opaque=false) ?(inline=false) ?types ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Declareops.no_seff) body = { const_entry_body = Future.from_val ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; @@ -212,11 +212,11 @@ let declare_sideff env fix_exn se = in let ty_of cb = match cb.Declarations.const_type with - | Declarations.RegularArity t -> Some t + | Declarations.RegularArity t -> Some t | Declarations.TemplateArity _ -> None in let cst_of cb pt = let pt, opaque = pt_opaque_of cb pt in - let univs, subst = + let univs, subst = if cb.const_polymorphic then let univs = Univ.instantiate_univ_context cb.const_universes in univs, Vars.subst_instance_constr (Univ.UContext.instance univs) @@ -240,7 +240,7 @@ let declare_sideff env fix_exn se = } in let exists c = try ignore(Environ.lookup_constant c env); true - with Not_found -> false in + with Not_found -> false in let knl = CList.map_filter (fun (c,cb,pt) -> if exists c then None @@ -287,7 +287,7 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) ?(poly=false) id ?types (body,ctx) = - let cb = + let cb = definition_entry ?types ~poly ~univs:(Univ.ContextSet.to_context ctx) ~opaque body in declare_constant ~internal ~local id @@ -383,12 +383,12 @@ let inInductive : inductive_obj -> obj = let declare_projections mind = let spec,_ = Inductive.lookup_mind_specif (Global.env ()) (mind,0) in match spec.mind_record with - | Some (Some (_, kns, pjs)) -> - Array.iteri (fun i kn -> + | Some (Some (_, kns, pjs)) -> + Array.iteri (fun i kn -> let id = Label.to_id (Constant.label kn) in let entry = {proj_entry_ind = mind; proj_entry_arg = i} in let kn' = declare_constant id (ProjectionEntry entry, - IsDefinition StructureComponent) + IsDefinition StructureComponent) in assert(eq_constant kn kn')) kns; true | Some None | None -> false @@ -442,52 +442,69 @@ let assumption_message id = (** Global universe names, in a different summary *) -type universe_names = +type universe_names = (Univ.universe_level Idmap.t * Id.t Univ.LMap.t) -let input_universes : universe_names -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Global universe name state") with - cache_function = (fun (na, pi) -> Universes.set_global_universe_names pi); - load_function = (fun _ (_, pi) -> Universes.set_global_universe_names pi); - discharge_function = (fun (_, a) -> Some a); - classify_function = (fun a -> Keep a) } +(* Discharged or not *) +type universe_decl = polymorphic * (Id.t * Univ.universe_level) list -let do_universe l = +let cache_universes (p, l) = let glob = Universes.global_universe_names () in - let glob', ctx = - List.fold_left (fun ((idl,lid),ctx) (l, id) -> - let lev = Universes.new_univ_level (Global.current_dirpath ()) in - ((Idmap.add id lev idl, Univ.LMap.add lev id lid), - Univ.ContextSet.add_universe lev ctx)) + let glob', ctx = + List.fold_left (fun ((idl,lid),ctx) (id, lev) -> + ((Idmap.add id lev idl, Univ.LMap.add lev id lid), + Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in Global.push_context_set false ctx; - Lib.add_anonymous_leaf (input_universes glob') + if p then Lib.add_section_context ctx; + Universes.set_global_universe_names glob' + +let input_universes : universe_decl -> Libobject.obj = + declare_object + { (default_object "Global universe name state") with + cache_function = (fun (na, pi) -> cache_universes pi); + load_function = (fun _ (_, pi) -> cache_universes pi); + discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); + classify_function = (fun a -> Keep a) } + +let do_universe poly l = + let l = + List.map (fun (l, id) -> + let lev = Universes.new_univ_level (Global.current_dirpath ()) in + (id, lev)) l + in + Lib.add_anonymous_leaf (input_universes (poly, l)) + +type constraint_decl = polymorphic * Univ.constraints + +let cache_constraints (na, (p, c)) = + Global.add_constraints c; + if p then Lib.add_section_context (Univ.ContextSet.add_constraints c Univ.ContextSet.empty) +let discharge_constraints (_, (p, c as a)) = + if p then None else Some a -let input_constraints : Univ.constraints -> Libobject.obj = - let open Libobject in +let input_constraints : constraint_decl -> Libobject.obj = + let open Libobject in declare_object { (default_object "Global universe constraints") with - cache_function = (fun (na, c) -> Global.add_constraints c); - load_function = (fun _ (_, c) -> Global.add_constraints c); - discharge_function = (fun (_, a) -> Some a); + cache_function = cache_constraints; + load_function = (fun _ -> cache_constraints); + discharge_function = discharge_constraints; classify_function = (fun a -> Keep a) } -let do_constraint l = - let u_of_id = +let do_constraint poly l = + let u_of_id = let names, _ = Universes.global_universe_names () in - fun (loc, id) -> + fun (loc, id) -> try Idmap.find id names with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) in let constraints = List.fold_left (fun acc (l, d, r) -> let lu = u_of_id l and ru = u_of_id r in Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l in - Lib.add_anonymous_leaf (input_constraints constraints) - + Lib.add_anonymous_leaf (input_constraints (poly, constraints)) diff --git a/library/declare.mli b/library/declare.mli index 76538a6248..7ed451c3f1 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -85,5 +85,5 @@ val exists_name : Id.t -> bool (** Global universe names and constraints *) -val do_universe : Id.t Loc.located list -> unit -val do_constraint : (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit +val do_universe : polymorphic -> Id.t Loc.located list -> unit +val do_constraint : polymorphic -> (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit diff --git a/library/lib.ml b/library/lib.ml index f4f52db53b..cdc8889037 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -392,10 +392,13 @@ type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t +type secentry = + | Variable of (Names.Id.t * Decl_kinds.binding_kind * + Decl_kinds.polymorphic * Univ.universe_context_set) + | Context of Univ.universe_context_set + let sectab = - Summary.ref ([] : ((Names.Id.t * Decl_kinds.binding_kind * - Decl_kinds.polymorphic * Univ.universe_context_set) list * - Opaqueproof.work_list * abstr_list) list) + Summary.ref ([] : (secentry list * Opaqueproof.work_list * abstr_list) list) ~name:"section-context" let add_section () = @@ -406,21 +409,29 @@ let add_section_variable id impl poly ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> - sectab := ((id,impl,poly,ctx)::vars,repl,abs)::sl + sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl + +let add_section_context ctx = + match !sectab with + | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) + | (vars,repl,abs)::sl -> + sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = let rec aux = function - | ((id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> + | (Variable (id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> let l, r = aux (idl,hyps) in (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r - | ((_,_,poly,ctx)::idl,hyps) -> + | (Variable (_,_,poly,ctx)::idl,hyps) -> let l, r = aux (idl,hyps) in l, if poly then Univ.ContextSet.union r ctx else r + | (Context ctx :: idl, hyps) -> + let l, r = aux (idl, hyps) in + l, Univ.ContextSet.union r ctx | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) let instance_from_variable_context sign = - let rec inst_rec = function | (id,b,None,_) :: sign -> id :: inst_rec sign | _ :: sign -> inst_rec sign @@ -437,7 +448,8 @@ let add_section_replacement f g hyps = let ctx = Univ.ContextSet.to_context ctx in let subst, ctx = Univ.abstract_universes true ctx in let args = instance_from_variable_context (List.rev sechyps) in - sectab := (vars,f (Univ.UContext.instance ctx,args) exps,g (sechyps,subst,ctx) abs)::sl + sectab := (vars,f (Univ.UContext.instance ctx,args) exps, + g (sechyps,subst,ctx) abs)::sl let add_section_kn kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in @@ -457,10 +469,13 @@ let section_segment_of_mutual_inductive kn = let section_instance = function | VarRef id -> - if List.exists (fun (id',_,_,_) -> Names.id_eq id id') - (pi1 (List.hd !sectab)) - then Univ.Instance.empty, [||] - else raise Not_found + let eq = function + | Variable (id',_,_,_) -> Names.id_eq id id' + | Context _ -> false + in + if List.exists eq (pi1 (List.hd !sectab)) + then Univ.Instance.empty, [||] + else raise Not_found | ConstRef con -> Names.Cmap.find con (fst (pi2 (List.hd !sectab))) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> diff --git a/library/lib.mli b/library/lib.mli index 9c4d26c5b2..b67b2b873f 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -172,7 +172,7 @@ val section_instance : Globnames.global_reference -> Univ.universe_instance * Na val is_in_section : Globnames.global_reference -> bool val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit - +val add_section_context : Univ.universe_context_set -> unit val add_section_constant : bool (* is_projection *) -> Names.constant -> Context.named_context -> unit val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit diff --git a/library/universes.ml b/library/universes.ml index 0656188eb5..30d38eb2a4 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -16,7 +16,8 @@ open Univ type universe_names = Univ.universe_level Idmap.t * Id.t Univ.LMap.t -let global_universes = Summary.ref ~name:"Global universe names" +let global_universes = + Summary.ref ~name:"Global universe names" ((Idmap.empty, Univ.LMap.empty) : universe_names) let global_universe_names () = !global_universes diff --git a/test-suite/bugs/closed/4390.v b/test-suite/bugs/closed/4390.v new file mode 100644 index 0000000000..a96a137001 --- /dev/null +++ b/test-suite/bugs/closed/4390.v @@ -0,0 +1,37 @@ +Module A. +Set Printing All. +Set Printing Universes. + +Module M. +Section foo. +Universe i. +End foo. +End M. + +Check Type@{i}. +(* Succeeds *) + +Fail Check Type@{j}. +(* Error: Undeclared universe: j *) + +Definition foo@{j} : Type@{i} := Type@{j}. +(* ok *) +End A. + +Set Universe Polymorphism. +Fail Universes j. +Monomorphic Universe j. +Section foo. + Universes i. + Constraint i < j. + Definition foo : Type@{j} := Type@{i}. + Definition foo' : Type@{j} := Type@{i}. +End foo. + +Check eq_refl : foo@{i} = foo'@{i}. + +Definition bar := foo. +Monomorphic Definition bar'@{k} := foo@{k}. + +Fail Constraint j = j. +Monomorphic Constraint i = i. diff --git a/toplevel/command.ml b/toplevel/command.ml index 7c86d2d059..3995c4b1bc 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -38,8 +38,8 @@ open Indschemes open Misctypes open Vernacexpr -let do_universe l = Declare.do_universe l -let do_constraint l = Declare.do_constraint l +let do_universe poly l = Declare.do_universe poly l +let do_constraint poly l = Declare.do_constraint poly l let rec under_binders env sigma f n c = if Int.equal n 0 then snd (f env sigma c) else diff --git a/toplevel/command.mli b/toplevel/command.mli index b1e1d7d060..b400f0fde2 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -20,8 +20,9 @@ open Pfedit (** This file is about the interpretation of raw commands into typed ones and top-level declaration of the main Gallina objects *) -val do_universe : Id.t Loc.located list -> unit -val do_constraint : (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit +val do_universe : polymorphic -> Id.t Loc.located list -> unit +val do_constraint : polymorphic -> + (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit (** {6 Hooks for Pcoq} *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index d04d6c9eda..2879947a91 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -552,12 +552,12 @@ let vernac_inductive poly lo finite indl = Errors.error "The Variant keyword cannot be used to define a record type. Use Record instead." | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record (match b with Class true -> Class false | _ -> b) - poly finite id bl c oc fs + poly finite id bl c oc fs | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in - (((coe', AssumExpr ((loc, Name id), ce)), None), []) + (((coe', AssumExpr ((loc, Name id), ce)), None), []) in vernac_record (Class true) poly finite id bl c None [f] | [ ( id , bl , c , Class true, _), _ ] -> Errors.error "Definitional classes must have a single method" @@ -602,8 +602,19 @@ let vernac_combined_scheme lid l = List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l); Indschemes.do_combined_scheme lid l -let vernac_universe l = do_universe l -let vernac_constraint l = do_constraint l +let vernac_universe loc poly l = + if poly && not (Lib.sections_are_opened ()) then + user_err_loc (loc, "vernac_universe", + str"Polymorphic universes can only be declared inside sections, " ++ + str "use Monomorphic Universe instead"); + do_universe poly l + +let vernac_constraint loc poly l = + if poly && not (Lib.sections_are_opened ()) then + user_err_loc (loc, "vernac_constraint", + str"Polymorphic universe constraints can only be declared" + ++ str " inside sections, use Monomorphic Constraint instead"); + do_constraint poly l (**********************) (* Modules *) @@ -1870,8 +1881,8 @@ let interp ?proof ~loc locality poly c = | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe l - | VernacConstraint l -> vernac_constraint l + | VernacUniverse l -> vernac_universe loc poly l + | VernacConstraint l -> vernac_constraint loc poly l (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> @@ -2034,7 +2045,7 @@ let check_vernac_supports_polymorphism c p = | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ | VernacHints _ | VernacContext _ - | VernacExtend _ ) -> () + | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> () | Some _, _ -> Errors.error "This command does not support Polymorphism" let enforce_polymorphism = function -- cgit v1.2.3 From d8cea1c80b71d2cd65daa4bc2126f1bfc61b0047 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 27 Oct 2015 21:57:13 +0100 Subject: Type-safe Argextend. --- grammar/argextend.ml4 | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 1fe66b3672..08651de640 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -142,26 +142,28 @@ let make_possibly_empty_subentries loc s cl = let make_act loc act pil = let rec make = function - | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >> + | [] -> <:expr< (fun loc -> $act$) >> | GramNonTerminal (_,t,_,Some p) :: tl -> let t = Genarg.unquote t in let p = Names.Id.to_string p in <:expr< - Pcoq.Gram.action (fun $lid:p$ -> let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) >> | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl -> - <:expr< Pcoq.Gram.action (fun _ -> $make tl$) >> in + <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function - | GramTerminal s -> <:expr< Pcoq.gram_token_of_string $str:s$ >> - | GramNonTerminal (_,_,g,_) -> - <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >> + | GramTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> + | GramNonTerminal (_,_,g,_) -> mlexpr_of_prod_entry_key g + +let rec make_prod = function +| [] -> <:expr< Extend.Stop >> +| item :: prods -> <:expr< Extend.Next $make_prod prods$ $make_prod_item item$ >> let make_rule loc (prods,act) = - <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >> + <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let rawtyp, rawpr, globtyp, globpr = match typ with @@ -224,8 +226,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = <:str_item< value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; <:str_item< do { - Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a)) - (None, [(None, None, $rules$)]); + Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$ } >> ] @@ -245,8 +246,7 @@ let declare_vernac_argument loc s pr cl = <:str_item< value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; <:str_item< do { - Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a)) - (None, [(None, None, $rules$)]); + Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule $wit$ $pr_rules$ (fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not globwit printer")) -- cgit v1.2.3 From 1235c6c3cfc6770920f46de30b1c4b0f5cb44b19 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 28 Oct 2015 12:49:03 +0100 Subject: Do not pause globing in funind. (Fix bug #4382) Since the functions of this plugin exit by raising exceptions, globing was never restarted. This prevented coqdoc from generating a proper output whenever some feature of this plugin was used. There does not seem to be any parsing of dynamic expressions, so pausing globing does not make much sense in the first place. --- plugins/funind/functional_principles_types.ml | 7 +------ plugins/funind/indfun.ml | 9 ++------- 2 files changed, 3 insertions(+), 13 deletions(-) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 64284c6fe7..9e27ddf2e9 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -594,9 +594,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr in const::other_result - let build_scheme fas = - Dumpglob.pause (); let evd = (ref (Evd.from_env (Global.env ()))) in let pconstants = (List.map (fun (_,f,sort) -> @@ -626,10 +624,7 @@ let build_scheme fas = Declare.definition_message princ_id ) fas - bodies_types; - Dumpglob.continue () - - + bodies_types let build_case_scheme fa = let env = Global.env () diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index eadeebd38e..47c67ed2aa 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -27,7 +27,6 @@ let choose_dest_or_ind scheme_info = Tactics.induction_destruct (is_rec_info scheme_info) false let functional_induction with_clean c princl pat = - Dumpglob.pause (); let res = let f,args = decompose_app c in fun g -> @@ -123,9 +122,7 @@ let functional_induction with_clean c princl pat = (args_as_induction_constr,princ'))) subst_and_reduce g' - in - Dumpglob.continue (); - res + in res let rec abstract_glob_constr c = function | [] -> c @@ -831,7 +828,6 @@ let make_graph (f_ref:global_reference) = end | _ -> raise (UserError ("", str "Not a function reference") ) in - Dumpglob.pause (); (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" | Some body -> @@ -883,8 +879,7 @@ let make_graph (f_ref:global_reference) = (* We register the infos *) List.iter (fun ((((_,id),_),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) - expr_list); - Dumpglob.continue () + expr_list) let do_generate_principle = do_generate_principle [] warning_error true -- cgit v1.2.3 From 38aacaa96abee65edb64bf88f15016d54ce31568 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 27 Oct 2015 18:13:55 +0100 Subject: Seeing configure as a static resolution of path continued (not yet on windows). This makes sense probably on Windows too, to be evaluated, maybe .exe suffix should be added. --- configure.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ml b/configure.ml index 37c45f3e62..173429ba8e 100644 --- a/configure.ml +++ b/configure.ml @@ -478,7 +478,7 @@ let camlbin, caml_version, camllib = | None -> try let camlc = which camlexec.byte in let dir = Filename.dirname camlc in - rebase_camlexec dir camlexec; + if not arch_win32 then rebase_camlexec dir camlexec; (* win32: TOCHECK *) dir, camlc with Not_found -> die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.byte ^ -- cgit v1.2.3 From e3ec13976d39909ac6f1a82bf1b243ba8a895190 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 28 Oct 2015 12:42:27 +0100 Subject: Revert "Fixing #4198 (continued): not matching within the inner lambdas/let-ins" After all, let's target 8.6. --- pretyping/constr_matching.ml | 19 +++---------------- test-suite/success/ltac.v | 26 -------------------------- 2 files changed, 3 insertions(+), 42 deletions(-) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 3fa037ffdd..5e99521a12 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -413,25 +413,12 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in let sub = (env, c1) :: subargs env lc in try_aux sub mk_ctx next - | Case (ci,p,c,brs) -> - (* Warning: this assumes predicate and branches to be - in canonical form using let and fun of the signature *) - let nardecls = List.length ci.ci_pp_info.ind_tags in - let sign_p,p = decompose_lam_n_decls (nardecls + 1) p in - let env_p = Environ.push_rel_context sign_p env in - let brs = Array.map2 decompose_lam_n_decls ci.ci_cstr_ndecls brs in - let sign_brs = Array.map fst brs in - let f (sign,br) = (Environ.push_rel_context sign env, br) in - let sub_br = Array.map f brs in + | Case (ci,hd,c1,lc) -> let next_mk_ctx = function - | c :: p :: brs -> - let p = it_mkLambda_or_LetIn p sign_p in - let brs = - Array.map2 it_mkLambda_or_LetIn (Array.of_list brs) sign_brs in - mk_ctx (mkCase (ci,p,c,brs)) + | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) | _ -> assert false in - let sub = (env, c) :: (env_p, p) :: Array.to_list sub_br in + let sub = (env, c1) :: (env, hd) :: subargs env lc in try_aux sub next_mk_ctx next | Fix (indx,(names,types,bodies)) -> let nb_fix = Array.length types in diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 5bef2e512a..6c4d4ae98f 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -317,29 +317,3 @@ let T := constr:(fun a b : nat => a) in end. exact (eq_refl n). Qed. - -(* Check that matching "match" does not look into the invisible - canonically generated binders of the return clause and of the branches *) - -Goal forall n, match n with 0 => true | S _ => false end = true. -intros. unfold nat_rect. -Fail match goal with |- context [nat] => idtac end. -Abort. - -(* Check that branches of automatically generated elimination - principle are correctly eta-expanded and hence matchable as seen - from the user point of view *) - -Goal forall a f n, nat_rect (fun _ => nat) a f n = 0. -intros. unfold nat_rect. -match goal with |- context [f _] => idtac end. -Abort. - -(* Check that branches of automatically generated elimination - principle are in correct form also in the presence of let-ins *) - -Inductive a (b:=0) : let b':=1 in Type := c : let d:=0 in a. -Goal forall x, match x with c => 0 end = 1. -intros. -match goal with |- context [0] => idtac end. -Abort. -- cgit v1.2.3 From 4444f04cfdbe449d184ac1ce0a56eb484805364d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 28 Oct 2015 12:56:29 +0100 Subject: Fixing the return type of the Atoken symbol. --- intf/extend.mli | 2 +- parsing/pcoq.ml | 2 +- parsing/pcoq.mli | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/intf/extend.mli b/intf/extend.mli index aa0db52d7f..975f194b07 100644 --- a/intf/extend.mli +++ b/intf/extend.mli @@ -54,7 +54,7 @@ type simple_constr_prod_entry_key = (** {5 Type-safe grammar extension} *) type ('self, 'a) symbol = -| Atoken : Tok.t -> ('self, Tok.t) symbol +| Atoken : Tok.t -> ('self, string) symbol | Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol | Alist1sep : ('self, 'a) symbol * string -> ('self, 'a list) symbol | Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b017fddc71..4565b87a01 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -67,7 +67,7 @@ let weaken_entry x = Gramobj.weaken_entry x *) type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, Tok.t) entry_key +| Atoken : Tok.t -> ('self, string) entry_key | Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key | Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 9a27b6e045..c224dbad9c 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -113,7 +113,7 @@ type gram_reinit = gram_assoc * gram_position *) type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, Tok.t) entry_key +| Atoken : Tok.t -> ('self, string) entry_key | Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key | Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key | Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -- cgit v1.2.3 From b5a0e384b405f64fd0854d5e88b55e8c2a159c02 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 28 Oct 2015 11:02:09 -0400 Subject: Univs: fix bug #4375, accept universe binders on (co)-fixpoints --- plugins/funind/indfun.ml | 2 +- test-suite/bugs/closed/4375.v | 106 ++++++++++++++++++++++++++++++++++++++++++ toplevel/command.ml | 44 +++++++++++------- toplevel/command.mli | 8 ++-- 4 files changed, 139 insertions(+), 21 deletions(-) create mode 100644 test-suite/bugs/closed/4375.v diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 47c67ed2aa..3dbd438061 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -592,7 +592,7 @@ let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),ctx,_) = Command.interp_fixpoint fixl ntns in + let ((_,_,typel),_,ctx,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx))) typel in let fixpoint_exprl_with_new_bl = diff --git a/test-suite/bugs/closed/4375.v b/test-suite/bugs/closed/4375.v new file mode 100644 index 0000000000..03af16535b --- /dev/null +++ b/test-suite/bugs/closed/4375.v @@ -0,0 +1,106 @@ + + +Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + + +Module A. +Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => foo t n + end. +End A. + +Module B. +Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => foo t n + end. +End B. + +Module C. +Fail Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{j} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End C. + +Module D. +Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{i j} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End D. + +Module E. +Fail Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{j i} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End E. + +(* +Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + +Print g. + +Polymorphic Fixpoint a@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t +with b@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + +Print a. +Print b. +*) + +Polymorphic CoInductive foo@{i} (T : Type@{i}) : Type@{i} := +| A : foo T -> foo T. + +Polymorphic CoFixpoint cg@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (cg@{i} t). + +Print cg. + +Polymorphic CoFixpoint ca@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (@cb@{i} t) +with cb@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (@ca@{i} t). + +Print ca. +Print cb. \ No newline at end of file diff --git a/toplevel/command.ml b/toplevel/command.ml index 3995c4b1bc..d75efeca1e 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -1037,7 +1037,17 @@ let interp_recursive isfix fixl notations = let fixnames = List.map (fun fix -> fix.fix_name) fixl in (* Interp arities allowing for unresolved types *) - let evdref = ref (Evd.from_env env) in + let all_universes = + List.fold_right (fun sfe acc -> + match sfe.fix_univs , acc with + | None , acc -> acc + | x , None -> x + | Some ls , Some us -> + if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then + error "(co)-recursive definitions should all have the same universe binders"; + Some (ls @ us)) fixl None in + let ctx = Evd.make_evar_universe_context env all_universes in + let evdref = ref (Evd.from_ctx ctx) in let fixctxs, fiximppairs, fixannots = List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in let fixctximpenvs, fixctximps = List.split fiximppairs in @@ -1084,7 +1094,7 @@ let interp_recursive isfix fixl notations = let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in (* Build the fix declaration block *) - (env,rec_sign,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots + (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots let check_recursive isfix env evd (fixnames,fixdefs,_) = check_evars_are_solved env evd (Evd.empty,evd); @@ -1094,16 +1104,16 @@ let check_recursive isfix env evd (fixnames,fixdefs,_) = end let interp_fixpoint l ntns = - let (env,_,evd),fix,info = interp_recursive true l ntns in + let (env,_,pl,evd),fix,info = interp_recursive true l ntns in check_recursive true env evd fix; - (fix,Evd.evar_universe_context evd,info) + (fix,pl,Evd.evar_universe_context evd,info) let interp_cofixpoint l ntns = - let (env,_,evd),fix,info = interp_recursive false l ntns in + let (env,_,pl,evd),fix,info = interp_recursive false l ntns in check_recursive false env evd fix; - fix,Evd.evar_universe_context evd,info + (fix,pl,Evd.evar_universe_context evd,info) -let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexes ntns = +let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -1127,10 +1137,10 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexe let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in - let ctx = Universes.restrict_universe_context ctx vars in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in - let ctx = Univ.ContextSet.to_context ctx in + let ctx = Evd.universe_context ?names:pl evd in ignore (List.map4 (declare_fix (local, poly, Fixpoint) ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) @@ -1139,7 +1149,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexe (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns -let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns = +let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -1158,10 +1168,12 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in + let vars = Universes.universes_of_constr (List.hd fixdecls) in let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in - let ctx = Univ.ContextSet.to_context ctx in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let ctx = Evd.universe_context ?names:pl evd in ignore (List.map4 (declare_fix (local, poly, CoFixpoint) ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) @@ -1197,7 +1209,7 @@ let out_def = function let do_program_recursive local p fixkind fixl ntns = let isfix = fixkind != Obligations.IsCoFixpoint in - let (env, rec_sign, evd), fix, info = + let (env, rec_sign, pl, evd), fix, info = interp_recursive isfix fixl ntns in (* Program-specific code *) @@ -1267,9 +1279,9 @@ let do_fixpoint local poly l = if Flags.is_program_mode () then do_program_fixpoint local poly l else let fixl, ntns = extract_fixpoint_components true l in - let fix = interp_fixpoint fixl ntns in + let (_, _, _, info as fix) = interp_fixpoint fixl ntns in let possible_indexes = - List.map compute_possible_guardness_evidences (pi3 fix) in + List.map compute_possible_guardness_evidences info in declare_fixpoint local poly fix possible_indexes ntns let do_cofixpoint local poly l = diff --git a/toplevel/command.mli b/toplevel/command.mli index b400f0fde2..94b4af9dd9 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -136,24 +136,24 @@ type recursive_preentry = val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : locality -> polymorphic -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list -> lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : locality -> polymorphic -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list -> decl_notation list -> unit -- cgit v1.2.3 From 7d9331a2a188842a98936278d02177f1a6fa7001 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sat, 17 Oct 2015 21:40:49 -0700 Subject: Adds support for the virtual machine to perform reduction of universe polymorphic definitions. - This implementation passes universes in separate arguments and does not eagerly instanitate polymorphic definitions. - This means that it pays no cost on monomorphic definitions. --- dev/vm_printers.ml | 7 +- kernel/byterun/coq_interp.c | 34 ++++-- kernel/byterun/coq_values.h | 17 ++- kernel/cbytecodes.ml | 57 +++++----- kernel/cbytecodes.mli | 31 ++++-- kernel/cbytegen.ml | 250 ++++++++++++++++++++++++++++++++++---------- kernel/cbytegen.mli | 10 +- kernel/cemitcodes.ml | 23 ++-- kernel/cemitcodes.mli | 4 +- kernel/csymtable.ml | 30 +++--- kernel/environ.mli | 2 +- kernel/mod_typing.ml | 10 +- kernel/modops.ml | 2 +- kernel/nativelambda.ml | 2 +- kernel/term_typing.ml | 39 ++++--- kernel/univ.ml | 7 +- kernel/univ.mli | 3 + kernel/vars.ml | 4 +- kernel/vars.mli | 2 +- kernel/vconv.ml | 50 +++++++-- kernel/vm.ml | 112 ++++++++++++++++---- kernel/vm.mli | 11 +- pretyping/vnorm.ml | 96 ++++++++++++----- 23 files changed, 578 insertions(+), 225 deletions(-) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 802b0f9d80..272df7b421 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -13,7 +13,7 @@ let ppripos (ri,pos) = ("annot : MutInd("^(string_of_mind sp)^","^(string_of_int i)^")\n") | Reloc_const _ -> print_string "structured constant\n" - | Reloc_getglobal (kn,_) -> + | Reloc_getglobal kn -> print_string ("getglob "^(string_of_con kn)^"\n")); print_flush () @@ -30,7 +30,7 @@ let ppsort = function let print_idkey idk = match idk with - | ConstKey (sp,_) -> + | ConstKey sp -> print_string "Cons("; print_string (string_of_con sp); print_string ")" @@ -61,7 +61,8 @@ and ppstack s = and ppatom a = match a with | Aid idk -> print_idkey idk - | Aind((sp,i),_) -> print_string "Ind("; + | Atype u -> print_string "Type(...)" + | Aind(sp,i) -> print_string "Ind("; print_string (string_of_mind sp); print_string ","; print_int i; print_string ")" diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 0553a5ed7e..dc571699ef 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -341,6 +341,7 @@ value coq_interprete /* Fallthrough */ Instruct(ENVACC){ print_instr("ENVACC"); + print_int(*pc); accu = Field(coq_env, *pc++); Next; } @@ -371,6 +372,10 @@ value coq_interprete sp[1] = (value)pc; sp[2] = coq_env; sp[3] = Val_long(coq_extra_args); + print_instr("call stack="); + print_lint(sp[1]); + print_lint(sp[2]); + print_lint(sp[3]); pc = Code_val(accu); coq_env = accu; coq_extra_args = 0; @@ -458,6 +463,7 @@ value coq_interprete sp[0] = arg1; sp[1] = arg2; pc = Code_val(accu); + print_lint(accu); coq_env = accu; coq_extra_args += 1; goto check_stacks; @@ -481,11 +487,18 @@ value coq_interprete print_instr("RETURN"); print_int(*pc); sp += *pc++; + print_instr("stack="); + print_lint(sp[0]); + print_lint(sp[1]); + print_lint(sp[2]); if (coq_extra_args > 0) { + print_instr("extra args > 0"); + print_lint(coq_extra_args); coq_extra_args--; pc = Code_val(accu); coq_env = accu; } else { + print_instr("extra args = 0"); pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); @@ -585,7 +598,10 @@ value coq_interprete Alloc_small(accu, 1 + nvars, Closure_tag); Code_val(accu) = pc + *pc; pc++; - for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + for (i = 0; i < nvars; i++) { + print_lint(sp[i]); + Field(accu, i + 1) = sp[i]; + } sp += nvars; Next; } @@ -720,6 +736,7 @@ value coq_interprete /* Fallthrough */ Instruct(GETGLOBAL){ print_instr("GETGLOBAL"); + print_int(*pc); accu = Field(coq_global_data, *pc); pc++; Next; @@ -732,7 +749,7 @@ value coq_interprete tag_t tag = *pc++; mlsize_t i; value block; - print_instr("MAKEBLOCK"); + print_instr("MAKEBLOCK, tag="); Alloc_small(block, wosize, tag); Field(block, 0) = accu; for (i = 1; i < wosize; i++) Field(block, i) = *sp++; @@ -743,7 +760,8 @@ value coq_interprete tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK1"); + print_instr("MAKEBLOCK1, tag="); + print_int(tag); Alloc_small(block, 1, tag); Field(block, 0) = accu; accu = block; @@ -753,7 +771,8 @@ value coq_interprete tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK2"); + print_instr("MAKEBLOCK2, tag="); + print_int(tag); Alloc_small(block, 2, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; @@ -764,7 +783,8 @@ value coq_interprete Instruct(MAKEBLOCK3) { tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK3"); + print_instr("MAKEBLOCK3, tag="); + print_int(tag); Alloc_small(block, 3, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; @@ -776,7 +796,8 @@ value coq_interprete Instruct(MAKEBLOCK4) { tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK4"); + print_instr("MAKEBLOCK4, tag="); + print_int(tag); Alloc_small(block, 4, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; @@ -940,6 +961,7 @@ value coq_interprete /* Fallthrough */ Instruct(CONSTINT) { print_instr("CONSTINT"); + print_int(*pc); accu = Val_int(*pc); pc++; Next; diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index 80100da719..bb0f0eb5e4 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -17,22 +17,17 @@ #define Default_tag 0 #define Accu_tag 0 - - #define ATOM_ID_TAG 0 #define ATOM_INDUCTIVE_TAG 1 -#define ATOM_PROJ_TAG 2 -#define ATOM_FIX_TAG 3 -#define ATOM_SWITCH_TAG 4 -#define ATOM_COFIX_TAG 5 -#define ATOM_COFIXEVALUATED_TAG 6 - - +#define ATOM_TYPE_TAG 2 +#define ATOM_PROJ_TAG 3 +#define ATOM_FIX_TAG 4 +#define ATOM_SWITCH_TAG 5 +#define ATOM_COFIX_TAG 6 +#define ATOM_COFIXEVALUATED_TAG 7 /* Les blocs accumulate */ #define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) #define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) #endif /* _COQ_VALUES_ */ - - diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 448bf85444..b13b0607b3 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -19,13 +19,12 @@ type tag = int let accu_tag = 0 -let max_atom_tag = 1 -let proj_tag = 2 -let fix_app_tag = 3 -let switch_tag = 4 -let cofix_tag = 5 -let cofix_evaluated_tag = 6 - +let max_atom_tag = 2 +let proj_tag = 3 +let fix_app_tag = 4 +let switch_tag = 5 +let cofix_tag = 6 +let cofix_evaluated_tag = 7 (* It would be great if OCaml exported this value, So fixme if this happens in a new version of OCaml *) @@ -33,10 +32,12 @@ let last_variant_tag = 245 type structured_constant = | Const_sorts of sorts - | Const_ind of pinductive + | Const_ind of inductive | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array + | Const_univ_level of Univ.universe_level + | Const_type of Univ.universe type reloc_table = (tag * int) array @@ -71,7 +72,8 @@ type instruction = | Kclosure of Label.t * int | Kclosurerec of int * int * Label.t array * Label.t array | Kclosurecofix of int * int * Label.t array * Label.t array - | Kgetglobal of pconstant + (* nb fv, init, lbl types, lbl bodies *) + | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of int * tag | Kmakeprod @@ -127,7 +129,10 @@ type instruction = and bytecodes = instruction list -type fv_elem = FVnamed of Id.t | FVrel of int +type fv_elem = + | FVnamed of Id.t + | FVrel of int + | FVuniv_var of int type fv = fv_elem array @@ -145,18 +150,17 @@ type vm_env = { type comp_env = { - nb_stack : int; (* nbre de variables sur la pile *) - in_stack : int list; (* position dans la pile *) - nb_rec : int; (* nbre de fonctions mutuellement *) - (* recursives = nbr *) + nb_uni_stack : int ; (* number of universes on the stack, *) + (* universes are always at the bottom. *) + nb_stack : int; (* number of variables on the stack *) + in_stack : int list; (* position in the stack *) + nb_rec : int; (* number of mutually recursive functions *) pos_rec : instruction list; (* instruction d'acces pour les variables *) (* de point fix ou de cofix *) offset : int; - in_env : vm_env ref + in_env : vm_env ref (* The free variables of the expression *) } - - (* --- Pretty print *) open Pp open Util @@ -169,14 +173,24 @@ let pp_sort s = let rec pp_struct_const = function | Const_sorts s -> pp_sort s - | Const_ind ((mind, i), u) -> pr_mind mind ++ str"#" ++ int i + | Const_ind (mind, i) -> pr_mind mind ++ str"#" ++ int i | Const_proj p -> Constant.print p | Const_b0 i -> int i | Const_bn (i,t) -> int i ++ surround (prvect_with_sep pr_comma pp_struct_const t) + | Const_univ_level l -> Univ.Level.pr l + | Const_type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}" let pp_lbl lbl = str "L" ++ int lbl +let pp_pcon (id,u) = + pr_con id ++ str "@{" ++ Univ.Instance.pr Univ.Level.pr u ++ str "}" + +let pp_fv_elem = function + | FVnamed id -> str "FVnamed(" ++ Id.print id ++ str ")" + | FVrel i -> str "Rel(" ++ int i ++ str ")" + | FVuniv_var v -> str "FVuniv(" ++ int v ++ str ")" + let rec pp_instr i = match i with | Klabel _ | Ksequence _ -> assert false @@ -210,8 +224,7 @@ let rec pp_instr i = prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ str " bodies = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) - | Kgetglobal (id,u) -> - str "getglobal " ++ pr_con id ++ str "@{" ++ Univ.Instance.pr Univ.Level.pr u ++ str "}" + | Kgetglobal idu -> str "getglobal " ++ pr_con idu | Kconst sc -> str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> @@ -269,10 +282,6 @@ and pp_bytecodes c = | i :: c -> tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c -let dump_bytecode c = - pperrnl (pp_bytecodes c); - flush_all() - (*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) type block = diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 03d6383057..c35ef6920f 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -22,14 +22,18 @@ val switch_tag : tag val cofix_tag : tag val cofix_evaluated_tag : tag -val last_variant_tag : tag +val last_variant_tag : tag type structured_constant = | Const_sorts of sorts - | Const_ind of pinductive + | Const_ind of inductive | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array + | Const_univ_level of Univ.universe_level + | Const_type of Univ.universe + +val pp_struct_const : structured_constant -> Pp.std_ppcmds type reloc_table = (tag * int) array @@ -64,9 +68,11 @@ type instruction = (** nb fv, init, lbl types, lbl bodies *) | Kclosurecofix of int * int * Label.t array * Label.t array (** nb fv, init, lbl types, lbl bodies *) - | Kgetglobal of pconstant (** accu = coq_global_data[c] *) + | Kgetglobal of constant | Kconst of structured_constant - | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block *) + | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 + ** is accu, all others are popped from + ** the top of the stack *) | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) @@ -120,7 +126,10 @@ type instruction = and bytecodes = instruction list -type fv_elem = FVnamed of Id.t | FVrel of int +type fv_elem = + FVnamed of Id.t +| FVrel of int +| FVuniv_var of int type fv = fv_elem array @@ -129,26 +138,28 @@ type fv = fv_elem array closed terms. *) exception NotClosed -(*spiwack: both type have been moved from Cbytegen because I needed then +(*spiwack: both type have been moved from Cbytegen because I needed them for the retroknowledge *) type vm_env = { - size : int; (** longueur de la liste [n] *) + size : int; (** length of the list [n] *) fv_rev : fv_elem list (** [fvn; ... ;fv1] *) } type comp_env = { + nb_uni_stack : int ; (** number of universes on the stack *) nb_stack : int; (** number of variables on the stack *) in_stack : int list; (** position in the stack *) nb_rec : int; (** number of mutually recursive functions *) - (** recursives = nbr *) + (** (= nbr) *) pos_rec : instruction list; (** instruction d'acces pour les variables *) (** de point fix ou de cofix *) offset : int; - in_env : vm_env ref + in_env : vm_env ref (** the variables that are accessed *) } -val dump_bytecode : bytecodes -> unit +val pp_bytecodes : bytecodes -> Pp.std_ppcmds +val pp_fv_elem : fv_elem -> Pp.std_ppcmds (*spiwack: moved this here because I needed it for retroknowledge *) type block = diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 3462694d61..f9f72efdb9 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -96,13 +96,14 @@ let empty_fv = { size= 0; fv_rev = [] } let fv r = !(r.in_env) -let empty_comp_env ()= - { nb_stack = 0; +let empty_comp_env ?(univs=0) ()= + { nb_uni_stack = univs; + nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 0; - in_env = ref empty_fv; + in_env = ref empty_fv } (*i Creation functions for comp_env *) @@ -110,8 +111,9 @@ let empty_comp_env ()= let rec add_param n sz l = if Int.equal n 0 then l else add_param (n - 1) sz (n+sz::l) -let comp_env_fun arity = - { nb_stack = arity; +let comp_env_fun ?(univs=0) arity = + { nb_uni_stack = univs ; + nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = 0; pos_rec = []; @@ -120,8 +122,9 @@ let comp_env_fun arity = } -let comp_env_fix_type rfv = - { nb_stack = 0; +let comp_env_fix_type rfv = + { nb_uni_stack = 0; + nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; @@ -134,7 +137,8 @@ let comp_env_fix ndef curr_pos arity rfv = for i = ndef downto 1 do prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec done; - { nb_stack = arity; + { nb_uni_stack = 0; + nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; @@ -143,7 +147,8 @@ let comp_env_fix ndef curr_pos arity rfv = } let comp_env_cofix_type ndef rfv = - { nb_stack = 0; + { nb_uni_stack = 0; + nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; @@ -156,7 +161,8 @@ let comp_env_cofix ndef arity rfv = for i = 1 to ndef do prec := Kenvacc i :: !prec done; - { nb_stack = arity; + { nb_uni_stack = 0; + nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; @@ -168,7 +174,7 @@ let comp_env_cofix ndef arity rfv = let push_param n sz r = { r with nb_stack = r.nb_stack + n; - in_stack = add_param n sz r.in_stack } + in_stack = add_param n (sz - r.nb_uni_stack) r.in_stack } (* [push_local sz r] add a new variable on the stack at position [sz] *) let push_local sz r = @@ -176,8 +182,6 @@ let push_local sz r = nb_stack = r.nb_stack + 1; in_stack = (sz + 1) :: r.in_stack } - - (*i Compilation of variables *) let find_at f l = let rec aux n = function @@ -214,6 +218,37 @@ let pos_rel i r sz = r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; Kenvacc(r.offset + pos) +(* +let pos_poly_inst idu r = + let env = !(r.in_env) in + let f = function + | FVpoly_inst i -> Univ.eq_puniverses Names.Constant.equal idu i + | _ -> false + in + try Kenvacc (r.offset + env.size - (find_at f env.fv_rev)) + with Not_found -> + let pos = env.size in + let db = FVpoly_inst idu in + r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; + Kenvacc(r.offset + pos) +*) + +let pos_universe_var i r sz = + if i < r.nb_uni_stack then + Kacc (sz - r.nb_stack - (r.nb_uni_stack - i)) + else + let env = !(r.in_env) in + let f = function + | FVuniv_var u -> Int.equal i u + | _ -> false + in + try Kenvacc (r.offset + env.size - (find_at f env.fv_rev)) + with Not_found -> + let pos = env.size in + let db = FVuniv_var i in + r.in_env := { size = pos + 1; fv_rev = db::env.fv_rev } ; + Kenvacc(r.offset + pos) + (*i Examination of the continuation *) (* Discard all instructions up to the next label. *) @@ -459,7 +494,8 @@ let rec str_const c = end | _ -> Bconstr c end - | Ind ind -> Bstrconst (Const_ind ind) + | Ind (ind,_) -> + Bstrconst (Const_ind ind) | Construct (((kn,j),i),u) -> begin (* spiwack: tries first to apply the run-time compilation @@ -513,6 +549,7 @@ let compile_fv_elem reloc fv sz cont = match fv with | FVrel i -> pos_rel i reloc sz :: cont | FVnamed id -> pos_named id reloc :: cont + | FVuniv_var i -> pos_universe_var i reloc sz :: cont let rec compile_fv reloc l sz cont = match l with @@ -524,18 +561,21 @@ let rec compile_fv reloc l sz cont = (* Compiling constants *) -let rec get_alias env (kn,u as p) = +let rec get_alias env kn = let cb = lookup_constant kn env in let tps = cb.const_body_code in match tps with - | None -> p + | None -> kn | Some tps -> (match Cemitcodes.force tps with - | BCalias (kn',u') -> get_alias env (kn', Univ.subst_instance_instance u u') - | _ -> p) + | BCalias kn' -> get_alias env kn' + | _ -> kn) (* Compiling expressions *) +type ('a,'b) sum = Inl of 'a | Inr of 'b + +(* sz is the size of the local stack *) let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" @@ -552,9 +592,40 @@ let rec compile_constr reloc c sz cont = | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont | Const (kn,u) -> compile_const reloc kn u [||] sz cont - | Sort _ | Ind _ | Construct _ -> + | Ind (i,u) -> + if Univ.Instance.is_empty u then compile_str_cst reloc (str_const c) sz cont - + else + comp_app compile_str_cst compile_universe reloc + (str_const c) + (Univ.Instance.to_array u) + sz + cont + | Sort (Prop _) | Construct _ -> + compile_str_cst reloc (str_const c) sz cont + | Sort (Type u) -> + begin + let levels = Univ.Universe.levels u in + if Univ.LSet.exists (fun x -> Univ.Level.var_index x <> None) levels + then + (** TODO(gmalecha): Fix this **) + (** NOTE: This relies on the order of iteration to be consistent + **) + let level_vars = + List.map_filter (fun x -> Univ.Level.var_index x) + (Univ.LSet.elements levels) + in + let compile_get_univ reloc idx sz cont = + compile_fv_elem reloc (FVuniv_var idx) sz cont + in + comp_app compile_str_cst compile_get_univ reloc + (Bstrconst (Const_type u)) + (Array.of_list level_vars) + sz + cont + else + compile_str_cst reloc (str_const c) sz cont + end | LetIn(_,xb,_,body) -> compile_constr reloc xb sz (Kpush :: @@ -663,7 +734,9 @@ let rec compile_constr reloc c sz cont = let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = match branch1 with - | Kreturn k -> assert (Int.equal k sz); sz, branch1, true + | Kreturn k -> + assert (Int.equal k sz) ; + sz, branch1, true | _ -> sz+3, Kjump, false in let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in @@ -745,6 +818,19 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) +and compile_get_global reloc (kn,u) sz cont = + let kn = get_alias !global_env kn in + if Univ.Instance.is_empty u then + Kgetglobal kn :: cont + else + comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) + compile_universe reloc () (Univ.Instance.to_array u) sz cont + +and compile_universe reloc uni sz cont = + match Univ.Level.var_index uni with + | None -> Kconst (Const_univ_level uni) :: cont + | Some idx -> pos_universe_var idx reloc sz :: cont + and compile_const = fun reloc-> fun kn u -> fun args -> fun sz -> fun cont -> let nargs = Array.length args in @@ -756,31 +842,83 @@ and compile_const = (mkConstU (kn,u)) reloc args sz cont with Not_found -> if Int.equal nargs 0 then - Kgetglobal (get_alias !global_env (kn, u)) :: cont + compile_get_global reloc (kn,u) sz cont else - comp_app (fun _ _ _ cont -> - Kgetglobal (get_alias !global_env (kn,u)) :: cont) - compile_constr reloc () args sz cont - -let compile fail_on_error env c = + if Univ.Instance.is_empty u then + (* normal compilation *) + comp_app (fun _ _ sz cont -> + compile_get_global reloc (kn,u) sz cont) + compile_constr reloc () args sz cont + else + let compile_either reloc constr_or_uni sz cont = + match constr_or_uni with + | Inl cst -> compile_constr reloc cst sz cont + | Inr uni -> compile_universe reloc uni sz cont + in + (** TODO(gmalecha): This can be more efficient **) + let all = + Array.of_list (List.map (fun x -> Inr x) (Array.to_list (Univ.Instance.to_array u)) @ + List.map (fun x -> Inl x) (Array.to_list args)) + in + comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) + compile_either reloc () all sz cont + +let is_univ_copy max u = + let u = Univ.Instance.to_array u in + if Array.length u = max then + Array.fold_left_i (fun i acc u -> + if acc then + match Univ.Level.var_index u with + | None -> false + | Some l -> l = i + else false) true u + else + false + +let dump_bytecodes init code fvs = + let open Pp in + (str "code =" ++ fnl () ++ + pp_bytecodes init ++ fnl () ++ + pp_bytecodes code ++ fnl () ++ + str "fv = " ++ + prlist_with_sep (fun () -> str "; ") pp_fv_elem fvs ++ + fnl ()) + +let compile fail_on_error ?universes:(universes=0) env c = set_global_env env; init_fun_code (); Label.reset_label_counter (); - let reloc = empty_comp_env () in - try - let init_code = compile_constr reloc c 0 [Kstop] in - let fv = List.rev (!(reloc.in_env).fv_rev) in - let pp_v v = - match v with - | FVnamed id -> Pp.str (Id.to_string id) - | FVrel i -> Pp.str (string_of_int i) + let cont = [Kstop] in + try + let reloc, init_code = + if Int.equal universes 0 then + let reloc = empty_comp_env () in + reloc, compile_constr reloc c 0 cont + else + (* We are going to generate a lambda, but merge the universe closure + * with the function closure if it exists. + *) + let reloc = empty_comp_env () in + let arity , body = + match kind_of_term c with + | Lambda _ -> + let params, body = decompose_lam c in + List.length params , body + | _ -> 0 , c + in + let full_arity = arity + universes in + let r_fun = comp_env_fun ~univs:universes arity in + let lbl_fun = Label.create () in + let cont_fun = + compile_constr r_fun body full_arity [Kreturn full_arity] + in + fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; + let fv = fv r_fun in + reloc, compile_fv reloc fv.fv_rev 0 (Kclosure(lbl_fun,fv.size) :: cont) in - let open Pp in - if !Flags.dump_bytecode then - (dump_bytecode init_code; - dump_bytecode !fun_code; - Pp.msg_debug (Pp.str "fv = " ++ - Pp.prlist_with_sep (fun () -> Pp.str "; ") pp_v fv ++ Pp.fnl ())); + let fv = List.rev (!(reloc.in_env).fv_rev) in + (if !Flags.dump_bytecode then + Pp.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive tname -> let fn = if fail_on_error then Errors.errorlabstrm "compile" else Pp.msg_warning in @@ -789,28 +927,33 @@ let compile fail_on_error env c = Id.print tname ++ str str_max_constructors)); None) -let compile_constant_body fail_on_error env = function +let compile_constant_body fail_on_error env univs = function | Undef _ | OpaqueDef _ -> Some BCconstant | Def sb -> let body = Mod_subst.force_constr sb in + let instance_size = + match univs with + | None -> 0 + | Some univ -> Univ.UContext.size univ + in match kind_of_term body with - | Const (kn',u) -> + | Const (kn',u) when is_univ_copy instance_size u -> (* we use the canonical name of the constant*) let con= constant_of_kn (canonical_con kn') in - Some (BCalias (get_alias env (con,u))) + Some (BCalias (get_alias env con)) | _ -> - let res = compile fail_on_error env body in + let res = compile fail_on_error ~universes:instance_size env body in Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) -let compile_alias (kn,u) = BCalias (constant_of_kn (canonical_con kn), u) +let compile_alias kn = BCalias (constant_of_kn (canonical_con kn)) (* spiwack: additional function which allow different part of compilation of the 31-bit integers *) let make_areconst n else_lbl cont = - if n <=0 then + if n <= 0 then cont else Kareconst (n, else_lbl)::cont @@ -902,14 +1045,14 @@ let op2_compilation op = 3/ if at least one is not, branches to the normal behavior: Kgetglobal (get_alias !global_env kn) *) let op_compilation n op = - let code_construct kn cont = + let code_construct reloc kn sz cont = let f_cont = let else_lbl = Label.create () in Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) - Kgetglobal (get_alias !global_env kn):: - Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *) + compile_get_global reloc kn sz ( + Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) in let lbl = Label.create () in fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; @@ -926,12 +1069,11 @@ let op_compilation n op = (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = n and non-tailcall cont*) - Kgetglobal (get_alias !global_env kn):: - Kapply n::labeled_cont))) + compile_get_global reloc kn sz (Kapply n::labeled_cont)))) else if Int.equal nargs 0 then - code_construct kn cont + code_construct reloc kn sz cont else - comp_app (fun _ _ _ cont -> code_construct kn cont) + comp_app (fun reloc _ sz cont -> code_construct reloc kn sz cont) compile_constr reloc () args sz cont let int31_escape_before_match fc cont = diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 1128f0d0b7..c0f48641ce 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -4,17 +4,17 @@ open Term open Declarations open Pre_env - +(** Should only be used for monomorphic terms *) val compile : bool -> (* Fail on error with a nice user message, otherwise simply a warning *) - env -> constr -> (bytecodes * bytecodes * fv) option + ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option (** init, fun, fv *) -val compile_constant_body : bool -> - env -> constant_def -> body_code option +val compile_constant_body : bool -> + env -> constant_universes option -> constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) -val compile_alias : pconstant -> body_code +val compile_alias : Names.constant -> body_code (** spiwack: this function contains the information needed to perform the static compilation of int31 (trying and obtaining diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 9b275cb6c3..2a70d0b1b7 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -19,7 +19,7 @@ open Mod_subst type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant - | Reloc_getglobal of pconstant + | Reloc_getglobal of Names.constant type patch = reloc_info * int @@ -127,11 +127,11 @@ let slot_for_const c = enter (Reloc_const c); out_int 0 -and slot_for_annot a = +let slot_for_annot a = enter (Reloc_annot a); out_int 0 -and slot_for_getglobal p = +let slot_for_getglobal p = enter (Reloc_getglobal p); out_int 0 @@ -190,7 +190,7 @@ let emit_instr = function Array.iter (out_label_with_orig org) lbl_bodies | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q - | Kconst((Const_b0 i)) -> + | Kconst (Const_b0 i) -> if i >= 0 && i <= 3 then out (opCONST0 + i) else (out opCONSTINT; out_int i) @@ -310,7 +310,7 @@ let rec subst_strcst s sc = | Const_sorts _ | Const_b0 _ -> sc | Const_proj p -> Const_proj (subst_constant s p) | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) - | Const_ind(ind,u) -> let kn,i = ind in Const_ind((subst_mind s kn, i), u) + | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) let subst_patch s (ri,pos) = match ri with @@ -319,7 +319,7 @@ let subst_patch s (ri,pos) = let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) - | Reloc_getglobal kn -> (Reloc_getglobal (subst_pcon s kn), pos) + | Reloc_getglobal kn -> (Reloc_getglobal (subst_constant s kn), pos) let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv @@ -328,12 +328,12 @@ let subst_pconstant s (kn, u) = (fst (subst_con_kn s kn), u) type body_code = | BCdefined of to_patch - | BCalias of pconstant + | BCalias of Names.constant | BCconstant type to_patch_substituted = | PBCdefined of to_patch substituted -| PBCalias of pconstant substituted +| PBCalias of Names.constant substituted | PBCconstant let from_val = function @@ -343,7 +343,7 @@ let from_val = function let force = function | PBCdefined tp -> BCdefined (force subst_to_patch tp) -| PBCalias cu -> BCalias (force subst_pconstant cu) +| PBCalias cu -> BCalias (force subst_constant cu) | PBCconstant -> BCconstant let subst_to_patch_subst s = function @@ -373,8 +373,3 @@ let to_memory (init_code, fun_code, fv) = | Label_undefined patchlist -> assert (patchlist = []))) !label_table; (code, reloc, fv) - - - - - diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 54b92b9121..10f3a6087a 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -4,7 +4,7 @@ open Cbytecodes type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant - | Reloc_getglobal of constant Univ.puniverses + | Reloc_getglobal of constant type patch = reloc_info * int @@ -25,7 +25,7 @@ val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch type body_code = | BCdefined of to_patch - | BCalias of constant Univ.puniverses + | BCalias of constant | BCconstant diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index b3f0ba5b58..28f0fa4f28 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -58,7 +58,7 @@ let set_global v = let rec eq_structured_constant c1 c2 = match c1, c2 with | Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2 | Const_sorts _, _ -> false -| Const_ind i1, Const_ind i2 -> Univ.eq_puniverses eq_ind i1 i2 +| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 | Const_ind _, _ -> false | Const_proj p1, Const_proj p2 -> Constant.equal p1 p2 | Const_proj _, _ -> false @@ -67,18 +67,24 @@ let rec eq_structured_constant c1 c2 = match c1, c2 with | Const_bn (t1, a1), Const_bn (t2, a2) -> Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2 | Const_bn _, _ -> false +| Const_univ_level l1 , Const_univ_level l2 -> Univ.eq_levels l1 l2 +| Const_univ_level _ , _ -> false +| Const_type u1 , Const_type u2 -> Univ.Universe.equal u1 u2 +| Const_type _ , _ -> false let rec hash_structured_constant c = let open Hashset.Combine in match c with | Const_sorts s -> combinesmall 1 (Sorts.hash s) - | Const_ind (i,u) -> combinesmall 2 (combine (ind_hash i) (Univ.Instance.hash u)) + | Const_ind i -> combinesmall 2 (ind_hash i) | Const_proj p -> combinesmall 3 (Constant.hash p) | Const_b0 t -> combinesmall 4 (Int.hash t) | Const_bn (t, a) -> let fold h c = combine h (hash_structured_constant c) in let h = Array.fold_left fold 0 a in combinesmall 5 (combine (Int.hash t) h) + | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l) + | Const_type u -> combinesmall 7 (Univ.Universe.hash u) module SConstTable = Hashtbl.Make (struct type t = structured_constant @@ -124,7 +130,7 @@ exception NotEvaluated let key rk = match !rk with | None -> raise NotEvaluated - | Some k -> (*Pp.msgnl (str"found at: "++int k);*) + | Some k -> try Ephemeron.get k with Ephemeron.InvalidKey -> raise NotEvaluated @@ -148,23 +154,22 @@ let slot_for_annot key = AnnotTable.add annot_tbl key n; n -let rec slot_for_getglobal env (kn,u) = +let rec slot_for_getglobal env kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk with NotEvaluated -> (* Pp.msgnl(str"not yet evaluated");*) let pos = match cb.const_body_code with - | None -> set_global (val_of_constant (kn,u)) + | None -> set_global (val_of_constant kn) | Some code -> match Cemitcodes.force code with | BCdefined(code,pl,fv) -> - if Univ.Instance.is_empty u then - let v = eval_to_patch env (code,pl,fv) in - set_global v - else set_global (val_of_constant (kn,u)) + let v = eval_to_patch env (code,pl,fv) in + set_global v | BCalias kn' -> slot_for_getglobal env kn' - | BCconstant -> set_global (val_of_constant (kn,u)) in + | BCconstant -> set_global (val_of_constant kn) + in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (Ephemeron.create pos); pos @@ -197,6 +202,8 @@ and slot_for_fv env fv = fill_fv_cache rv i val_of_rel env_of_rel b | Some (v, _) -> v end + | FVuniv_var idu -> + assert false and eval_to_patch env (buff,pl,fv) = (* copy code *before* patching because of nested evaluations: @@ -214,7 +221,6 @@ and eval_to_patch env (buff,pl,fv) = List.iter patch pl; let vm_env = Array.map (slot_for_fv env) fv in let tc = tcode_of_code buff (length buff) in -(*Pp.msgnl (str"execute code");*) eval_tcode tc vm_env and val_of_constr env c = @@ -232,5 +238,3 @@ and val_of_constr env c = let set_transparent_const kn = () (* !?! *) let set_opaque_const kn = () (* !?! *) - - diff --git a/kernel/environ.mli b/kernel/environ.mli index 9f6ea522a7..dfe6cc85b1 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -250,7 +250,7 @@ type unsafe_type_judgment = { (** {6 Compilation of global declaration } *) -val compile_constant_body : env -> constant_def -> Cemitcodes.body_code option +val compile_constant_body : env -> constant_universes option -> constant_def -> Cemitcodes.body_code option exception Hyp_not_found diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index c03c5175fd..bd7ee7b339 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -126,11 +126,17 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = Vars.subst_univs_level_constr subst c, ctx, Univ.ContextSet.empty in let def = Def (Mod_subst.from_val c') in +(* let ctx' = Univ.UContext.make (newus, cst) in *) + let univs = + if cb.const_polymorphic then Some cb.const_universes + else None + in let cb' = { cb with const_body = def; - const_universes = univs; - const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' def) } + const_universes = ctx ; + const_body_code = Option.map Cemitcodes.from_val + (compile_constant_body env' univs def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else diff --git a/kernel/modops.ml b/kernel/modops.ml index f0cb65c967..cbb7963315 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -335,7 +335,7 @@ let strengthen_const mp_from l cb resolver = in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); - const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias (con,u))) } + const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 263befd213..4d033bc999 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -379,7 +379,7 @@ let rec get_alias env (kn, u as p) = | None -> p | Some tps -> match Cemitcodes.force tps with - | Cemitcodes.BCalias kn' -> get_alias env kn' + | Cemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p (*i Global environment *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index b6df8f454b..cab99077f0 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -258,33 +258,30 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred) lc) in let tps = - (* FIXME: incompleteness of the bytecode vm: we compile polymorphic - constants like opaque definitions. *) - if poly then Some (Cemitcodes.from_val Cemitcodes.BCconstant) - else - let res = - match proj with - | None -> compile_constant_body env def - | Some pb -> + let res = + let comp_univs = if poly then Some univs else None in + match proj with + | None -> compile_constant_body env comp_univs def + | Some pb -> (* The compilation of primitive projections is a bit tricky, because they refer to themselves (the body of p looks like fun c => Proj(p,c)). We break the cycle by building an ad-hoc compilation environment. A cleaner solution would be that kernel projections are simply Proj(i,c) with i an int and c a constr, but we would have to get rid of the compatibility layer. *) - let cb = - { const_hyps = hyps; - const_body = def; - const_type = typ; - const_proj = proj; - const_body_code = None; - const_polymorphic = poly; - const_universes = univs; - const_inline_code = inline_code } - in - let env = add_constant kn cb env in - compile_constant_body env def - in Option.map Cemitcodes.from_val res + let cb = + { const_hyps = hyps; + const_body = def; + const_type = typ; + const_proj = proj; + const_body_code = None; + const_polymorphic = poly; + const_universes = univs; + const_inline_code = inline_code } + in + let env = add_constant kn cb env in + compile_constant_body env comp_univs def + in Option.map Cemitcodes.from_val res in { const_hyps = hyps; const_body = def; diff --git a/kernel/univ.ml b/kernel/univ.ml index c0bd3bacd7..064dde3a64 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1754,7 +1754,7 @@ let eq_puniverses f (x, u) (y, u') = f x y && Instance.equal u u' (** A context of universe levels with universe constraints, - representiong local universe variables and constraints *) + representing local universe variables and constraints *) module UContext = struct @@ -1778,8 +1778,11 @@ struct let union (univs, cst) (univs', cst') = Instance.append univs univs', Constraint.union cst cst' - + let dest x = x + + let size (x,_) = Instance.length x + end type universe_context = UContext.t diff --git a/kernel/univ.mli b/kernel/univ.mli index cbaf7e546a..c926c57bd8 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -343,6 +343,9 @@ sig (** Keeps the order of the instances *) val union : t -> t -> t + (* the number of universes in the context *) + val size : t -> int + end type universe_context = UContext.t diff --git a/kernel/vars.ml b/kernel/vars.ml index 88c1e1038c..a800e25315 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -337,5 +337,5 @@ let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else map_rel_context (fun x -> subst_instance_constr s x) ctx -type id_key = pconstant tableKey -let eq_id_key x y = Names.eq_table_key (Univ.eq_puniverses Constant.equal) x y +type id_key = constant tableKey +let eq_id_key x y = Names.eq_table_key Constant.equal x y diff --git a/kernel/vars.mli b/kernel/vars.mli index fdd4603b5b..c0fbeeb6e6 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -88,5 +88,5 @@ val subst_univs_level_context : Univ.universe_level_subst -> rel_context -> rel_ val subst_instance_constr : universe_instance -> constr -> constr val subst_instance_context : universe_instance -> rel_context -> rel_context -type id_key = pconstant tableKey +type id_key = constant tableKey val eq_id_key : id_key -> id_key -> bool diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 2f6be06011..e0d9688486 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -45,8 +45,15 @@ let rec conv_val env pb k v1 v2 cu = else conv_whd env pb k (whd_val v1) (whd_val v2) cu and conv_whd env pb k whd1 whd2 cu = +(* Pp.(msg_debug (str "conv_whd(" ++ pr_whd whd1 ++ str ", " ++ pr_whd whd2 ++ str ")")) ; *) match whd1, whd2 with | Vsort s1, Vsort s2 -> sort_cmp_universes env pb s1 s2 cu + | Vuniv_level _ , _ + | _ , Vuniv_level _ -> + (** Both of these are invalid since universes are handled via + ** special cases in the code. + **) + assert false | Vprod p1, Vprod p2 -> let cu = conv_val env CONV k (dom p1) (dom p2) cu in conv_fun env pb k (codom p1) (codom p2) cu @@ -81,26 +88,53 @@ and conv_whd env pb k whd1 whd2 cu = and conv_atom env pb k a1 stk1 a2 stk2 cu = +(* Pp.(msg_debug (str "conv_atom(" ++ pr_atom a1 ++ str ", " ++ pr_atom a2 ++ str ")")) ; *) match a1, a2 with - | Aind ind1, Aind ind2 -> - if eq_puniverses eq_ind ind1 ind2 && compare_stack stk1 stk2 + | Aind ((mi,i) as ind1) , Aind ind2 -> + if eq_ind ind1 ind2 && compare_stack stk1 stk2 then - conv_stack env k stk1 stk2 cu + if Environ.polymorphic_ind ind1 env + then + let mib = Environ.lookup_mind mi env in + let ulen = Univ.UContext.size mib.Declarations.mind_universes in + match stk1 , stk2 with + | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> + assert (ulen <= nargs args1) ; + assert (ulen <= nargs args2) ; + for i = 0 to ulen - 1 do + let a1 = uni_lvl_val (arg args1 i) in + let a2 = uni_lvl_val (arg args2 i) in + let result = Univ.Level.equal a1 a2 in + if not result + then raise NotConvertible + done ; + conv_arguments env ~from:ulen k args1 args2 + (conv_stack env k stk1' stk2' cu) + | _ -> raise NotConvertible + else + conv_stack env k stk1 stk2 cu else raise NotConvertible | Aid ik1, Aid ik2 -> if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack env k stk1 stk2 cu else raise NotConvertible + | Atype u1 , Atype u2 -> + let u1 = Vm.instantiate_universe u1 stk1 in + let u2 = Vm.instantiate_universe u2 stk2 in + sort_cmp_universes env pb (Type u1) (Type u2) cu + | Atype _ , Aid _ + | Atype _ , Aind _ + | Aid _ , Atype _ | Aind _, _ | Aid _, _ -> raise NotConvertible -and conv_stack env k stk1 stk2 cu = +and conv_stack env ?from:(from=0) k stk1 stk2 cu = match stk1, stk2 with | [], [] -> cu | Zapp args1 :: stk1, Zapp args2 :: stk2 -> - conv_stack env k stk1 stk2 (conv_arguments env k args1 args2 cu) + conv_stack env k stk1 stk2 (conv_arguments env ~from:from k args1 args2 cu) | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 -> conv_stack env k stk1 stk2 - (conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu)) + (conv_arguments env ~from:from k args1 args2 (conv_fix env k f1 f2 cu)) | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> if check_switch sw1 sw2 then let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in @@ -144,13 +178,13 @@ and conv_cofix env k cf1 cf2 cu = conv_vect (conv_val env CONV (k + Array.length tcf1)) bcf1 bcf2 cu else raise NotConvertible -and conv_arguments env k args1 args2 cu = +and conv_arguments env ?from:(from=0) k args1 args2 cu = if args1 == args2 then cu else let n = nargs args1 in if Int.equal n (nargs args2) then let rcu = ref cu in - for i = 0 to n - 1 do + for i = from to n - 1 do rcu := conv_val env CONV k (arg args1 i) (arg args2 i) !rcu done; !rcu diff --git a/kernel/vm.ml b/kernel/vm.ml index eacd803fd4..858f546c60 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -121,12 +121,12 @@ type vswitch = { (* *) (* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) (* - representation of [accu] : tag_[....] *) -(* -- tag <= 2 : encoding atom type (sorts, free vars, etc.) *) -(* -- 3_[accu|proj name] : a projection blocked by an accu *) -(* -- 4_[accu|fix_app] : a fixpoint blocked by an accu *) -(* -- 5_[accu|vswitch] : a match blocked by an accu *) -(* -- 6_[fcofix] : a cofix function *) -(* -- 7_[fcofix|val] : a cofix function, val represent the value *) +(* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) +(* -- 10_[accu|proj name] : a projection blocked by an accu *) +(* -- 11_[accu|fix_app] : a fixpoint blocked by an accu *) +(* -- 12_[accu|vswitch] : a match blocked by an accu *) +(* -- 13_[fcofix] : a cofix function *) +(* -- 14_[fcofix|val] : a cofix function, val represent the value *) (* of the function applied to arg1 ... argn *) (* The [arguments] type, which is abstracted as an array, represents : *) (* tag[ _ | _ |v1|... | vn] *) @@ -136,7 +136,8 @@ type vswitch = { type atom = | Aid of Vars.id_key - | Aind of pinductive + | Aind of inductive + | Atype of Univ.universe (* Zippers *) @@ -159,6 +160,7 @@ type whd = | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack + | Vuniv_level of Univ.universe_level (*************************************************) (* Destructors ***********************************) @@ -199,7 +201,9 @@ let rec whd_accu a stk = | [Zapp args] -> Vcofix(vcofix, res, Some args) | _ -> assert false end - | _ -> assert false + | tg -> + Errors.anomaly + Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg) external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" @@ -212,22 +216,45 @@ let whd_val : values -> whd = if tag = accu_tag then ( if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *) - else + else if is_accumulate (fun_code o) then whd_accu o [] - else (Vprod(Obj.obj o))) + else Vprod(Obj.obj o)) else if tag = Obj.closure_tag || tag = Obj.infix_tag then - ( match kind_of_closure o with + (match kind_of_closure o with | 0 -> Vfun(Obj.obj o) | 1 -> Vfix(Obj.obj o, None) | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> Errors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work")) - else - Vconstr_block(Obj.obj o) - + else + Vconstr_block(Obj.obj o) + +let uni_lvl_val : values -> Univ.universe_level = + fun v -> + let whd = Obj.magic v in + match whd with + | Vuniv_level lvl -> lvl + | _ -> + let pr = + let open Pp in + match whd with + | Vsort _ -> str "Vsort" + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk" + | _ -> assert false + in + Errors.anomaly + Pp.( strbrk "Parsing virtual machine value expected universe level, got " + ++ pr) + (************************************************) -(* Abstrct machine ******************************) +(* Abstract machine *****************************) (************************************************) (* gestion de la pile *) @@ -299,6 +326,8 @@ let rec obj_of_str_const str = Obj.set_field res i (obj_of_str_const args.(i)) done; res + | Const_univ_level l -> Obj.repr (Vuniv_level l) + | Const_type u -> obj_of_atom (Atype u) let val_of_obj o = ((Obj.obj o) : values) @@ -317,11 +346,11 @@ let val_of_proj kn v = module IdKeyHash = struct - type t = pconstant tableKey - let equal = Names.eq_table_key (Univ.eq_puniverses Constant.equal) + type t = constant tableKey + let equal = Names.eq_table_key Constant.equal open Hashset.Combine let hash = function - | ConstKey (c,u) -> combinesmall 1 (Constant.hash c) + | ConstKey c -> combinesmall 1 (Constant.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end @@ -606,3 +635,50 @@ let apply_whd k whd = interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 | Vatom_stk(a,stk) -> apply_stack (val_of_atom a) stk v + | Vuniv_level lvl -> assert false + +let instantiate_universe (u : Univ.universe) (stk : stack) : Univ.universe = + match stk with + | [] -> u + | [Zapp args] -> + assert (Univ.LSet.cardinal (Univ.Universe.levels u) = nargs args) ; + let _,mp = Univ.LSet.fold (fun key (i,mp) -> + let u = uni_lvl_val (arg args i) in + (i+1, Univ.LMap.add key (Univ.Universe.make u) mp)) + (Univ.Universe.levels u) + (0,Univ.LMap.empty) in + let subst = Univ.make_subst mp in + Univ.subst_univs_universe subst u + | _ -> + Errors.anomaly Pp.(str "ill-formed universe") + + +let rec pr_atom a = + Pp.(match a with + | Aid c -> str "Aid(" ++ (match c with + | ConstKey c -> Names.pr_con c + | RelKey i -> str "#" ++ int i + | _ -> str "...") ++ str ")" + | Aind (mi,i) -> str "Aind(" ++ Names.pr_mind mi ++ str "#" ++ int i ++ str ")" + | Atype _ -> str "Atype(") +and pr_whd w = + Pp.(match w with + | Vsort _ -> str "Vsort" + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" + | Vuniv_level _ -> assert false) +and pr_stack stk = + Pp.(match stk with + | [] -> str "[]" + | s :: stk -> pr_zipper s ++ str " :: " ++ pr_stack stk) +and pr_zipper z = + Pp.(match z with + | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" + | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" + | Zswitch s -> str "Zswitch(...)" + | Zproj c -> str "Zproj(" ++ Names.pr_con c ++ str ")") diff --git a/kernel/vm.mli b/kernel/vm.mli index 045d02333c..bc19786632 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -22,7 +22,8 @@ type arguments type atom = | Aid of Vars.id_key - | Aind of pinductive + | Aind of inductive + | Atype of Univ.universe (** Zippers *) @@ -45,19 +46,25 @@ type whd = | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack + | Vuniv_level of Univ.universe_level + +val pr_atom : atom -> Pp.std_ppcmds +val pr_whd : whd -> Pp.std_ppcmds (** Constructors *) val val_of_str_const : structured_constant -> values val val_of_rel : int -> values val val_of_named : Id.t -> values -val val_of_constant : pconstant -> values +val val_of_constant : constant -> values external val_of_annot_switch : annot_switch -> values = "%identity" (** Destructors *) val whd_val : values -> whd +val uni_lvl_val : values -> Univ.universe_level +val instantiate_universe : Univ.universe -> stack -> Univ.universe (** Arguments *) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 46af784dda..b9c1a5a1c7 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -93,19 +93,6 @@ let construct_of_constr_const env tag typ = let construct_of_constr_block = construct_of_constr false -let constr_type_of_idkey env idkey = - match idkey with - | ConstKey cst -> - let const_type = Typeops.type_of_constant_in env cst in - mkConstU cst, const_type - | VarKey id -> - let (_,_,ty) = lookup_named id env in - mkVar id, ty - | RelKey i -> - let n = (nb_rel env - i) in - let (_,_,ty) = lookup_rel n env in - mkRel n, lift n ty - let type_of_ind env (ind, u) = type_of_inductive env (Inductive.lookup_mind_specif env ind, u) @@ -164,9 +151,11 @@ and nf_whd env whd typ = let t = ta.(i) in let _, args = nf_args env vargs t in mkApp(cfd,args) - | Vconstr_const n -> construct_of_constr_const env n typ + | Vconstr_const n -> + construct_of_constr_const env n typ | Vconstr_block b -> let tag = btag b in + let x = tag in let (tag,ofs) = if tag = Cbytecodes.last_variant_tag then match whd_val (bfield b 0) with @@ -177,22 +166,80 @@ and nf_whd env whd typ = let args = nf_bargs env b ofs ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> - let c,typ = constr_type_of_idkey env idkey in - nf_stk env c typ stk - | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkIndU ind) (type_of_ind env ind) stk + constr_type_of_idkey env idkey stk nf_stk +(*let c,typ = constr_type_of_idkey env idkey in + nf_stk env c typ stk *) + | Vatom_stk(Aind ((mi,i) as ind), stk) -> + if Environ.polymorphic_ind ind env then + let mib = Environ.lookup_mind mi env in + let ulen = Univ.UContext.size mib.mind_universes in + match stk with + | Zapp args :: stk' -> + assert (ulen <= nargs args) ; + let inst = + Array.init ulen (fun i -> Vm.uni_lvl_val (arg args i)) + in + let pind = (ind, Univ.Instance.of_array inst) in + nf_stk ~from:ulen env (mkIndU pind) (type_of_ind env pind) stk + | _ -> assert false + else + let pind = (ind, Univ.Instance.empty) in + nf_stk env (mkIndU pind) (type_of_ind env pind) stk + | Vatom_stk(Atype u, stk) -> + mkSort (Type (Vm.instantiate_universe u stk)) + | Vuniv_level lvl -> + assert false + +and constr_type_of_idkey env (idkey : Vars.id_key) stk cont = + match idkey with + | ConstKey cst -> + if Environ.polymorphic_constant cst env then + let cbody = Environ.lookup_constant cst env in + match stk with + | Zapp vargs :: stk' -> + let uargs = Univ.UContext.size cbody.const_universes in + assert (Vm.nargs vargs >= uargs) ; + let uary = Array.init uargs (fun i -> Vm.uni_lvl_val (Vm.arg vargs i)) in + let ui = Univ.Instance.of_array uary in + let ucst = (cst, ui) in + let const_type = Typeops.type_of_constant_in env ucst in + if uargs < Vm.nargs vargs then + let t, args = nf_args env vargs ~from:uargs const_type in + cont env (mkApp (mkConstU ucst, args)) t stk' + else + cont env (mkConstU ucst) const_type stk' + | _ -> assert false + else + begin + let ucst = (cst, Univ.Instance.empty) in + let const_type = Typeops.type_of_constant_in env ucst in + cont env (mkConstU ucst) const_type stk + end + | VarKey id -> + let (_,_,ty) = lookup_named id env in + cont env (mkVar id) ty stk + | RelKey i -> + let n = (nb_rel env - i) in + let (_,_,ty) = lookup_rel n env in + cont env (mkRel n) (lift n ty) stk -and nf_stk env c t stk = +and nf_stk ?from:(from=0) env c t stk = match stk with | [] -> c | Zapp vargs :: stk -> - let t, args = nf_args env vargs t in - nf_stk env (mkApp(c,args)) t stk + if nargs vargs >= from then + let t, args = nf_args ~from:from env vargs t in + nf_stk env (mkApp(c,args)) t stk + else + let rest = from - nargs vargs in + nf_stk ~from:rest env c t stk | Zfix (f,vargs) :: stk -> + assert (from = 0) ; let fa, typ = nf_fix_app env f vargs in let _,_,codom = decompose_prod env typ in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> + assert (from = 0) ; let ((mind,_ as ind), u), allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in @@ -215,6 +262,7 @@ and nf_stk env c t stk = let ci = case_info sw in nf_stk env (mkCase(ci, p, c, branchs)) tcase stk | Zproj p :: stk -> + assert (from = 0) ; let p' = Projection.make p true in let ty = Inductiveops.type_of_projection_knowing_arg env Evd.empty p' c t in nf_stk env (mkProj(p',c)) ty stk @@ -240,14 +288,14 @@ and nf_predicate env ind mip params v pT = true, mkLambda(name,dom,body) | _, _ -> false, nf_val env v crazy_type -and nf_args env vargs t = +and nf_args env vargs ?from:(f=0) t = let t = ref t in - let len = nargs vargs in + let len = nargs vargs - f in let args = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env (arg vargs i) dom in + let c = nf_val env (arg vargs (f+i)) dom in t := subst1 c codom; c) in !t,args -- cgit v1.2.3 From 95669265239c4da7f5cfcf134825f6801e52391f Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 21 Oct 2015 09:13:18 -0700 Subject: test cases. --- test-suite/kernel/vm-univ.v | 145 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 test-suite/kernel/vm-univ.v diff --git a/test-suite/kernel/vm-univ.v b/test-suite/kernel/vm-univ.v new file mode 100644 index 0000000000..1bdba3c68d --- /dev/null +++ b/test-suite/kernel/vm-univ.v @@ -0,0 +1,145 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Section pmap. + Context {T : Type@{i}} {U : Type@{j}} (f : T -> U). + + Polymorphic Fixpoint pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) + end. +End pmap. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Section pfold. + Context {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U). + + Polymorphic Fixpoint pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. +End pfold. + +Polymorphic Inductive nat : Type@{i} := +| O +| S : nat -> nat. + +Fixpoint nat_max (a b : nat) : nat := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height {T : Type@{i}} (t : Tree@{i} T) : nat := + match t with + | Empty _ => O + | Branch _ ls => S (pfold nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat {T : Type@{i}} (n : nat) (v : T) : plist@{i} T := + match n with + | O => pnil + | S n => pcons v (repeat n v) + end. + +Polymorphic Fixpoint big_tree (n : nat) : Tree@{i} nat := + match n with + | O => @Empty nat + | S n' => Branch _ (repeat n' (big_tree n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: height@{Set} (@Branch nat pnil) = S O. + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. -- cgit v1.2.3 From 9ce6802ea563437b15e45198f4d8d0f716a576bb Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 27 Oct 2015 23:27:50 +0100 Subject: Fix minor typo in native compiler. --- kernel/nativevalues.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index e4a7799933..40bef4bc67 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -10,7 +10,7 @@ open Names open Errors open Util -(** This modules defines the representation of values internally used by +(** This module defines the representation of values internally used by the native compiler *) type t = t -> t -- cgit v1.2.3 From 90dfacaacfec8265b11dc9291de9510f515c0081 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 27 Oct 2015 23:59:05 +0100 Subject: Conversion of polymorphic inductive types was incomplete in VM and native. Was showing up when comparing e.g. prod Type Type with prod Type Type (!) with a polymorphic prod. --- kernel/nativeconv.ml | 10 ++++++---- kernel/reduction.ml | 14 ++++++++------ kernel/reduction.mli | 7 ++++++- kernel/vconv.ml | 35 ++++++++++------------------------- pretyping/reductionops.ml | 2 +- 5 files changed, 31 insertions(+), 37 deletions(-) diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 7ae66c485a..0242fd461c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -63,10 +63,12 @@ and conv_atom env pb lvl a1 a2 cu = | Ameta _, _ | _, Ameta _ | Aevar _, _ | _, Aevar _ -> assert false | Arel i1, Arel i2 -> if Int.equal i1 i2 then cu else raise NotConvertible - | Aind ind1, Aind ind2 -> - if eq_puniverses eq_ind ind1 ind2 then cu else raise NotConvertible - | Aconstant c1, Aconstant c2 -> - if eq_puniverses eq_constant c1 c2 then cu else raise NotConvertible + | Aind (ind1,u1), Aind (ind2,u2) -> + if eq_ind ind1 ind2 then convert_instances ~flex:false u1 u2 cu + else raise NotConvertible + | Aconstant (c1,u1), Aconstant (c2,u2) -> + if Constant.equal c1 c2 then convert_instances ~flex:true u1 u2 cu + else raise NotConvertible | Asort s1, Asort s2 -> sort_cmp_universes env pb s1 s2 cu | Avar id1, Avar id2 -> diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 2c111a55b5..892557ac6c 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -173,7 +173,7 @@ let is_cumul = function CUMUL -> true | CONV -> false type 'a universe_compare = { (* Might raise NotConvertible *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; - compare_instances: bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; + compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; } type 'a universe_state = 'a * 'a universe_compare @@ -185,8 +185,10 @@ type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.co let sort_cmp_universes env pb s0 s1 (u, check) = (check.compare env pb s0 s1 u, check) -let convert_instances flex u u' (s, check) = - (check.compare_instances flex u u' s, check) +(* [flex] should be true for constants, false for inductive types and + constructors. *) +let convert_instances ~flex u u' (s, check) = + (check.compare_instances ~flex u u' s, check) let conv_table_key infos k1 k2 cuniv = if k1 == k2 then cuniv else @@ -196,7 +198,7 @@ let conv_table_key infos k1 k2 cuniv = else let flex = evaluable_constant cst (info_env infos) && RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst) - in convert_instances flex u u' cuniv + in convert_instances ~flex u u' cuniv | VarKey id, VarKey id' when Id.equal id id' -> cuniv | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible @@ -590,7 +592,7 @@ let check_sort_cmp_universes env pb s0 s1 univs = let checked_sort_cmp_universes env pb s0 s1 univs = check_sort_cmp_universes env pb s0 s1 univs; univs -let check_convert_instances _flex u u' univs = +let check_convert_instances ~flex u u' univs = if Univ.Instance.check_eq univs u u' then univs else raise NotConvertible @@ -630,7 +632,7 @@ let infer_cmp_universes env pb s0 s1 univs = | CONV -> infer_eq univs u1 u2) else univs -let infer_convert_instances flex u u' (univs,cstrs) = +let infer_convert_instances ~flex u u' (univs,cstrs) = (univs, Univ.enforce_eq_instances u u' cstrs) let inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare = diff --git a/kernel/reduction.mli b/kernel/reduction.mli index c3cc7b2b69..0df26d6276 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -37,7 +37,7 @@ type conv_pb = CONV | CUMUL type 'a universe_compare = { (* Might raise NotConvertible *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; - compare_instances: bool (* Instance of a flexible constant? *) -> + compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; } @@ -50,6 +50,11 @@ type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.co val sort_cmp_universes : env -> conv_pb -> sorts -> sorts -> 'a * 'a universe_compare -> 'a * 'a universe_compare +(* [flex] should be true for constants, false for inductive types and +constructors. *) +val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t -> + 'a * 'a universe_compare -> 'a * 'a universe_compare + val checked_universes : Univ.universes universe_compare val inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare diff --git a/kernel/vconv.ml b/kernel/vconv.ml index e0d9688486..2e519789e1 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -99,17 +99,15 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = let ulen = Univ.UContext.size mib.Declarations.mind_universes in match stk1 , stk2 with | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> - assert (ulen <= nargs args1) ; - assert (ulen <= nargs args2) ; - for i = 0 to ulen - 1 do - let a1 = uni_lvl_val (arg args1 i) in - let a2 = uni_lvl_val (arg args2 i) in - let result = Univ.Level.equal a1 a2 in - if not result - then raise NotConvertible - done ; - conv_arguments env ~from:ulen k args1 args2 - (conv_stack env k stk1' stk2' cu) + assert (ulen <= nargs args1); + assert (ulen <= nargs args2); + let u1 = Array.init ulen (fun i -> uni_lvl_val (arg args1 i)) in + let u2 = Array.init ulen (fun i -> uni_lvl_val (arg args2 i)) in + let u1 = Univ.Instance.of_array u1 in + let u2 = Univ.Instance.of_array u2 in + let cu = convert_instances ~flex:false u1 u2 cu in + conv_arguments env ~from:ulen k args1 args2 + (conv_stack env k stk1' stk2' cu) | _ -> raise NotConvertible else conv_stack env k stk1 stk2 cu @@ -118,13 +116,7 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack env k stk1 stk2 cu else raise NotConvertible - | Atype u1 , Atype u2 -> - let u1 = Vm.instantiate_universe u1 stk1 in - let u2 = Vm.instantiate_universe u2 stk2 in - sort_cmp_universes env pb (Type u1) (Type u2) cu - | Atype _ , Aid _ - | Atype _ , Aind _ - | Aid _ , Atype _ + | Atype _ , _ | _, Atype _ -> assert false | Aind _, _ | Aid _, _ -> raise NotConvertible and conv_stack env ?from:(from=0) k stk1 stk2 cu = @@ -190,13 +182,6 @@ and conv_arguments env ?from:(from=0) k args1 args2 cu = !rcu else raise NotConvertible -let rec eq_puniverses f (x,l1) (y,l2) cu = - if f x y then conv_universes l1 l2 cu - else raise NotConvertible - -and conv_universes l1 l2 cu = - if Univ.Instance.equal l1 l2 then cu else raise NotConvertible - let vm_conv_gen cv_pb env univs t1 t2 = try let v1 = val_of_constr env t1 in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index bb1bc7d2ea..0714c93b4f 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1282,7 +1282,7 @@ let sigma_compare_sorts env pb s0 s1 sigma = | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1 | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1 -let sigma_compare_instances flex i0 i1 sigma = +let sigma_compare_instances ~flex i0 i1 sigma = try Evd.set_eq_instances ~flex sigma i0 i1 with Evd.UniversesDiffer | Univ.UniverseInconsistency _ -> -- cgit v1.2.3 From 4f8a9d10123bd8aa4d17853a7248d3b3fe8a3625 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 28 Oct 2015 11:16:24 +0100 Subject: Refine Gregory Malecha's patch on VM and universe polymorphism. - Universes are now represented in the VM by a structured constant containing the global levels. This constant is applied to local level variables if any. - When reading back a universe, we perform the union of these levels and return a [Vsort]. - Fixed a bug: structured constants could contain local universe variables in constructor arguments, which has to be prevented. Was showing up for instance when evaluating [cons _ list (nil _)] with a polymorphic [list] type. - Fixed a bug: polymorphic inductive types can have an empty stack. Was showing up when evaluating [bool] with a polymorphic [bool] type. - Made a few cosmetic changes. Patch written with Benjamin Grégoire. --- dev/vm_printers.ml | 1 + kernel/cbytecodes.ml | 1 + kernel/cbytecodes.mli | 1 + kernel/cbytegen.ml | 92 ++++++++++++--------------- kernel/cemitcodes.ml | 2 +- kernel/vconv.ml | 3 +- kernel/vm.ml | 167 ++++++++++++++++++++++++-------------------------- kernel/vm.mli | 1 - pretyping/vnorm.ml | 85 ++++++++++++------------- 9 files changed, 163 insertions(+), 190 deletions(-) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 272df7b421..1c501df808 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -79,6 +79,7 @@ and ppwhd whd = | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s + | Vuniv_level lvl -> Pp.pp (Univ.Level.pr lvl) and ppvblock b = open_hbox(); diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index b13b0607b3..0a24a75d68 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -19,6 +19,7 @@ type tag = int let accu_tag = 0 +let type_atom_tag = 2 let max_atom_tag = 2 let proj_tag = 3 let fix_app_tag = 4 diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index c35ef6920f..03ae6b9cdc 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -15,6 +15,7 @@ type tag = int val accu_tag : tag +val type_atom_tag : tag val max_atom_tag : tag val proj_tag : tag val fix_app_tag : tag diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index f9f72efdb9..1f7cc3c7a6 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -91,6 +91,7 @@ open Pre_env (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) +type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t let empty_fv = { size= 0; fv_rev = [] } @@ -218,21 +219,6 @@ let pos_rel i r sz = r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; Kenvacc(r.offset + pos) -(* -let pos_poly_inst idu r = - let env = !(r.in_env) in - let f = function - | FVpoly_inst i -> Univ.eq_puniverses Names.Constant.equal idu i - | _ -> false - in - try Kenvacc (r.offset + env.size - (find_at f env.fv_rev)) - with Not_found -> - let pos = env.size in - let db = FVpoly_inst idu in - r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; - Kenvacc(r.offset + pos) -*) - let pos_universe_var i r sz = if i < r.nb_uni_stack then Kacc (sz - r.nb_stack - (r.nb_uni_stack - i)) @@ -494,9 +480,9 @@ let rec str_const c = end | _ -> Bconstr c end - | Ind (ind,_) -> + | Ind (ind,u) when Univ.Instance.is_empty u -> Bstrconst (Const_ind ind) - | Construct (((kn,j),i),u) -> + | Construct (((kn,j),i),_) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) @@ -571,10 +557,6 @@ let rec get_alias env kn = | BCalias kn' -> get_alias env kn' | _ -> kn) -(* Compiling expressions *) - -type ('a,'b) sum = Inl of 'a | Inr of 'b - (* sz is the size of the local stack *) let rec compile_constr reloc c sz cont = match kind_of_term c with @@ -592,39 +574,43 @@ let rec compile_constr reloc c sz cont = | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont | Const (kn,u) -> compile_const reloc kn u [||] sz cont - | Ind (i,u) -> + | Ind (ind,u) -> + let bcst = Bstrconst (Const_ind ind) in if Univ.Instance.is_empty u then - compile_str_cst reloc (str_const c) sz cont + compile_str_cst reloc bcst sz cont else comp_app compile_str_cst compile_universe reloc - (str_const c) + bcst (Univ.Instance.to_array u) sz cont | Sort (Prop _) | Construct _ -> compile_str_cst reloc (str_const c) sz cont | Sort (Type u) -> - begin - let levels = Univ.Universe.levels u in - if Univ.LSet.exists (fun x -> Univ.Level.var_index x <> None) levels - then - (** TODO(gmalecha): Fix this **) - (** NOTE: This relies on the order of iteration to be consistent - **) - let level_vars = - List.map_filter (fun x -> Univ.Level.var_index x) - (Univ.LSet.elements levels) - in - let compile_get_univ reloc idx sz cont = + (* We separate global and local universes in [u]. The former will be part + of the structured constant, while the later (if any) will be applied as + arguments. *) + let open Univ in begin + let levels = Universe.levels u in + let global_levels = + LSet.filter (fun x -> Level.var_index x = None) levels + in + let local_levels = + List.map_filter (fun x -> Level.var_index x) + (LSet.elements levels) + in + (* We assume that [Universe.type0m] is a neutral element for [Universe.sup] *) + let uglob = + LSet.fold (fun lvl u -> Universe.sup u (Universe.make lvl)) global_levels Universe.type0m + in + if local_levels = [] then + compile_str_cst reloc (Bstrconst (Const_sorts (Type uglob))) sz cont + else + let compile_get_univ reloc idx sz cont = compile_fv_elem reloc (FVuniv_var idx) sz cont in comp_app compile_str_cst compile_get_univ reloc - (Bstrconst (Const_type u)) - (Array.of_list level_vars) - sz - cont - else - compile_str_cst reloc (str_const c) sz cont + (Bstrconst (Const_type u)) (Array.of_list local_levels) sz cont end | LetIn(_,xb,_,body) -> compile_constr reloc xb sz @@ -831,8 +817,7 @@ and compile_universe reloc uni sz cont = | None -> Kconst (Const_univ_level uni) :: cont | Some idx -> pos_universe_var idx reloc sz :: cont -and compile_const = - fun reloc-> fun kn u -> fun args -> fun sz -> fun cont -> +and compile_const reloc kn u args sz cont = let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function @@ -850,18 +835,19 @@ and compile_const = compile_get_global reloc (kn,u) sz cont) compile_constr reloc () args sz cont else - let compile_either reloc constr_or_uni sz cont = + let compile_arg reloc constr_or_uni sz cont = match constr_or_uni with - | Inl cst -> compile_constr reloc cst sz cont - | Inr uni -> compile_universe reloc uni sz cont - in - (** TODO(gmalecha): This can be more efficient **) - let all = - Array.of_list (List.map (fun x -> Inr x) (Array.to_list (Univ.Instance.to_array u)) @ - List.map (fun x -> Inl x) (Array.to_list args)) + | ArgConstr cst -> compile_constr reloc cst sz cont + | ArgUniv uni -> compile_universe reloc uni sz cont in + let u = Univ.Instance.to_array u in + let lu = Array.length u in + let all = + Array.init (lu + Array.length args) + (fun i -> if i < lu then ArgUniv u.(i) else ArgConstr args.(i-lu)) + in comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) - compile_either reloc () all sz cont + compile_arg reloc () all sz cont let is_univ_copy max u = let u = Univ.Instance.to_array u in diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 2a70d0b1b7..ef0c9af4ff 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -307,7 +307,7 @@ type to_patch = emitcodes * (patch list) * fv (* Substitution *) let rec subst_strcst s sc = match sc with - | Const_sorts _ | Const_b0 _ -> sc + | Const_sorts _ | Const_b0 _ | Const_univ_level _ | Const_type _ -> sc | Const_proj p -> Const_proj (subst_constant s p) | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 2e519789e1..4610dbcb07 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -98,6 +98,7 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = let mib = Environ.lookup_mind mi env in let ulen = Univ.UContext.size mib.Declarations.mind_universes in match stk1 , stk2 with + | [], [] -> assert (Int.equal ulen 0); cu | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> assert (ulen <= nargs args1); assert (ulen <= nargs args2); @@ -108,7 +109,7 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = let cu = convert_instances ~flex:false u1 u2 cu in conv_arguments env ~from:ulen k args1 args2 (conv_stack env k stk1' stk2' cu) - | _ -> raise NotConvertible + | _, _ -> assert false (* Should not happen if problem is well typed *) else conv_stack env k stk1 stk2 cu else raise NotConvertible diff --git a/kernel/vm.ml b/kernel/vm.ml index 858f546c60..64ddc43766 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -162,16 +162,96 @@ type whd = | Vatom_stk of atom * stack | Vuniv_level of Univ.universe_level +(************************************************) +(* Abstract machine *****************************) +(************************************************) + +(* gestion de la pile *) +external push_ra : tcode -> unit = "coq_push_ra" +external push_val : values -> unit = "coq_push_val" +external push_arguments : arguments -> unit = "coq_push_arguments" +external push_vstack : vstack -> unit = "coq_push_vstack" + + +(* interpreteur *) +external interprete : tcode -> values -> vm_env -> int -> values = + "coq_interprete_ml" + + + +(* Functions over arguments *) +let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 +let arg args i = + if 0 <= i && i < (nargs args) then + val_of_obj (Obj.field (Obj.repr args) (i+2)) + else invalid_arg + ("Vm.arg size = "^(string_of_int (nargs args))^ + " acces "^(string_of_int i)) + +(* Apply a value to arguments contained in [vargs] *) +let apply_arguments vf vargs = + let n = nargs vargs in + if Int.equal n 0 then vf + else + begin + push_ra stop; + push_arguments vargs; + interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + end + +(* Apply value [vf] to an array of argument values [varray] *) +let apply_varray vf varray = + let n = Array.length varray in + if Int.equal n 0 then vf + else + begin + push_ra stop; + push_vstack varray; + interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + end + (*************************************************) (* Destructors ***********************************) (*************************************************) +let uni_lvl_val (v : values) : Univ.universe_level = + let whd = Obj.magic v in + match whd with + | Vuniv_level lvl -> lvl + | _ -> + let pr = + let open Pp in + match whd with + | Vsort _ -> str "Vsort" + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk" + | _ -> assert false + in + Errors.anomaly + Pp.( strbrk "Parsing virtual machine value expected universe level, got " + ++ pr) + let rec whd_accu a stk = let stk = if Int.equal (Obj.size a) 2 then stk else Zapp (Obj.obj a) :: stk in let at = Obj.field a 1 in match Obj.tag at with + | i when Int.equal i type_atom_tag -> + begin match stk with + | [Zapp args] -> + let u = ref (Obj.obj (Obj.field at 0)) in + for i = 0 to nargs args - 1 do + u := Univ.Universe.sup !u (Univ.Universe.make (uni_lvl_val (arg args i))) + done; + Vsort (Type !u) + | _ -> assert false + end | i when i <= max_atom_tag -> Vatom_stk(Obj.magic at, stk) | i when Int.equal i proj_tag -> @@ -230,77 +310,6 @@ let whd_val : values -> whd = else Vconstr_block(Obj.obj o) -let uni_lvl_val : values -> Univ.universe_level = - fun v -> - let whd = Obj.magic v in - match whd with - | Vuniv_level lvl -> lvl - | _ -> - let pr = - let open Pp in - match whd with - | Vsort _ -> str "Vsort" - | Vprod _ -> str "Vprod" - | Vfun _ -> str "Vfun" - | Vfix _ -> str "Vfix" - | Vcofix _ -> str "Vcofix" - | Vconstr_const i -> str "Vconstr_const" - | Vconstr_block b -> str "Vconstr_block" - | Vatom_stk (a,stk) -> str "Vatom_stk" - | _ -> assert false - in - Errors.anomaly - Pp.( strbrk "Parsing virtual machine value expected universe level, got " - ++ pr) - -(************************************************) -(* Abstract machine *****************************) -(************************************************) - -(* gestion de la pile *) -external push_ra : tcode -> unit = "coq_push_ra" -external push_val : values -> unit = "coq_push_val" -external push_arguments : arguments -> unit = "coq_push_arguments" -external push_vstack : vstack -> unit = "coq_push_vstack" - - -(* interpreteur *) -external interprete : tcode -> values -> vm_env -> int -> values = - "coq_interprete_ml" - - - -(* Functions over arguments *) -let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 -let arg args i = - if 0 <= i && i < (nargs args) then - val_of_obj (Obj.field (Obj.repr args) (i+2)) - else invalid_arg - ("Vm.arg size = "^(string_of_int (nargs args))^ - " acces "^(string_of_int i)) - -(* Apply a value to arguments contained in [vargs] *) -let apply_arguments vf vargs = - let n = nargs vargs in - if Int.equal n 0 then vf - else - begin - push_ra stop; - push_arguments vargs; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) - end - -(* Apply value [vf] to an array of argument values [varray] *) -let apply_varray vf varray = - let n = Array.length varray in - if Int.equal n 0 then vf - else - begin - push_ra stop; - push_vstack varray; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) - end - (**********************************************) (* Constructors *******************************) (**********************************************) @@ -637,22 +646,6 @@ let apply_whd k whd = apply_stack (val_of_atom a) stk v | Vuniv_level lvl -> assert false -let instantiate_universe (u : Univ.universe) (stk : stack) : Univ.universe = - match stk with - | [] -> u - | [Zapp args] -> - assert (Univ.LSet.cardinal (Univ.Universe.levels u) = nargs args) ; - let _,mp = Univ.LSet.fold (fun key (i,mp) -> - let u = uni_lvl_val (arg args i) in - (i+1, Univ.LMap.add key (Univ.Universe.make u) mp)) - (Univ.Universe.levels u) - (0,Univ.LMap.empty) in - let subst = Univ.make_subst mp in - Univ.subst_univs_universe subst u - | _ -> - Errors.anomaly Pp.(str "ill-formed universe") - - let rec pr_atom a = Pp.(match a with | Aid c -> str "Aid(" ++ (match c with diff --git a/kernel/vm.mli b/kernel/vm.mli index bc19786632..43a42eb9c4 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -64,7 +64,6 @@ external val_of_annot_switch : annot_switch -> values = "%identity" val whd_val : values -> whd val uni_lvl_val : values -> Univ.universe_level -val instantiate_universe : Univ.universe -> stack -> Univ.universe (** Arguments *) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b9c1a5a1c7..c4c85a62ed 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -155,7 +155,6 @@ and nf_whd env whd typ = construct_of_constr_const env n typ | Vconstr_block b -> let tag = btag b in - let x = tag in let (tag,ofs) = if tag = Cbytecodes.last_variant_tag then match whd_val (bfield b 0) with @@ -166,62 +165,54 @@ and nf_whd env whd typ = let args = nf_bargs env b ofs ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> - constr_type_of_idkey env idkey stk nf_stk -(*let c,typ = constr_type_of_idkey env idkey in - nf_stk env c typ stk *) + constr_type_of_idkey env idkey stk | Vatom_stk(Aind ((mi,i) as ind), stk) -> - if Environ.polymorphic_ind ind env then - let mib = Environ.lookup_mind mi env in - let ulen = Univ.UContext.size mib.mind_universes in - match stk with - | Zapp args :: stk' -> - assert (ulen <= nargs args) ; - let inst = - Array.init ulen (fun i -> Vm.uni_lvl_val (arg args i)) - in - let pind = (ind, Univ.Instance.of_array inst) in - nf_stk ~from:ulen env (mkIndU pind) (type_of_ind env pind) stk - | _ -> assert false - else - let pind = (ind, Univ.Instance.empty) in - nf_stk env (mkIndU pind) (type_of_ind env pind) stk - | Vatom_stk(Atype u, stk) -> - mkSort (Type (Vm.instantiate_universe u stk)) + let mib = Environ.lookup_mind mi env in + let nb_univs = + if mib.mind_polymorphic then Univ.UContext.size mib.mind_universes + else 0 + in + let mk u = + let pind = (ind, u) in (mkIndU pind, type_of_ind env pind) + in + nf_univ_args ~nb_univs mk env stk + | Vatom_stk(Atype u, stk) -> assert false | Vuniv_level lvl -> assert false -and constr_type_of_idkey env (idkey : Vars.id_key) stk cont = +and nf_univ_args ~nb_univs mk env stk = + let u = + if Int.equal nb_univs 0 then Univ.Instance.empty + else match stk with + | Zapp args :: _ -> + let inst = + Array.init nb_univs (fun i -> Vm.uni_lvl_val (arg args i)) + in + Univ.Instance.of_array inst + | _ -> assert false + in + let (t,ty) = mk u in + nf_stk ~from:nb_univs env t ty stk + +and constr_type_of_idkey env (idkey : Vars.id_key) stk = match idkey with | ConstKey cst -> - if Environ.polymorphic_constant cst env then - let cbody = Environ.lookup_constant cst env in - match stk with - | Zapp vargs :: stk' -> - let uargs = Univ.UContext.size cbody.const_universes in - assert (Vm.nargs vargs >= uargs) ; - let uary = Array.init uargs (fun i -> Vm.uni_lvl_val (Vm.arg vargs i)) in - let ui = Univ.Instance.of_array uary in - let ucst = (cst, ui) in - let const_type = Typeops.type_of_constant_in env ucst in - if uargs < Vm.nargs vargs then - let t, args = nf_args env vargs ~from:uargs const_type in - cont env (mkApp (mkConstU ucst, args)) t stk' - else - cont env (mkConstU ucst) const_type stk' - | _ -> assert false - else - begin - let ucst = (cst, Univ.Instance.empty) in - let const_type = Typeops.type_of_constant_in env ucst in - cont env (mkConstU ucst) const_type stk - end - | VarKey id -> + let cbody = Environ.lookup_constant cst env in + let nb_univs = + if cbody.const_polymorphic then Univ.UContext.size cbody.const_universes + else 0 + in + let mk u = + let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst) + in + nf_univ_args ~nb_univs mk env stk + | VarKey id -> let (_,_,ty) = lookup_named id env in - cont env (mkVar id) ty stk + nf_stk env (mkVar id) ty stk | RelKey i -> let n = (nb_rel env - i) in let (_,_,ty) = lookup_rel n env in - cont env (mkRel n) (lift n ty) stk + nf_stk env (mkRel n) (lift n ty) stk and nf_stk ?from:(from=0) env c t stk = match stk with -- cgit v1.2.3 From f1dd27ae0e6082b111770fa74cba6abda30f3b89 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 28 Oct 2015 12:51:51 +0100 Subject: Fix bug in native compiler with universe polymorphism. Universe instances for constructors were not always correct, for instance in: [cons _ list (nil _)] with a polymorphic [list] type, [nil] was receiving an empty instance. --- pretyping/nativenorm.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index dafe88d8db..de988aa2cd 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -53,8 +53,8 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib typ params = - let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in +let type_constructor mind mib u typ params = + let s = ind_subst mind mib u in let ctyp = substl s typ in let nparams = Array.length params in if Int.equal nparams 0 then ctyp @@ -68,13 +68,13 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let params = Array.sub allargs 0 nparams in try if const then - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(0)) params in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(0)) params in retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag, ctyp else raise Not_found with Not_found -> let i = invert_tag const tag mip.mind_reloc_tbl in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in (mkApp(mkConstructU((ind,i),u), params), ctyp) @@ -90,12 +90,12 @@ let construct_of_constr_const env tag typ = let construct_of_constr_block = construct_of_constr false -let build_branches_type env (mind,_ as _ind) mib mip params dep p = +let build_branches_type env (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = - let typi = type_constructor mind mib cty params in + let typi = type_constructor mind mib u cty params in let decl,indapp = Reductionops.splay_prod env Evd.empty typi in let decl_with_letin,_ = decompose_prod_assum typi in let ind,cargs = find_rectype_a env indapp in @@ -292,7 +292,7 @@ and nf_atom_type env atom = let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params p pT in (* Calcul du type des branches *) - let btypes = build_branches_type env (fst ind) mib mip params dep p in + let btypes = build_branches_type env (fst ind) mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = -- cgit v1.2.3 From 110f7b41eca9c3e22fff0df67419b57d9c2ef612 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 28 Oct 2015 16:56:41 +0100 Subject: Fix test suite after Matthieu's ed7af646f2e486b. --- test-suite/success/univnames.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/success/univnames.v b/test-suite/success/univnames.v index 31d264f645..048b53d26c 100644 --- a/test-suite/success/univnames.v +++ b/test-suite/success/univnames.v @@ -21,6 +21,6 @@ Inductive bla@{l k} : Type@{k} := blaI : Type@{l} -> bla. Inductive blacopy@{k l} : Type@{k} := blacopyI : Type@{l} -> blacopy. -Universe g. +Monomorphic Universe g. Inductive blacopy'@{l} : Type@{g} := blacopy'I : Type@{l} -> blacopy'. \ No newline at end of file -- cgit v1.2.3 From 0a1b046d37761fe47435d5041bb5031e3f7d6613 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 28 Oct 2015 10:03:17 +0100 Subject: lib_stack: API to reorder the libstack For discharging it is important that constants occur in the libstack in an order that respects the dependencies among them. This is impossible to achieve for private constants when they are exported globally without this (ugly IMO) api. --- library/lib.ml | 3 +++ library/lib.mli | 1 + 2 files changed, 4 insertions(+) diff --git a/library/lib.ml b/library/lib.ml index cdc8889037..297441e6e2 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -198,6 +198,9 @@ let split_lib_at_opening sp = let add_entry sp node = lib_stk := (sp,node) :: !lib_stk +let pull_to_head oname = + lib_stk := (oname,List.assoc oname !lib_stk) :: List.remove_assoc oname !lib_stk + let anonymous_id = let n = ref 0 in fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n)) diff --git a/library/lib.mli b/library/lib.mli index b67b2b873f..bb88317591 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -55,6 +55,7 @@ val segment_of_objects : val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name val add_anonymous_leaf : Libobject.obj -> unit +val pull_to_head : Libnames.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) -- cgit v1.2.3 From 908dcd613b12645f3b62bf44c2696b80a0b16940 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 28 Oct 2015 16:46:42 +0100 Subject: Avoid type checking private_constants (side_eff) again during Qed (#4357). Side effects are now an opaque data type, called private_constant, you can only obtain from safe_typing. When add_constant is called on a definition_entry that contains private constants, they are either - inlined in the main proof term but not re-checked - declared globally without re-checking them As a safety measure, the opaque data type contains a pointer to the revstruct (an internal field of safe_env that changes every time a new constant is added), and such pointer is compared with the current value store in safe_env when the private_constant is inlined. Only when the comparison is successful the private_constant is not re-checked. Otherwise else it is. In short, we accept into the kernel private constant only when they arrive in the very same order and on top of the very same env they arrived when we fist checked them. Note: private_constants produced by workers never pass the safety measure (the revstruct pointer is an Ephemeron). Sending back the entire revstruct is possible but: 1. we lack a way to quickly compare two revstructs, 2. it can be large. --- kernel/declarations.mli | 6 - kernel/declareops.ml | 18 +-- kernel/declareops.mli | 12 +- kernel/entries.mli | 25 +++- kernel/opaqueproof.ml | 5 +- kernel/safe_typing.ml | 103 +++++++++++--- kernel/safe_typing.mli | 41 +++++- kernel/term_typing.ml | 188 ++++++++++++++++++++++--- kernel/term_typing.mli | 33 ++++- library/declare.ml | 151 +++++++++----------- library/declare.mli | 10 +- library/global.mli | 5 +- library/heads.ml | 5 +- library/libobject.ml | 3 + plugins/derive/derive.ml | 4 +- plugins/funind/functional_principles_types.ml | 14 +- plugins/funind/functional_principles_types.mli | 10 +- plugins/funind/indfun_common.ml | 2 +- plugins/funind/indfun_common.mli | 4 +- pretyping/evd.ml | 26 +--- pretyping/evd.mli | 4 +- proofs/pfedit.ml | 10 +- proofs/pfedit.mli | 6 +- proofs/proof_global.ml | 9 +- proofs/proof_global.mli | 4 +- proofs/proofview.mli | 2 +- stm/lemmas.ml | 5 +- tactics/elimschemes.ml | 20 +-- tactics/eqschemes.ml | 17 +-- tactics/eqschemes.mli | 4 +- tactics/equality.ml | 2 +- tactics/tactics.ml | 6 +- toplevel/auto_ind_decl.ml | 23 ++- toplevel/classes.ml | 2 +- toplevel/command.ml | 8 +- toplevel/command.mli | 10 +- toplevel/discharge.ml | 4 +- toplevel/ind_tables.ml | 22 +-- toplevel/ind_tables.mli | 10 +- toplevel/indschemes.ml | 4 +- toplevel/obligations.ml | 12 +- toplevel/obligations.mli | 4 +- toplevel/record.ml | 6 +- 43 files changed, 547 insertions(+), 312 deletions(-) diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 7def963e73..dc5c17a75b 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -79,12 +79,6 @@ type constant_body = { const_proj : projection_body option; const_inline_code : bool } -type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ] - -type side_effect = - | SEsubproof of constant * constant_body * seff_env - | SEscheme of (inductive * constant * constant_body * seff_env) list * string - (** {6 Representation of mutual inductive types in the kernel } *) type recarg = diff --git a/kernel/declareops.ml b/kernel/declareops.ml index a7051d5c13..248504c1b1 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -304,17 +304,7 @@ let hcons_mind mib = (** {6 Stm machinery } *) -let string_of_side_effect = function - | SEsubproof (c,_,_) -> Names.string_of_con c - | SEscheme (cl,_) -> - String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) -type side_effects = side_effect list -let no_seff = ([] : side_effects) -let iter_side_effects f l = List.iter f (List.rev l) -let fold_side_effects f a l = List.fold_left f a l -let uniquize_side_effects l = List.rev (CList.uniquize (List.rev l)) -let union_side_effects l1 l2 = l1 @ l2 -let flatten_side_effects l = List.flatten l -let side_effects_of_list l = l -let cons_side_effects x l = x :: l -let side_effects_is_empty = List.is_empty +let string_of_side_effect { Entries.eff } = match eff with + | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.string_of_con c ^ ")" + | Entries.SEscheme (cl,_) -> + "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) ^ ")" diff --git a/kernel/declareops.mli b/kernel/declareops.mli index ce65af975e..1b87009589 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -9,6 +9,7 @@ open Declarations open Mod_subst open Univ +open Entries (** Operations concerning types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) @@ -49,17 +50,6 @@ val is_opaque : constant_body -> bool val string_of_side_effect : side_effect -> string -type side_effects -val no_seff : side_effects -val iter_side_effects : (side_effect -> unit) -> side_effects -> unit -val fold_side_effects : ('a -> side_effect -> 'a) -> 'a -> side_effects -> 'a -val uniquize_side_effects : side_effects -> side_effects -val union_side_effects : side_effects -> side_effects -> side_effects -val flatten_side_effects : side_effects list -> side_effects -val side_effects_of_list : side_effect list -> side_effects -val cons_side_effects : side_effect -> side_effects -> side_effects -val side_effects_is_empty : side_effects -> bool - (** {6 Inductive types} *) val eq_recarg : recarg -> recarg -> bool diff --git a/kernel/entries.mli b/kernel/entries.mli index 303d27d355..e058519e96 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -54,11 +54,11 @@ type mutual_inductive_entry = { mind_entry_private : bool option } (** {6 Constants (Definition/Axiom) } *) -type proof_output = constr Univ.in_universe_context_set * Declareops.side_effects -type const_entry_body = proof_output Future.computation +type 'a proof_output = constr Univ.in_universe_context_set * 'a +type 'a const_entry_body = 'a proof_output Future.computation -type definition_entry = { - const_entry_body : const_entry_body; +type 'a definition_entry = { + const_entry_body : 'a const_entry_body; (* List of section variables *) const_entry_secctx : Context.section_context option; (* State id on which the completion of type checking is reported *) @@ -78,8 +78,8 @@ type projection_entry = { proj_entry_ind : mutual_inductive; proj_entry_arg : int } -type constant_entry = - | DefinitionEntry of definition_entry +type 'a constant_entry = + | DefinitionEntry of 'a definition_entry | ParameterEntry of parameter_entry | ProjectionEntry of projection_entry @@ -96,3 +96,16 @@ type module_entry = | MType of module_params_entry * module_struct_entry | MExpr of module_params_entry * module_struct_entry * module_struct_entry option + +type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ] + +type side_eff = + | SEsubproof of constant * Declarations.constant_body * seff_env + | SEscheme of (inductive * constant * Declarations.constant_body * seff_env) list * string + +type side_effect = { + from_env : Declarations.structure_body Ephemeron.key; + eff : side_eff; +} + +type side_effects = side_effect list diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 9f4361f401..badb15b561 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -43,7 +43,10 @@ let set_indirect_univ_accessor f = (get_univ := f) let create cu = Direct ([],cu) let turn_indirect dp o (prfs,odp) = match o with - | Indirect _ -> Errors.anomaly (Pp.str "Already an indirect opaque") + | Indirect (_,_,i) -> + if not (Int.Map.mem i prfs) + then Errors.anomaly (Pp.str "Indirect in a different table") + else Errors.anomaly (Pp.str "Already an indirect opaque") | Direct (d,cu) -> let cu = Future.chain ~pure:true cu (fun (c, u) -> hcons_constr c, u) in let id = Int.Map.cardinal prfs in diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ec245b0648..b71cd31b5c 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -207,15 +207,55 @@ let get_opaque_body env cbo = (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) -let sideff_of_con env c = +type private_constant = Entries.side_effect +type private_constants = private_constant list + +type private_constant_role = Term_typing.side_effect_role = + | Subproof + | Schema of inductive * string + +let empty_private_constants = [] +let add_private x xs = x :: xs +let concat_private xs ys = xs @ ys +let mk_pure_proof = Term_typing.mk_pure_proof +let inline_private_constants_in_constr = Term_typing.handle_side_effects +let inline_private_constants_in_definition_entry = Term_typing.handle_entry_side_effects +let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x) + +let constant_entry_of_private_constant = function + | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } -> + [ kn, Term_typing.constant_entry_of_side_effect cb eff_env ] + | { Entries.eff = Entries.SEscheme (l,_) } -> + List.map (fun (_,kn,cb,eff_env) -> + kn, Term_typing.constant_entry_of_side_effect cb eff_env) l + +let private_con_of_con env c = let cbo = Environ.lookup_constant c env.env in - SEsubproof (c, cbo, get_opaque_body env.env cbo) -let sideff_of_scheme kind env cl = - SEscheme( - List.map (fun (i,c) -> - let cbo = Environ.lookup_constant c env.env in - i, c, cbo, get_opaque_body env.env cbo) cl, - kind) + { Entries.from_env = Ephemeron.create env.revstruct; + Entries.eff = Entries.SEsubproof (c,cbo,get_opaque_body env.env cbo) } + +let private_con_of_scheme ~kind env cl = + { Entries.from_env = Ephemeron.create env.revstruct; + Entries.eff = Entries.SEscheme( + List.map (fun (i,c) -> + let cbo = Environ.lookup_constant c env.env in + i, c, cbo, get_opaque_body env.env cbo) cl, + kind) } + +let universes_of_private eff = + let open Declarations in + List.fold_left (fun acc { Entries.eff } -> + match eff with + | Entries.SEscheme (l,s) -> + List.fold_left (fun acc (_,_,cb,c) -> + let acc = match c with + | `Nothing -> acc + | `Opaque (_, ctx) -> ctx :: acc in + if cb.const_polymorphic then acc + else (Univ.ContextSet.of_context cb.const_universes) :: acc) + acc l + | Entries.SEsubproof _ -> acc) + [] eff let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env @@ -337,7 +377,7 @@ let safe_push_named (id,_,_ as d) env = let push_named_def (id,de) senv = - let c,typ,univs = Term_typing.translate_local_def senv.env id de in + let c,typ,univs = Term_typing.translate_local_def senv.revstruct senv.env id de in let poly = de.Entries.const_entry_polymorphic in let univs = Univ.ContextSet.of_context univs in let c, univs = match c with @@ -442,19 +482,16 @@ let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) type global_declaration = - | ConstantEntry of Entries.constant_entry + | ConstantEntry of bool * private_constants Entries.constant_entry | GlobalRecipe of Cooking.recipe -let add_constant dir l decl senv = - let kn = make_con senv.modpath dir l in - let cb = match decl with - | ConstantEntry ce -> Term_typing.translate_constant senv.env kn ce - | GlobalRecipe r -> - let cb = Term_typing.translate_recipe senv.env kn r in - if DirPath.is_empty dir then Declareops.hcons_const_body cb else cb - in +type exported_private_constant = + constant * private_constants Entries.constant_entry * private_constant_role + +let add_constant_aux no_section senv (kn, cb) = + let l = pi3 (Constant.repr3 kn) in let cb, otab = match cb.const_body with - | OpaqueDef lc when DirPath.is_empty dir -> + | OpaqueDef lc when no_section -> (* In coqc, opaque constants outside sections will be stored indirectly in a specific table *) let od, otab = @@ -471,7 +508,33 @@ let add_constant dir l decl senv = (Mod_subst.add_inline_delta_resolver (user_con kn) (lev,None)) senv' | _ -> senv' in - kn, senv'' + senv'' + +let add_constant dir l decl senv = + let kn = make_con senv.modpath dir l in + let no_section = DirPath.is_empty dir in + let seff_to_export, decl = + match decl with + | ConstantEntry (true, ce) -> + let exports, ce = + Term_typing.validate_side_effects_for_export + senv.revstruct senv.env ce in + exports, ConstantEntry (false, ce) + | _ -> [], decl + in + let senv = + List.fold_left (add_constant_aux no_section) senv + (List.map (fun (kn,cb,_,_) -> kn, cb) seff_to_export) in + let senv = + let cb = + match decl with + | ConstantEntry (export_seff,ce) -> + Term_typing.translate_constant senv.revstruct senv.env kn ce + | GlobalRecipe r -> + let cb = Term_typing.translate_recipe senv.env kn r in + if no_section then Declareops.hcons_const_body cb else cb in + add_constant_aux no_section senv (kn, cb) in + (kn, List.map (fun (kn,_,ce,r) -> kn, ce, r) seff_to_export), senv (** Insertion of inductive types *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index eac08eb834..2214cf8bb8 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -39,10 +39,30 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment (** {6 Stm machinery } *) -val sideff_of_con : safe_environment -> constant -> Declarations.side_effect -val sideff_of_scheme : - string -> safe_environment -> (inductive * constant) list -> - Declarations.side_effect +type private_constant +type private_constants + +type private_constant_role = + | Subproof + | Schema of inductive * string + +val side_effects_of_private_constants : + private_constants -> Entries.side_effects + +val empty_private_constants : private_constants +val add_private : private_constant -> private_constants -> private_constants +val concat_private : private_constants -> private_constants -> private_constants + +val private_con_of_con : safe_environment -> constant -> private_constant +val private_con_of_scheme : kind:string -> safe_environment -> (inductive * constant) list -> private_constant + +val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output +val inline_private_constants_in_constr : + Environ.env -> Constr.constr -> private_constants -> Constr.constr +val inline_private_constants_in_definition_entry : + Environ.env -> private_constants Entries.definition_entry -> private_constants Entries.definition_entry + +val universes_of_private : private_constants -> Univ.universe_context_set list val is_curmod_library : safe_environment -> bool @@ -63,16 +83,23 @@ val push_named_assum : (** Returns the full universe context necessary to typecheck the definition (futures are forced) *) val push_named_def : - Id.t * Entries.definition_entry -> Univ.universe_context_set safe_transformer + Id.t * private_constants Entries.definition_entry -> Univ.universe_context_set safe_transformer (** Insertion of global axioms or definitions *) type global_declaration = - | ConstantEntry of Entries.constant_entry + (* bool: export private constants *) + | ConstantEntry of bool * private_constants Entries.constant_entry | GlobalRecipe of Cooking.recipe +type exported_private_constant = + constant * private_constants Entries.constant_entry * private_constant_role + +(** returns the main constant plus a list of auxiliary constants (empty + unless one requires the side effects to be exported) *) val add_constant : - DirPath.t -> Label.t -> global_declaration -> constant safe_transformer + DirPath.t -> Label.t -> global_declaration -> + (constant * exported_private_constant list) safe_transformer (** Adding an inductive type *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index cab99077f0..d75bd73fb6 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -43,10 +43,29 @@ let map_option_typ = function None -> `None | Some x -> `Some x (* Insertion of constants and parameters in environment. *) -let mk_pure_proof c = (c, Univ.ContextSet.empty), Declareops.no_seff +let mk_pure_proof c = (c, Univ.ContextSet.empty), [] + +let equal_eff e1 e2 = + let open Entries in + match e1, e2 with + | { eff = SEsubproof (c1,_,_) }, { eff = SEsubproof (c2,_,_) } -> + Names.Constant.equal c1 c2 + | { eff = SEscheme (cl1,_) }, { eff = SEscheme (cl2,_) } -> + CList.for_all2eq + (fun (_,c1,_,_) (_,c2,_,_) -> Names.Constant.equal c1 c2) + cl1 cl2 + | _ -> false + +let rec uniq_seff = function + | [] -> [] + | x :: xs -> x :: uniq_seff (List.filter (fun y -> not (equal_eff x y)) xs) +(* The list of side effects is in reverse order (most recent first). + * To keep the "tological" order between effects we have to uniqize from the + * tail *) +let uniq_seff l = List.rev (uniq_seff (List.rev l)) let handle_side_effects env body ctx side_eff = - let handle_sideff (t,ctx) se = + let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } = let cbl = match se with | SEsubproof (c,cb,b) -> [c,cb,b] | SEscheme (cl,_) -> List.map (fun (_,c,cb,b) -> c,cb,b) cl in @@ -65,7 +84,7 @@ let handle_side_effects env body ctx side_eff = let rec sub_body c u b i x = match kind_of_term x with | Const (c',u') when eq_constant c c' -> Vars.subst_instance_constr u' b - | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub_body c u b i x) i x in + | _ -> map_constr_with_binders ((+) 1) (sub_body c u b) i x in let fix_body (c,cb,b) (t,ctx) = match cb.const_body, b with | Def b, _ -> @@ -87,17 +106,60 @@ let handle_side_effects env body ctx side_eff = let t = sub c 1 (Vars.lift 1 t) in mkApp (mkLambda (cname c, b_ty, t), [|b|]), Univ.ContextSet.union ctx - (Univ.ContextSet.of_context cb.const_universes) + (Univ.ContextSet.of_context cb.const_universes) else let univs = cb.const_universes in sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t), ctx | _ -> assert false in - List.fold_right fix_body cbl (t,ctx) + let t, ctx = List.fold_right fix_body cbl (t,ctx) in + t, ctx, (mb,List.length cbl) :: sl in (* CAVEAT: we assure a proper order *) - Declareops.fold_side_effects handle_sideff (body,ctx) - (Declareops.uniquize_side_effects side_eff) + List.fold_left handle_sideff (body,ctx,[]) (uniq_seff side_eff) + +let check_signatures curmb sl = + let is_direct_ancestor (sl, curmb) (mb, how_many) = + match curmb with + | None -> None, None + | Some curmb -> + try + let mb = Ephemeron.get mb in + match sl with + | None -> sl, None + | Some n -> + if List.length mb >= how_many && CList.skipn how_many mb == curmb + then Some (n + how_many), Some mb + else None, None + with Ephemeron.InvalidKey -> None, None in + let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in + sl + +let trust_seff sl b e = + let rec aux sl b e acc = + match sl, kind_of_term b with + | (None|Some 0), _ -> b, e, acc + | Some sl, LetIn (n,c,ty,bo) -> + aux (Some (sl-1)) bo + (Environ.push_rel (n,Some c,ty) e) (`Let(n,c,ty)::acc) + | Some sl, App(hd,arg) -> + begin match kind_of_term hd with + | Lambda (n,ty,bo) -> + aux (Some (sl-1)) bo + (Environ.push_rel (n,None,ty) e) (`Cut(n,ty,arg)::acc) + | _ -> assert false + end + | _ -> assert false + in + aux sl b e [] + +let rec unzip ctx j = + match ctx with + | [] -> j + | `Let (n,c,ty) :: ctx -> + unzip ctx { j with uj_val = mkLetIn (n,c,ty,j.uj_val) } + | `Cut (n,ty,arg) :: ctx -> + unzip ctx { j with uj_val = mkApp (mkLambda (n,ty,j.uj_val),arg) } let hcons_j j = { uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} @@ -105,7 +167,7 @@ let hcons_j j = let feedback_completion_typecheck = Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete) -let infer_declaration env kn dcl = +let infer_declaration ~trust env kn dcl = match dcl with | ParameterEntry (ctx,poly,(t,uctx),nl) -> let env = push_context ~strict:(not poly) uctx env in @@ -124,9 +186,14 @@ let infer_declaration env kn dcl = let tyj = infer_type env typ in let proofterm = Future.chain ~greedy:true ~pure:true body (fun ((body, ctx),side_eff) -> - let body,ctx = handle_side_effects env body ctx side_eff in + let body, ctx, signatures = + handle_side_effects env body ctx side_eff in + let trusted_signatures = check_signatures trust signatures in let env' = push_context_set ctx env in - let j = infer env' body in + let j = + let body, env', zip_ctx = trust_seff trusted_signatures body env' in + let j = infer env' body in + unzip zip_ctx j in let j = hcons_j j in let subst = Univ.LMap.empty in let _typ = constrain_type env' j c.const_entry_polymorphic subst @@ -143,7 +210,7 @@ let infer_declaration env kn dcl = let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in let univsctx = Univ.ContextSet.of_context c.const_entry_universes in - let body, ctx = handle_side_effects env body + let body, ctx, _ = handle_side_effects env body (Univ.ContextSet.union univsctx ctx) side_eff in let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in @@ -294,8 +361,93 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) (*s Global and local constant declaration. *) -let translate_constant env kn ce = - build_constant_declaration kn env (infer_declaration env (Some kn) ce) +let translate_constant mb env kn ce = + build_constant_declaration kn env + (infer_declaration ~trust:mb env (Some kn) ce) + +let constant_entry_of_side_effect cb u = + let pt = + match cb.const_body, u with + | OpaqueDef _, `Opaque (b, c) -> b, c + | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty + | _ -> assert false in + DefinitionEntry { + const_entry_body = Future.from_val (pt, []); + const_entry_secctx = None; + const_entry_feedback = None; + const_entry_type = + (match cb.const_type with RegularArity t -> Some t | _ -> None); + const_entry_polymorphic = cb.const_polymorphic; + const_entry_universes = cb.const_universes; + const_entry_opaque = Declareops.is_opaque cb; + const_entry_inline_code = cb.const_inline_code } +;; + +let turn_direct (kn,cb,u,r as orig) = + match cb.const_body, u with + | OpaqueDef _, `Opaque (b,c) -> + let pt = Future.from_val (b,c) in + kn, { cb with const_body = OpaqueDef (Opaqueproof.create pt) }, u, r + | _ -> orig +;; + +type side_effect_role = + | Subproof + | Schema of inductive * string + +type exported_side_effect = + constant * constant_body * side_effects Entries.constant_entry * side_effect_role + +let validate_side_effects_for_export mb env ce = + match ce with + | ParameterEntry _ | ProjectionEntry _ -> [], ce + | DefinitionEntry c -> + let { const_entry_body = body } = c in + let _, eff = Future.force body in + let ce = DefinitionEntry { c with + const_entry_body = Future.chain ~greedy:true ~pure:true body + (fun (b_ctx, _) -> b_ctx, []) } in + let not_exists (c,_,_,_) = + try ignore(Environ.lookup_constant c env); false + with Not_found -> true in + let aux (acc,sl) { eff = se; from_env = mb } = + let cbl = match se with + | SEsubproof (c,cb,b) -> [c,cb,b,Subproof] + | SEscheme (cl,k) -> + List.map (fun (i,c,cb,b) -> c,cb,b,Schema(i,k)) cl in + let cbl = List.filter not_exists cbl in + if cbl = [] then acc, sl + else cbl :: acc, (mb,List.length cbl) :: sl in + let seff, signatures = List.fold_left aux ([],[]) (uniq_seff eff) in + let trusted = check_signatures mb signatures in + let push_seff env = function + | kn, cb, `Nothing, _ -> + Environ.add_constant kn cb env + | kn, cb, `Opaque(_, ctx), _ -> + let env = Environ.add_constant kn cb env in + Environ.push_context_set + ~strict:(not cb.const_polymorphic) ctx env in + let rec translate_seff sl seff acc env = + match sl, seff with + | _, [] -> List.rev acc, ce + | (None | Some 0), cbs :: rest -> + let env, cbs = + List.fold_left (fun (env,cbs) (kn, ocb, u, r) -> + let ce = constant_entry_of_side_effect ocb u in + let cb = translate_constant mb env kn ce in + (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,ce,r) :: cbs)) + (env,[]) cbs in + translate_seff sl rest (cbs @ acc) env + | Some sl, cbs :: rest -> + let cbs_len = List.length cbs in + let cbs = List.map turn_direct cbs in + let env = List.fold_left push_seff env cbs in + let ecbs = List.map (fun (kn,cb,u,r) -> + kn, cb, constant_entry_of_side_effect cb u, r) cbs in + translate_seff (Some (sl-cbs_len)) rest (ecbs @ acc) env + in + translate_seff trusted seff [] env +;; let translate_local_assum env t = let j = infer env t in @@ -305,9 +457,9 @@ let translate_local_assum env t = let translate_recipe env kn r = build_constant_declaration kn env (Cooking.cook_constant env r) -let translate_local_def env id centry = +let translate_local_def mb env id centry = let def,typ,proj,poly,univs,inline_code,ctx = - infer_declaration env None (DefinitionEntry centry) in + infer_declaration ~trust:mb env None (DefinitionEntry centry) in let typ = type_of_constant_type env typ in if ctx = None && !Flags.compilation_mode = Flags.BuildVo then begin match def with @@ -332,9 +484,9 @@ let translate_mind env kn mie = Indtypes.check_inductive env kn mie let handle_entry_side_effects env ce = { ce with const_entry_body = Future.chain ~greedy:true ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> - let body, ctx' = handle_side_effects env body ctx side_eff in - (body, ctx'), Declareops.no_seff); + let body, ctx',_ = handle_side_effects env body ctx side_eff in + (body, ctx'), []); } let handle_side_effects env body side_eff = - fst (handle_side_effects env body Univ.ContextSet.empty side_eff) + pi1 (handle_side_effects env body Univ.ContextSet.empty side_eff) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 8d92bcc68f..509160ccc7 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -12,23 +12,42 @@ open Environ open Declarations open Entries -val translate_local_def : env -> Id.t -> definition_entry -> +val translate_local_def : structure_body -> env -> Id.t -> side_effects definition_entry -> constant_def * types * constant_universes val translate_local_assum : env -> types -> types -val mk_pure_proof : constr -> proof_output +val mk_pure_proof : constr -> side_effects proof_output -val handle_side_effects : env -> constr -> Declareops.side_effects -> constr +val handle_side_effects : env -> constr -> side_effects -> constr (** Returns the term where side effects have been turned into let-ins or beta redexes. *) -val handle_entry_side_effects : env -> definition_entry -> definition_entry +val handle_entry_side_effects : env -> side_effects definition_entry -> side_effects definition_entry (** Same as {!handle_side_effects} but applied to entries. Only modifies the {!Entries.const_entry_body} field. It is meant to get a term out of a not yet type checked proof. *) -val translate_constant : env -> constant -> constant_entry -> constant_body +val uniq_seff : side_effects -> side_effects + +val translate_constant : structure_body -> env -> constant -> side_effects constant_entry -> constant_body + +(* Checks weather the side effects in constant_entry can be trusted. + * Returns the list of effects to be exported. + * Note: It forces the Future.computation. *) +type side_effect_role = + | Subproof + | Schema of inductive * string + +type exported_side_effect = + constant * constant_body * side_effects Entries.constant_entry * side_effect_role + +val validate_side_effects_for_export : + structure_body -> env -> side_effects constant_entry -> + exported_side_effect list * side_effects constant_entry + +val constant_entry_of_side_effect : + constant_body -> seff_env -> side_effects constant_entry val translate_mind : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body @@ -37,8 +56,8 @@ val translate_recipe : env -> constant -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : env -> constant option -> - constant_entry -> Cooking.result +val infer_declaration : trust:structure_body -> env -> constant option -> + side_effects constant_entry -> Cooking.result val build_constant_declaration : constant -> env -> Cooking.result -> constant_body diff --git a/library/declare.ml b/library/declare.ml index 0004f45a29..63e5a72245 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -35,7 +35,7 @@ type internal_flag = (** Declaration of section variables and local definitions *) type section_variable_entry = - | SectionLocalDef of definition_entry + | SectionLocalDef of Safe_typing.private_constants definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -93,9 +93,13 @@ type constant_obj = { cst_hyps : Dischargedhypsmap.discharged_hyps; cst_kind : logical_kind; cst_locl : bool; + mutable cst_exported : Safe_typing.exported_private_constant list; + (* mutable: to avoid change the libobject API, since cache_function + * does not return an updated object *) + mutable cst_was_seff : bool } -type constant_declaration = constant_entry * logical_kind +type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) @@ -131,8 +135,17 @@ let check_exists sp = let cache_constant ((sp,kn), obj) = let id = basename sp in let _,dir,_ = repr_kn kn in - let () = check_exists sp in - let kn' = Global.add_constant dir id obj.cst_decl in + let kn' = + if obj.cst_was_seff then begin + obj.cst_was_seff <- false; + if Global.exists_objlabel (Label.of_id (basename sp)) + then constant_of_kn kn + else Errors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp)) + end else + let () = check_exists sp in + let kn', exported = Global.add_constant dir id obj.cst_decl in + obj.cst_exported <- exported; + kn' in assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); let cst = Global.lookup_constant kn' in @@ -156,20 +169,23 @@ let discharge_constant ((sp, kn), obj) = Some { obj with cst_hyps = new_hyps; cst_decl = new_decl; } (* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_constant_entry = - ConstantEntry (ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) +let dummy_constant_entry = + ConstantEntry + (false, ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) let dummy_constant cst = { cst_decl = dummy_constant_entry; cst_hyps = []; cst_kind = cst.cst_kind; cst_locl = cst.cst_locl; + cst_exported = []; + cst_was_seff = cst.cst_was_seff; } let classify_constant cst = Substitute (dummy_constant cst) -let inConstant : constant_obj -> obj = - declare_object { (default_object "CONSTANT") with +let (inConstant, outConstant : (constant_obj -> obj) * (obj -> constant_obj)) = + declare_object_full { (default_object "CONSTANT") with cache_function = cache_constant; load_function = load_constant; open_function = open_constant; @@ -177,16 +193,40 @@ let inConstant : constant_obj -> obj = subst_function = ident_subst_function; discharge_function = discharge_constant } +let declare_scheme = ref (fun _ _ -> assert false) +let set_declare_scheme f = declare_scheme := f + let declare_constant_common id cst = - let (sp,kn) = add_leaf id (inConstant cst) in + let update_tables c = +(* Printf.eprintf "tables: %s\n%!" (Names.Constant.to_string c); *) + declare_constant_implicits c; + Heads.declare_head (EvalConstRef c); + Notation.declare_ref_arguments_scope (ConstRef c) in + let o = inConstant cst in + let _, kn as oname = add_leaf id o in + List.iter (fun (c,ce,role) -> + (* handling of private_constants just exported *) + let o = inConstant { + cst_decl = ConstantEntry (false, ce); + cst_hyps = [] ; + cst_kind = IsProof Theorem; + cst_locl = false; + cst_exported = []; + cst_was_seff = true; } in + let id = Label.to_id (pi3 (Constant.repr3 c)) in + ignore(add_leaf id o); + update_tables c; + match role with + | Safe_typing.Subproof -> () + | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|]) + (outConstant o).cst_exported; + pull_to_head oname; let c = Global.constant_of_delta_kn kn in - declare_constant_implicits c; - Heads.declare_head (EvalConstRef c); - Notation.declare_ref_arguments_scope (ConstRef c); + update_tables c; c let definition_entry ?(opaque=false) ?(inline=false) ?types - ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Declareops.no_seff) body = + ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Safe_typing.empty_private_constants) body = { const_entry_body = Future.from_val ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; @@ -196,90 +236,25 @@ let definition_entry ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let declare_scheme = ref (fun _ _ -> assert false) -let set_declare_scheme f = declare_scheme := f -let declare_sideff env fix_exn se = - let cbl, scheme = match se with - | SEsubproof (c, cb, pt) -> [c, cb, pt], None - | SEscheme (cbl, k) -> - List.map (fun (_,c,cb,pt) -> c,cb,pt) cbl, Some (cbl,k) in - let id_of c = Names.Label.to_id (Names.Constant.label c) in - let pt_opaque_of cb pt = - match cb, pt with - | { const_body = Def sc }, _ -> (Mod_subst.force_constr sc, Univ.ContextSet.empty), false - | { const_body = OpaqueDef _ }, `Opaque(pt,univ) -> (pt, univ), true - | _ -> assert false - in - let ty_of cb = - match cb.Declarations.const_type with - | Declarations.RegularArity t -> Some t - | Declarations.TemplateArity _ -> None in - let cst_of cb pt = - let pt, opaque = pt_opaque_of cb pt in - let univs, subst = - if cb.const_polymorphic then - let univs = Univ.instantiate_univ_context cb.const_universes in - univs, Vars.subst_instance_constr (Univ.UContext.instance univs) - else cb.const_universes, fun x -> x - in - let pt = (subst (fst pt), snd pt) in - let ty = Option.map subst (ty_of cb) in - { cst_decl = ConstantEntry (DefinitionEntry { - const_entry_body = Future.from_here ~fix_exn (pt, Declareops.no_seff); - const_entry_secctx = Some cb.Declarations.const_hyps; - const_entry_type = ty; - const_entry_opaque = opaque; - const_entry_inline_code = false; - const_entry_feedback = None; - const_entry_polymorphic = cb.const_polymorphic; - const_entry_universes = univs; - }); - cst_hyps = [] ; - cst_kind = Decl_kinds.IsDefinition Decl_kinds.Definition; - cst_locl = true; - } in - let exists c = - try ignore(Environ.lookup_constant c env); true - with Not_found -> false in - let knl = - CList.map_filter (fun (c,cb,pt) -> - if exists c then None - else Some (c,declare_constant_common (id_of c) (cst_of cb pt))) cbl in - match scheme with - | None -> () - | Some (inds_consts,kind) -> - !declare_scheme kind (Array.of_list - (List.map (fun (c,kn) -> - CList.find_map (fun (x,c',_,_) -> - if Constant.equal c c' then Some (x,kn) else None) inds_consts) - knl)) - let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = - let cd = (* We deal with side effects *) + let export = (* We deal with side effects *) match cd with - | Entries.DefinitionEntry de -> - if export_seff || - not de.const_entry_opaque || - de.const_entry_polymorphic then + | DefinitionEntry de when + export_seff || + not de.const_entry_opaque || + de.const_entry_polymorphic -> let bo = de.const_entry_body in let _, seff = Future.force bo in - if Declareops.side_effects_is_empty seff then cd - else begin - let seff = Declareops.uniquize_side_effects seff in - Declareops.iter_side_effects - (declare_sideff (Global.env ()) (Future.fix_exn_of bo)) seff; - Entries.DefinitionEntry { de with - const_entry_body = Future.chain ~pure:true bo (fun (pt, _) -> - pt, Declareops.no_seff) } - end - else cd - | _ -> cd + Safe_typing.empty_private_constants <> seff + | _ -> false in let cst = { - cst_decl = ConstantEntry cd; + cst_decl = ConstantEntry (export,cd); cst_hyps = [] ; cst_kind = kind; cst_locl = local; + cst_exported = []; + cst_was_seff = false; } in let kn = declare_constant_common id cst in kn diff --git a/library/declare.mli b/library/declare.mli index 7ed451c3f1..fdbd235614 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -22,7 +22,7 @@ open Decl_kinds (** Declaration of local constructions (Variable/Hypothesis/Local) *) type section_variable_entry = - | SectionLocalDef of definition_entry + | SectionLocalDef of Safe_typing.private_constants definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -32,7 +32,7 @@ val declare_variable : variable -> variable_declaration -> object_name (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) -type constant_declaration = constant_entry * logical_kind +type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind (** [declare_constant id cd] declares a global declaration (constant/parameter) with name [id] in the current section; it returns @@ -49,8 +49,8 @@ type internal_flag = (* Defaut definition entries, transparent with no secctx or proj information *) val definition_entry : ?opaque:bool -> ?inline:bool -> ?types:types -> - ?poly:polymorphic -> ?univs:Univ.universe_context -> ?eff:Declareops.side_effects -> - constr -> definition_entry + ?poly:polymorphic -> ?univs:Univ.universe_context -> + ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> constant @@ -60,7 +60,7 @@ val declare_definition : ?local:bool -> ?poly:polymorphic -> Id.t -> ?types:constr -> constr Univ.in_universe_context_set -> constant -(** Since transparent constant's side effects are globally declared, we +(** Since transparent constants' side effects are globally declared, we * need that *) val set_declare_scheme : (string -> (inductive * constant) array -> unit) -> unit diff --git a/library/global.mli b/library/global.mli index ac231f7fd8..03469bea41 100644 --- a/library/global.mli +++ b/library/global.mli @@ -31,10 +31,11 @@ val set_engagement : Declarations.engagement -> unit (** Variables, Local definitions, constants, inductive types *) val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit -val push_named_def : (Id.t * Entries.definition_entry) -> Univ.universe_context_set +val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.universe_context_set val add_constant : - DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant + DirPath.t -> Id.t -> Safe_typing.global_declaration -> + constant * Safe_typing.exported_private_constant list val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive diff --git a/library/heads.ml b/library/heads.ml index 5c153b0676..73d2aa053f 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -68,7 +68,10 @@ let kind_of_head env t = | None -> NotImmediatelyComputableHead) | Const (cst,_) -> (try on_subterm k l b (constant_head cst) - with Not_found -> assert false) + with Not_found -> + Errors.anomaly + Pp.(str "constant not found in kind_of_head: " ++ + str (Names.Constant.to_string cst))) | Construct _ | CoFix _ -> if b then NotImmediatelyComputableHead else ConstructorHead | Sort _ | Ind _ | Prod _ -> RigidHead RigidType diff --git a/library/libobject.ml b/library/libobject.ml index 2ee57baf9c..85c830ea2c 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -108,6 +108,9 @@ let declare_object_full odecl = let declare_object odecl = try fst (declare_object_full odecl) with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e) +let declare_object_full odecl = + try declare_object_full odecl + with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e) let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index c232ae31ad..d6c29283f1 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let map_const_entry_body (f:Term.constr->Term.constr) (x:Entries.const_entry_body) - : Entries.const_entry_body = +let map_const_entry_body (f:Term.constr->Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body) + : Safe_typing.private_constants Entries.const_entry_body = Future.chain ~pure:true x begin fun ((b,ctx),fx) -> (f b , ctx) , fx end diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 9e27ddf2e9..c439323243 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -334,7 +334,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) ignore( Declare.declare_constant name - (Entries.DefinitionEntry ce, + (DefinitionEntry ce, Decl_kinds.IsDefinition (Decl_kinds.Scheme)) ); Declare.definition_message name; @@ -447,7 +447,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entry list = +let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_constants definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in @@ -541,7 +541,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr let sorts = Array.of_list sorts in List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in + let first_princ_body,first_princ_type = const.const_entry_body, const.const_entry_type in let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = destFix fix in let other_result = @@ -585,9 +585,9 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt in {const with - Entries.const_entry_body = - (Future.from_val (Term_typing.mk_pure_proof princ_body)); - Entries.const_entry_type = Some scheme_type + const_entry_body = + (Future.from_val (Safe_typing.mk_pure_proof princ_body)); + const_entry_type = Some scheme_type } ) other_fun_princ_types @@ -620,7 +620,7 @@ let build_scheme fas = ignore (Declare.declare_constant princ_id - (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); + (DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); Declare.definition_message princ_id ) fas diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index f6e5578d2e..bc082f0730 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -1,3 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* sorts array -> exception No_graph_found val make_scheme : Evd.evar_map ref -> - (pconstant*glob_sort) list -> Entries.definition_entry list + (pconstant*glob_sort) list -> Safe_typing.private_constants Entries.definition_entry list val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 35bd1c36da..aa47e26192 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -149,7 +149,7 @@ let get_locality = function | Global -> false let save with_clean id const (locality,_,kind) hook = - let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in + let fix_exn = Future.fix_exn_of const.const_entry_body in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let k = Kindops.logical_kind_of_goal_kind kind in diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 10daf6e848..23f1da1ba7 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -46,7 +46,7 @@ val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr -val save : bool -> Id.t -> Entries.definition_entry -> Decl_kinds.goal_kind -> +val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> unit Lemmas.declaration_hook Ephemeron.key -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and @@ -54,7 +54,7 @@ val save : bool -> Id.t -> Entries.definition_entry -> Decl_kinds.goal_kind -> *) val get_proof_clean : bool -> Names.Id.t * - (Entries.definition_entry * Decl_kinds.goal_kind) + (Safe_typing.private_constants Entries.definition_entry * Decl_kinds.goal_kind) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 1107c2951e..0593bbca8a 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -579,7 +579,7 @@ type evar_map = { (** Metas *) metas : clbinding Metamap.t; (** Interactive proofs *) - effects : Declareops.side_effects; + effects : Safe_typing.private_constants; future_goals : Evar.t list; (** list of newly created evars, to be eventually turned into goals if not solved.*) principal_future_goal : Evar.t option; (** if [Some e], [e] must be @@ -768,7 +768,7 @@ let empty = { conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; - effects = Declareops.no_seff; + effects = Safe_typing.empty_private_constants; evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; @@ -1041,22 +1041,8 @@ let with_context_set rigid d (a, ctx) = (merge_context_set rigid d ctx, a) let emit_universe_side_effects eff u = - Declareops.fold_side_effects - (fun acc eff -> - match eff with - | Declarations.SEscheme (l,s) -> - List.fold_left - (fun acc (_,_,cb,c) -> - let acc = match c with - | `Nothing -> acc - | `Opaque (s, ctx) -> merge_uctx true univ_rigid acc ctx - in if cb.Declarations.const_polymorphic then acc - else - merge_uctx true univ_rigid acc - (Univ.ContextSet.of_context cb.Declarations.const_universes)) - acc l - | Declarations.SEsubproof _ -> acc) - u eff + let uctxs = Safe_typing.universes_of_private eff in + List.fold_left (merge_uctx true univ_rigid) u uctxs let add_uctx_names s l (names, names_rev) = (UNameMap.add s l names, Univ.LMap.add l s names_rev) @@ -1399,11 +1385,11 @@ let e_eq_constr_univs evdref t u = (* Side effects *) let emit_side_effects eff evd = - { evd with effects = Declareops.union_side_effects eff evd.effects; + { evd with effects = Safe_typing.concat_private eff evd.effects; universes = emit_universe_side_effects eff evd.universes } let drop_side_effects evd = - { evd with effects = Declareops.no_seff; } + { evd with effects = Safe_typing.empty_private_constants; } let eval_side_effects evd = evd.effects diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 52d7d42120..9379b50b52 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -261,10 +261,10 @@ val dependent_evar_ident : existential_key -> evar_map -> Id.t (** {5 Side-effects} *) -val emit_side_effects : Declareops.side_effects -> evar_map -> evar_map +val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map (** Push a side-effect into the evar map. *) -val eval_side_effects : evar_map -> Declareops.side_effects +val eval_side_effects : evar_map -> Safe_typing.private_constants (** Return the effects contained in the evar map. *) val drop_side_effects : evar_map -> evar_map diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 00ef8ecafd..02dbd1fdcb 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -150,10 +150,14 @@ let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = let sign = val_of_named_context (named_context env) in let gk = Global, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in - let ce = if side_eff then Term_typing.handle_entry_side_effects env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun (pt, _) -> pt, Declareops.no_seff) } in + let ce = + if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce + else { ce with + const_entry_body = Future.chain ~pure:true ce.const_entry_body + (fun (pt, _) -> pt, Safe_typing.empty_private_constants) } in let (cb, ctx), se = Future.force ce.const_entry_body in let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in - assert(Declareops.side_effects_is_empty se); + assert(Safe_typing.empty_private_constants = se); cb, status, Evd.evar_universe_context univs' let refine_by_tactic env sigma ty tac = @@ -188,7 +192,7 @@ let refine_by_tactic env sigma ty tac = other goals that were already present during its invocation, so that those goals rely on effects that are not present anymore. Hopefully, this hack will work in most cases. *) - let ans = Term_typing.handle_side_effects env ans neff in + let ans = Safe_typing.inline_private_constants_in_constr env ans neff in ans, sigma (**********************************************************************) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index b1fba132d9..fc521ea432 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -69,11 +69,11 @@ val start_proof : val cook_this_proof : Proof_global.proof_object -> (Id.t * - (Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) val cook_proof : unit -> (Id.t * - (Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) (** {6 ... } *) (** [get_pftreestate ()] returns the current focused pending proof. @@ -152,7 +152,7 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit val build_constant_by_tactic : Id.t -> Evd.evar_universe_context -> named_context_val -> ?goal_kind:goal_kind -> types -> unit Proofview.tactic -> - Entries.definition_entry * bool * Evd.evar_universe_context + Safe_typing.private_constants Entries.definition_entry * bool * Evd.evar_universe_context val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index a0ead42ef3..809ed41c7e 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -67,7 +67,7 @@ type proof_universes = Evd.evar_universe_context type proof_object = { id : Names.Id.t; - entries : Entries.definition_entry list; + entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; (* constraints : Univ.constraints; *) @@ -315,13 +315,14 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let open Universes in let body = c in let typ = - if not (keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff)) then + if not (keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff)) then nf t else t in let used_univs_body = Universes.universes_of_constr body in let used_univs_typ = Universes.universes_of_constr typ in - if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then + if keep_body_ucst_separate || + not (Safe_typing.empty_private_constants = eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in let ctx = Evd.evar_universe_context_set initunivs universes in (* For vi2vo compilation proofs are computed now but we need to @@ -365,7 +366,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = { id = pid; entries = entries; persistence = strength; universes = universes }, fun pr_ending -> Ephemeron.get terminator pr_ending -type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index fcb706cc8d..f8615e8499 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -58,7 +58,7 @@ type lemma_possible_guards = int list list type proof_universes = Evd.evar_universe_context type proof_object = { id : Names.Id.t; - entries : Entries.definition_entry list; + entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; (* constraints : Univ.constraints; *) @@ -97,7 +97,7 @@ val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof * Both access the current proof state. The former is supposed to be * chained with a computation that completed the proof *) -type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 5a9e7f39f0..927df33a0c 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -336,7 +336,7 @@ val tclENV : Environ.env tactic (** {7 Put-like primitives} *) (** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Declareops.side_effects -> unit tactic +val tclEFFECTS : Safe_typing.private_constants -> unit tactic (** [mark_as_unsafe] declares the current tactic is unsafe. *) val mark_as_unsafe : unit tactic diff --git a/stm/lemmas.ml b/stm/lemmas.ml index c49ddfd8ec..6c18326882 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -70,11 +70,12 @@ let adjust_guardness_conditions const = function try ignore(Environ.lookup_constant c e); true with Not_found -> false in if exists c e then e else Environ.add_constant c cb e in - let env = Declareops.fold_side_effects (fun env -> function + let env = List.fold_left (fun env { eff } -> + match eff with | SEsubproof (c, cb,_) -> add c cb env | SEscheme (l,_) -> List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l) - env (Declareops.uniquize_side_effects eff) in + env (Safe_typing.side_effects_of_private_constants eff) in let indexes = search_guard Loc.ghost env possible_indexes fixdecls in diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index e6a8cbe3ad..8a6d93cf7c 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -52,7 +52,7 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = let ctxset = Univ.ContextSet.of_context ctx in let ectx = Evd.evar_universe_context_of ctxset in let sigma, c = build_induction_scheme env (Evd.from_ctx ectx) (ind,u) dep sort in - (c, Evd.evar_universe_context sigma), Declareops.no_seff + (c, Evd.evar_universe_context sigma), Safe_typing.empty_private_constants let build_induction_scheme_in_type dep sort ind = let env = Global.env () in @@ -68,15 +68,15 @@ let build_induction_scheme_in_type dep sort ind = let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" - (fun _ x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" - (fun _ x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" - (fun _ x -> build_induction_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" @@ -109,24 +109,24 @@ let build_case_analysis_scheme_in_type dep sort ind = let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index f7d3ad5d0a..b2603315d5 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -193,7 +193,7 @@ let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" (fun _ ind -> let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in - (c, ctx), Declareops.no_seff) + (c, ctx), Safe_typing.empty_private_constants) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -412,7 +412,8 @@ let build_l2r_rew_scheme dep env ind kind = [|main_body|]) else main_body)))))) - in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff + in (c, Evd.evar_universe_context_of ctx), + Safe_typing.concat_private eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -660,7 +661,7 @@ let rew_l2r_dep_scheme_kind = (**********************************************************************) let rew_r2l_dep_scheme_kind = declare_individual_scheme_object "_rew_dep" - (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) (**********************************************************************) (* Dependent rewrite from right-to-left in hypotheses *) @@ -670,7 +671,7 @@ let rew_r2l_dep_scheme_kind = (**********************************************************************) let rew_r2l_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_dep" - (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) (**********************************************************************) (* Dependent rewrite from left-to-right in hypotheses *) @@ -680,7 +681,7 @@ let rew_r2l_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_r_dep" - (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) @@ -694,7 +695,7 @@ let rew_l2r_forward_dep_scheme_kind = let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" (fun _ ind -> fix_r2l_forward_rew_scheme - (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Declareops.no_seff) + (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Safe_typing.empty_private_constants) (**********************************************************************) (* Non-dependent rewrite from either right-to-left in conclusion or *) @@ -704,7 +705,7 @@ let rew_l2r_scheme_kind = (**********************************************************************) let rew_r2l_scheme_kind = declare_individual_scheme_object "_rew" - (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Declareops.no_seff) + (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Safe_typing.empty_private_constants) (* End of rewriting schemes *) @@ -782,4 +783,4 @@ let build_congr env (eq,refl,ctx) ind = let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun _ ind -> (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Safe_typing.empty_private_constants) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 6bb84808a9..3fe3307308 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -25,7 +25,7 @@ val rew_r2l_scheme_kind : individual scheme_kind val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> - constr Evd.in_evar_universe_context * Declareops.side_effects + constr Evd.in_evar_universe_context * Safe_typing.private_constants val build_r2l_forward_rew_scheme : bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : @@ -37,7 +37,7 @@ val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind val build_sym_involutive_scheme : env -> inductive -> - constr Evd.in_evar_universe_context * Declareops.side_effects + constr Evd.in_evar_universe_context * Safe_typing.private_constants val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) diff --git a/tactics/equality.ml b/tactics/equality.ml index bc711b81ef..674c85af79 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -317,7 +317,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = assert false in let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in - sigma, elim, Declareops.no_seff + sigma, elim, Safe_typing.empty_private_constants else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 1437b24625..0b920066fd 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4455,9 +4455,9 @@ let abstract_subproof id gk tac = (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in let evd = Evd.set_universe_context evd ectx in - let open Declareops in - let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in - let effs = cons_side_effects eff + let open Safe_typing in + let eff = private_con_of_con (Global.safe_env ()) cst in + let effs = add_private eff Entries.(snd (Future.force const.const_entry_body)) in let args = List.rev (instance_from_named_context sign) in let solve = diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 8ac273c84f..7a89b9f54e 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -179,12 +179,12 @@ let build_beq_scheme mode kn = let rec aux c = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in match kind_of_term c with - | Rel x -> mkRel (x-nlist+ndx), Declareops.no_seff - | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Declareops.no_seff + | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants + | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Safe_typing.empty_private_constants | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Declareops.no_seff + if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants else begin try let eq, eff = @@ -193,9 +193,8 @@ let build_beq_scheme mode kn = let eqa, eff = let eqa, effs = List.split (List.map aux a) in Array.of_list eqa, - Declareops.union_side_effects - (Declareops.flatten_side_effects (List.rev effs)) - eff in + List.fold_left Safe_typing.concat_private eff (List.rev effs) + in let args = Array.append (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in @@ -238,7 +237,7 @@ let build_beq_scheme mode kn = let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in let ar = Array.make n (Lazy.force ff) in - let eff = ref Declareops.no_seff in + let eff = ref Safe_typing.empty_private_constants in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.make n (Lazy.force ff) in @@ -256,7 +255,7 @@ let build_beq_scheme mode kn = (nb_cstr_args+ndx+1) cc in - eff := Declareops.union_side_effects eff' !eff; + eff := Safe_typing.concat_private eff' !eff; Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] @@ -288,7 +287,7 @@ let build_beq_scheme mode kn = let names = Array.make nb_ind Anonymous and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in - let eff = ref Declareops.no_seff in + let eff = ref Safe_typing.empty_private_constants in let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do names.(i) <- Name (Id.of_string (rec_name i)); @@ -296,7 +295,7 @@ let build_beq_scheme mode kn = (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb)); let c, eff' = make_one_eq i in cores.(i) <- c; - eff := Declareops.union_side_effects eff' !eff + eff := Safe_typing.concat_private eff' !eff done; (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in @@ -875,7 +874,7 @@ let compute_dec_tact ind lnamesparrec nparrec = Not_found -> Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.") end >>= fun (lbI,eff'') -> - let eff = (Declareops.union_side_effects eff'' (Declareops.union_side_effects eff' eff)) in + let eff = (Safe_typing.concat_private eff'' (Safe_typing.concat_private eff' eff)) in Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; intros_using fresh_first_intros; @@ -942,7 +941,7 @@ let make_eq_decidability mode mind = (compute_dec_goal (ind,u) lnamesparrec nparrec) (compute_dec_tact ind lnamesparrec nparrec) in - ([|ans|], ctx), Declareops.no_seff + ([|ans|], ctx), Safe_typing.empty_private_constants let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 805a29e396..e750f0ca26 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -187,7 +187,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro Evarutil.check_evars env Evd.empty !evars termtype; let ctx = Evd.universe_context !evars in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id - (Entries.ParameterEntry + (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in instance_hook k None global imps ?hook (ConstRef cst); id end diff --git a/toplevel/command.ml b/toplevel/command.ml index d75efeca1e..433ef4dccd 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -169,7 +169,7 @@ let declare_definition ident (local, p, k) ce imps hook = gr | Discharge | Local | Global -> declare_global_definition ident ce local k imps in - Lemmas.call_hook (Future.fix_exn_of ce.Entries.const_entry_body) hook local r + Lemmas.call_hook (Future.fix_exn_of ce.const_entry_body) hook local r let _ = Obligations.declare_definition_ref := declare_definition @@ -178,7 +178,7 @@ let do_definition ident k pl bl red_option c ctypopt hook = if Flags.is_program_mode () then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in - assert(Declareops.side_effects_is_empty sideff); + assert(Safe_typing.empty_private_constants = sideff); assert(Univ.ContextSet.is_empty ctx); let typ = match ce.const_entry_type with | Some t -> t @@ -1139,7 +1139,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in - let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in let ctx = Evd.universe_context ?names:pl evd in ignore (List.map4 (declare_fix (local, poly, Fixpoint) ctx) fixnames fixdecls fixtypes fiximps); @@ -1169,7 +1169,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let vars = Universes.universes_of_constr (List.hd fixdecls) in - let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in diff --git a/toplevel/command.mli b/toplevel/command.mli index 94b4af9dd9..a031677b47 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -26,17 +26,17 @@ val do_constraint : polymorphic -> (** {6 Hooks for Pcoq} *) -val set_declare_definition_hook : (definition_entry -> unit) -> unit -val get_declare_definition_hook : unit -> (definition_entry -> unit) +val set_declare_definition_hook : (Safe_typing.private_constants definition_entry -> unit) -> unit +val get_declare_definition_hook : unit -> (Safe_typing.private_constants definition_entry -> unit) (** {6 Definitions/Let} *) val interp_definition : lident list option -> local_binder list -> polymorphic -> red_expr option -> constr_expr -> - constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits + constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * Impargs.manual_implicits val declare_definition : Id.t -> definition_kind -> - definition_entry -> Impargs.manual_implicits -> + Safe_typing.private_constants definition_entry -> Impargs.manual_implicits -> Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference val do_definition : Id.t -> definition_kind -> lident list option -> @@ -170,4 +170,4 @@ val do_cofixpoint : val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit val declare_fix : ?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> - Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference + Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 7d5d61fb8b..b6da21e5ae 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -20,8 +20,8 @@ open Cooking (* Discharging mutual inductive *) let detype_param = function - | (Name id,None,p) -> id, Entries.LocalAssum p - | (Name id,Some p,_) -> id, Entries.LocalDef p + | (Name id,None,p) -> id, LocalAssum p + | (Name id,Some p,_) -> id, LocalDef p | (Anonymous,_,_) -> anomaly (Pp.str "Unnamed inductive local variable") (* Replace diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 218c47b28d..dde801a7fb 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -29,9 +29,9 @@ open Pp (* Registering schemes in the environment *) type mutual_scheme_object_function = - internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants type 'a scheme_kind = string @@ -124,7 +124,9 @@ let define internal id c p univs = let c = Vars.subst_univs_fn_constr (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in let entry = { - const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), Declareops.no_seff); + const_entry_body = + Future.from_val ((c,Univ.ContextSet.empty), + Safe_typing.empty_private_constants); const_entry_secctx = None; const_entry_type = None; const_entry_polymorphic = p; @@ -148,8 +150,8 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = | None -> add_suffix mib.mind_packets.(i).mind_typename suff in let const = define mode id c mib.mind_polymorphic ctx in declare_scheme kind [|ind,const|]; - const, Declareops.cons_side_effects - (Safe_typing.sideff_of_scheme kind (Global.safe_env()) [ind,const]) eff + const, Safe_typing.add_private + (Safe_typing.private_con_of_scheme kind (Global.safe_env()) [ind,const]) eff let define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with @@ -168,8 +170,8 @@ let define_mutual_scheme_base kind suff f mode names mind = let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; consts, - Declareops.cons_side_effects - (Safe_typing.sideff_of_scheme + Safe_typing.add_private + (Safe_typing.private_con_of_scheme kind (Global.safe_env()) (Array.to_list schemes)) eff @@ -181,10 +183,10 @@ let define_mutual_scheme kind mode names mind = let find_scheme_on_env_too kind ind = let s = String.Map.find kind (Indmap.find ind !scheme_map) in - s, Declareops.cons_side_effects - (Safe_typing.sideff_of_scheme + s, Safe_typing.add_private + (Safe_typing.private_con_of_scheme kind (Global.safe_env()) [ind, s]) - Declareops.no_seff + Safe_typing.empty_private_constants let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = try find_scheme_on_env_too kind ind diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index d0844dd946..abd951c313 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -20,9 +20,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants (** Main functions to register a scheme builder *) @@ -37,13 +37,13 @@ val declare_individual_scheme_object : string -> ?aux:string -> val define_individual_scheme : individual scheme_kind -> internal_flag (** internal *) -> - Id.t option -> inductive -> constant * Declareops.side_effects + Id.t option -> inductive -> constant * Safe_typing.private_constants val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> - (int * Id.t) list -> mutual_inductive -> constant array * Declareops.side_effects + (int * Id.t) list -> mutual_inductive -> constant array * Safe_typing.private_constants (** Main function to retrieve a scheme in the cache or to generate it *) -val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> constant * Declareops.side_effects +val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> constant * Safe_typing.private_constants val check_scheme : 'a scheme_kind -> inductive -> bool diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index ae8ee7670a..0b021254e2 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -371,7 +371,7 @@ let do_mutual_induction_scheme lnamedepindsort = let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma decl in (* let decltype = refresh_universes decltype in *) - let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Declareops.no_seff) in + let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in let cst = define fi UserIndividualRequest sigma proof_output (Some decltype) in ConstRef cst :: lrecref in @@ -469,7 +469,7 @@ let do_combined_scheme name schemes = schemes in let body,typ = build_combined_scheme (Global.env ()) csts in - let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Declareops.no_seff) in + let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ)); fixpoint_message None [snd name] diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 665926922f..e488f84f8a 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -541,7 +541,7 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx -let mk_proof c = ((c, Univ.ContextSet.empty), Declareops.no_seff) +let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants) let declare_mutual_definition l = let len = List.length l in @@ -619,7 +619,7 @@ let declare_obligation prg obl body ty uctx = shrink_body body else [], body, [||] in let ce = - { const_entry_body = Future.from_val((body,Univ.ContextSet.empty),Declareops.no_seff); + { const_entry_body = Future.from_val((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants); const_entry_secctx = None; const_entry_type = if List.is_empty ctx then ty else None; const_entry_polymorphic = poly; @@ -796,12 +796,12 @@ let solve_by_tac name evi t poly ctx = let (entry,_,ctx') = Pfedit.build_constant_by_tactic id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps concl (Tacticals.New.tclCOMPLETE t) in let env = Global.env () in - let entry = Term_typing.handle_entry_side_effects env entry in - let body, eff = Future.force entry.Entries.const_entry_body in - assert(Declareops.side_effects_is_empty eff); + let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in + let body, eff = Future.force entry.const_entry_body in + assert(Safe_typing.empty_private_constants = eff); let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard (Global.env ()) (fst body); - (fst body), entry.Entries.const_entry_type, Evd.evar_universe_context ctx' + (fst body), entry.const_entry_type, Evd.evar_universe_context ctx' let obligation_hook prg obl num auto ctx' _ gr = let obls, rem = prg.prg_obligations in diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 40f124ca36..61a8ee520f 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -17,11 +17,11 @@ open Decl_kinds (** Forward declaration. *) val declare_fix_ref : (?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> - Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref + Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref val declare_definition_ref : (Id.t -> definition_kind -> - Entries.definition_entry -> Impargs.manual_implicits + Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits -> global_reference Lemmas.declaration_hook -> global_reference) ref val check_evars : env -> evar_map -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 60fe76bb82..b1be4c92a6 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -160,8 +160,8 @@ let degenerate_decl (na,b,t) = | Name id -> id | Anonymous -> anomaly (Pp.str "Unnamed record variable") in match b with - | None -> (id, Entries.LocalAssum t) - | Some b -> (id, Entries.LocalDef b) + | None -> (id, LocalAssum t) + | Some b -> (id, LocalDef b) type record_error = | MissingProj of Id.t * Id.t list @@ -297,7 +297,7 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field try let entry = { const_entry_body = - Future.from_val (Term_typing.mk_pure_proof proj); + Future.from_val (Safe_typing.mk_pure_proof proj); const_entry_secctx = None; const_entry_type = Some projtyp; const_entry_polymorphic = poly; -- cgit v1.2.3 From 89be9efbf6dbd8a04fb8ccab4c9aa7a11b9a0f03 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 28 Oct 2015 11:16:47 -0400 Subject: Printing of @{} instances for polymorphic references in Print and About. --- printing/prettyp.ml | 14 +++++++++++--- printing/printer.ml | 4 ++++ printing/printer.mli | 1 + printing/printmod.ml | 6 +++++- 4 files changed, 21 insertions(+), 4 deletions(-) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index b8c5fd4cfc..7e625af0de 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -73,7 +73,11 @@ let print_ref reduce ref = in it_mkProd_or_LetIn ccl ctx else typ in let univs = Global.universes_of_global ref in - hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ ++ + let inst = + if Global.is_polymorphic ref then Printer.pr_universe_instance univs + else mt () + in + hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_ltype typ ++ Printer.pr_universe_ctx univs) (********************************) @@ -473,6 +477,10 @@ let print_typed_body (val_0,typ) = let ungeneralized_type_of_constant_type t = Typeops.type_of_constant_type (Global.env ()) t +let print_instance cb = + if cb.const_polymorphic then pr_universe_instance cb.const_universes + else mt() + let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in @@ -485,11 +493,11 @@ let print_constant with_values sep sp = match val_0 with | None -> str"*** [ " ++ - print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ + print_basename sp ++ print_instance cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ Printer.pr_universe_ctx univs | _ -> - print_basename sp ++ str sep ++ cut () ++ + print_basename sp ++ print_instance cb ++ str sep ++ cut () ++ (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)++ Printer.pr_universe_ctx univs) diff --git a/printing/printer.ml b/printing/printer.ml index 18e4902255..f4852b1089 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -825,3 +825,7 @@ let pr_polymorphic b = if b then str"Polymorphic " else str"Monomorphic " else mt () +let pr_universe_instance ctx = + let inst = Univ.UContext.instance ctx in + str"@{" ++ Univ.Instance.pr Univ.Level.pr inst ++ str"}" + diff --git a/printing/printer.mli b/printing/printer.mli index 5f56adbe6f..25a4aa166b 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -84,6 +84,7 @@ val pr_sort : evar_map -> sorts -> std_ppcmds (** Universe constraints *) val pr_polymorphic : bool -> std_ppcmds +val pr_universe_instance : Univ.universe_context -> std_ppcmds val pr_universe_ctx : Univ.universe_context -> std_ppcmds (** Printing global references using names as short as possible *) diff --git a/printing/printmod.ml b/printing/printmod.ml index 53d0508c7f..8031de27d4 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -94,8 +94,12 @@ let print_one_inductive env mib ((_,i) as ind) = let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in let envpar = push_rel_context params env in + let inst = + if mib.mind_polymorphic then Printer.pr_universe_instance mib.mind_universes + else mt () + in hov 0 ( - pr_id mip.mind_typename ++ brk(1,4) ++ print_params env Evd.empty params ++ + pr_id mip.mind_typename ++ inst ++ brk(1,4) ++ print_params env Evd.empty params ++ str ": " ++ Printer.pr_lconstr_env envpar Evd.empty arity ++ str " :=") ++ brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes -- cgit v1.2.3 From 0132b5b51fc1856356fb74130d3dea7fd378f76c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 28 Oct 2015 12:36:20 -0400 Subject: Univs: local names handling. Keep user-side information on the names used in instances of universe polymorphic references and use them for printing. --- library/universes.ml | 16 +++++ library/universes.mli | 10 ++- plugins/funind/functional_principles_types.ml | 2 +- plugins/funind/merge.ml | 4 +- plugins/funind/recdef.ml | 2 +- plugins/setoid_ring/newring.ml4 | 2 +- pretyping/evd.ml | 30 ++++++--- pretyping/evd.mli | 6 +- printing/prettyp.ml | 38 +++++++----- printing/printer.ml | 8 +-- printing/printer.mli | 4 +- printing/printmod.ml | 38 +++++++----- tactics/leminv.ml | 3 +- tactics/rewrite.ml | 4 +- toplevel/class.ml | 2 +- toplevel/classes.ml | 4 +- toplevel/command.ml | 89 +++++++++++++++------------ toplevel/command.mli | 13 ++-- toplevel/indschemes.ml | 2 +- toplevel/record.ml | 11 ++-- toplevel/vernacentries.ml | 4 +- 21 files changed, 180 insertions(+), 112 deletions(-) diff --git a/library/universes.ml b/library/universes.ml index 30d38eb2a4..6cccb10efb 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -12,7 +12,9 @@ open Names open Term open Environ open Univ +open Globnames +(** Global universe names *) type universe_names = Univ.universe_level Idmap.t * Id.t Univ.LMap.t @@ -27,6 +29,20 @@ let pr_with_global_universes l = try Nameops.pr_id (LMap.find l (snd !global_universes)) with Not_found -> Level.pr l +(** Local universe names of polymorphic references *) + +type universe_binders = (Id.t * Univ.universe_level) list + +let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" + +let universe_binders_of_global ref = + try + let l = Refmap.find ref !universe_binders_table in l + with Not_found -> [] + +let register_universe_binders ref l = + universe_binders_table := Refmap.add ref l !universe_binders_table + (* To disallow minimization to Set *) let set_minimization = ref true diff --git a/library/universes.mli b/library/universes.mli index 4ff21d45c9..45672ef460 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -14,9 +14,10 @@ open Univ val set_minimization : bool ref val is_set_minimization : unit -> bool - + (** Universes *) +(** Global universe name <-> level mapping *) type universe_names = Univ.universe_level Idmap.t * Id.t Univ.LMap.t @@ -25,6 +26,13 @@ val set_global_universe_names : universe_names -> unit val pr_with_global_universes : Level.t -> Pp.std_ppcmds +(** Local universe name <-> level mapping *) + +type universe_binders = (Id.t * Univ.universe_level) list + +val register_universe_binders : Globnames.global_reference -> universe_binders -> unit +val universe_binders_of_global : Globnames.global_reference -> universe_binders + (** The global universe counter *) val set_remote_new_univ_level : universe_level RemoteCounter.installer diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index c439323243..c47602bda0 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -330,7 +330,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) let evd',value = change_property_sort evd' s new_principle_type new_princ_name in let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(Evd.universe_context evd') value in + let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in ignore( Declare.declare_constant name diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 60c58730a3..e3455e7702 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -884,10 +884,10 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,impls = Command.interp_mutual_inductive indl [] + let mie,pl,impls = Command.interp_mutual_inductive indl [] false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) - ignore (Command.declare_mutual_inductive_with_eliminations mie impls) + ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls) (* Find infos on identifier id. *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index ca0b9c5feb..5d41ec7237 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1509,7 +1509,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(Evd.universe_context evm) res in + let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = fst (*FIXME*)(interp_constr diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 1c4ba88237..c7185ff25e 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -220,7 +220,7 @@ let exec_tactic env evd n f args = let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in - Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd + Array.map (fun x -> nf (constr_of x)) !res, snd (Evd.universe_context evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 0593bbca8a..36d9c25fdd 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -356,6 +356,16 @@ let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_loca let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx } let evar_universe_context_subst ctx = ctx.uctx_univ_variables +let add_uctx_names s l (names, names_rev) = + (UNameMap.add s l names, Univ.LMap.add l s names_rev) + +let evar_universe_context_of_binders b = + let ctx = empty_evar_universe_context in + let names = + List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc) + ctx.uctx_names b + in { ctx with uctx_names = names } + let instantiate_variable l b v = v := Univ.LMap.add l (Some b) !v @@ -965,19 +975,19 @@ let pr_uctx_level uctx = let universe_context ?names evd = match names with - | None -> Univ.ContextSet.to_context evd.universes.uctx_local + | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local | Some pl -> let levels = Univ.ContextSet.levels evd.universes.uctx_local in - let newinst, left = + let newinst, map, left = List.fold_right - (fun (loc,id) (newinst, acc) -> + (fun (loc,id) (newinst, map, acc) -> let l = try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names) with Not_found -> user_err_loc (loc, "universe_context", str"Universe " ++ pr_id id ++ str" is not bound anymore.") - in (l :: newinst, Univ.LSet.remove l acc)) - pl ([], levels) + in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) + pl ([], [], levels) in if not (Univ.LSet.is_empty left) then let n = Univ.LSet.cardinal left in @@ -985,8 +995,11 @@ let universe_context ?names evd = (str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level evd.universes) left ++ spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") - else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst), - Univ.ContextSet.constraints evd.universes.uctx_local) + else + let inst = Univ.Instance.of_array (Array.of_list newinst) in + let ctx = Univ.UContext.make (inst, + Univ.ContextSet.constraints evd.universes.uctx_local) + in map, ctx let restrict_universe_context evd vars = let uctx = evd.universes in @@ -1044,9 +1057,6 @@ let emit_universe_side_effects eff u = let uctxs = Safe_typing.universes_of_private eff in List.fold_left (merge_uctx true univ_rigid) u uctxs -let add_uctx_names s l (names, names_rev) = - (UNameMap.add s l names, Univ.LMap.add l s names_rev) - let uctx_new_univ_variable rigid name predicative ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = Universes.new_univ_level (Global.current_dirpath ()) in diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 9379b50b52..3c16b27ad9 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -487,6 +487,9 @@ val union_evar_universe_context : evar_universe_context -> evar_universe_context evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst +val evar_universe_context_of_binders : + Universes.universe_binders -> evar_universe_context + val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map (** Raises Not_found if not a name for a universe in this map. *) @@ -534,7 +537,8 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set -val universe_context : ?names:(Id.t located) list -> evar_map -> Univ.universe_context +val universe_context : ?names:(Id.t located) list -> evar_map -> + (Id.t * Univ.Level.t) list * Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst val universes : evar_map -> Univ.universes diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 7e625af0de..84649e6ebf 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -73,12 +73,15 @@ let print_ref reduce ref = in it_mkProd_or_LetIn ccl ctx else typ in let univs = Global.universes_of_global ref in + let env = Global.env () in + let bl = Universes.universe_binders_of_global ref in + let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in let inst = - if Global.is_polymorphic ref then Printer.pr_universe_instance univs + if Global.is_polymorphic ref then Printer.pr_universe_instance sigma univs else mt () in - hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_ltype typ ++ - Printer.pr_universe_ctx univs) + hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_ltype_env env sigma typ ++ + Printer.pr_universe_ctx sigma univs) (********************************) (** Printing implicit arguments *) @@ -467,18 +470,19 @@ let gallina_print_section_variable id = print_named_decl id ++ with_line_skip (print_name_infos (VarRef id)) -let print_body = function - | Some c -> pr_lconstr c +let print_body env evd = function + | Some c -> pr_lconstr_env env evd c | None -> (str"") -let print_typed_body (val_0,typ) = - (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ) +let print_typed_body env evd (val_0,typ) = + (print_body env evd val_0 ++ fnl () ++ str " : " ++ pr_ltype_env env evd typ) let ungeneralized_type_of_constant_type t = Typeops.type_of_constant_type (Global.env ()) t -let print_instance cb = - if cb.const_polymorphic then pr_universe_instance cb.const_universes +let print_instance sigma cb = + if cb.const_polymorphic then + pr_universe_instance sigma cb.const_universes else mt() let print_constant with_values sep sp = @@ -489,17 +493,23 @@ let print_constant with_values sep sp = let univs = Univ.instantiate_univ_context (Global.universes_of_constant_body cb) in + let ctx = + Evd.evar_universe_context_of_binders + (Universes.universe_binders_of_global (ConstRef sp)) + in + let env = Global.env () and sigma = Evd.from_ctx ctx in + let pr_ltype = pr_ltype_env env sigma in hov 0 (pr_polymorphic cb.const_polymorphic ++ match val_0 with | None -> str"*** [ " ++ - print_basename sp ++ print_instance cb ++ str " : " ++ cut () ++ pr_ltype typ ++ + print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_universe_ctx univs + Printer.pr_universe_ctx sigma univs | _ -> - print_basename sp ++ print_instance cb ++ str sep ++ cut () ++ - (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)++ - Printer.pr_universe_ctx univs) + print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ + (if with_values then print_typed_body env sigma (val_0,typ) else pr_ltype typ)++ + Printer.pr_universe_ctx sigma univs) let gallina_print_constant_with_infos sp = print_constant true " = " sp ++ diff --git a/printing/printer.ml b/printing/printer.ml index f4852b1089..202b4f2bc7 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -208,10 +208,10 @@ let safe_pr_constr t = let (sigma, env) = get_current_context () in safe_pr_constr_env env sigma t -let pr_universe_ctx c = +let pr_universe_ctx sigma c = if !Detyping.print_universes && not (Univ.UContext.is_empty c) then fnl()++pr_in_comment (fun c -> v 0 - (Univ.pr_universe_context Universes.pr_with_global_universes c)) c + (Univ.pr_universe_context (Evd.pr_evd_level sigma) c)) c else mt() @@ -825,7 +825,7 @@ let pr_polymorphic b = if b then str"Polymorphic " else str"Monomorphic " else mt () -let pr_universe_instance ctx = +let pr_universe_instance evd ctx = let inst = Univ.UContext.instance ctx in - str"@{" ++ Univ.Instance.pr Univ.Level.pr inst ++ str"}" + str"@{" ++ Univ.Instance.pr (Evd.pr_evd_level evd) inst ++ str"}" diff --git a/printing/printer.mli b/printing/printer.mli index 25a4aa166b..0a44e4f103 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -84,8 +84,8 @@ val pr_sort : evar_map -> sorts -> std_ppcmds (** Universe constraints *) val pr_polymorphic : bool -> std_ppcmds -val pr_universe_instance : Univ.universe_context -> std_ppcmds -val pr_universe_ctx : Univ.universe_context -> std_ppcmds +val pr_universe_instance : evar_map -> Univ.universe_context -> std_ppcmds +val pr_universe_ctx : evar_map -> Univ.universe_context -> std_ppcmds (** Printing global references using names as short as possible *) diff --git a/printing/printmod.ml b/printing/printmod.ml index 8031de27d4..1d275c1aa6 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -72,10 +72,10 @@ let print_params env sigma params = if List.is_empty params then mt () else Printer.pr_rel_context env sigma params ++ brk(1,2) -let print_constructors envpar names types = +let print_constructors envpar sigma names types = let pc = prlist_with_sep (fun () -> brk(1,0) ++ str "| ") - (fun (id,c) -> pr_id id ++ str " : " ++ Printer.pr_lconstr_env envpar Evd.empty c) + (fun (id,c) -> pr_id id ++ str " : " ++ Printer.pr_lconstr_env envpar sigma c) (Array.to_list (Array.map2 (fun n t -> (n,t)) names types)) in hv 0 (str " " ++ pc) @@ -83,7 +83,7 @@ let print_constructors envpar names types = let build_ind_type env mip = Inductive.type_of_inductive env mip -let print_one_inductive env mib ((_,i) as ind) = +let print_one_inductive env sigma mib ((_,i) as ind) = let u = if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes else Univ.Instance.empty in @@ -95,13 +95,14 @@ let print_one_inductive env mib ((_,i) as ind) = let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in let envpar = push_rel_context params env in let inst = - if mib.mind_polymorphic then Printer.pr_universe_instance mib.mind_universes + if mib.mind_polymorphic then + Printer.pr_universe_instance sigma mib.mind_universes else mt () in hov 0 ( - pr_id mip.mind_typename ++ inst ++ brk(1,4) ++ print_params env Evd.empty params ++ - str ": " ++ Printer.pr_lconstr_env envpar Evd.empty arity ++ str " :=") ++ - brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes + pr_id mip.mind_typename ++ inst ++ brk(1,4) ++ print_params env sigma params ++ + str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ str " :=") ++ + brk(0,2) ++ print_constructors envpar sigma mip.mind_consnames cstrtypes let print_mutual_inductive env mind mib = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) @@ -113,11 +114,13 @@ let print_mutual_inductive env mind mib = | BiFinite -> "Variant" | CoFinite -> "CoInductive" in + let bl = Universes.universe_binders_of_global (IndRef (mind, 0)) in + let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in hov 0 (Printer.pr_polymorphic mib.mind_polymorphic ++ def keyword ++ spc () ++ prlist_with_sep (fun () -> fnl () ++ str" with ") - (print_one_inductive env mib) inds ++ - Printer.pr_universe_ctx (Univ.instantiate_univ_context mib.mind_universes)) + (print_one_inductive env sigma mib) inds ++ + Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes)) let get_fields = let rec prodec_rec l subst c = @@ -146,6 +149,8 @@ let print_record env mind mib = let cstrtype = hnf_prod_applist env cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in + let bl = Universes.universe_binders_of_global (IndRef (mind,0)) in + let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in let keyword = let open Decl_kinds in match mib.mind_finite with @@ -157,16 +162,16 @@ let print_record env mind mib = hov 0 ( Printer.pr_polymorphic mib.mind_polymorphic ++ def keyword ++ spc () ++ pr_id mip.mind_typename ++ brk(1,4) ++ - print_params env Evd.empty params ++ - str ": " ++ Printer.pr_lconstr_env envpar Evd.empty arity ++ brk(1,2) ++ + print_params env sigma params ++ + str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ brk(1,2) ++ str ":= " ++ pr_id mip.mind_consnames.(0)) ++ brk(1,2) ++ hv 2 (str "{ " ++ prlist_with_sep (fun () -> str ";" ++ brk(2,0)) (fun (id,b,c) -> pr_id id ++ str (if b then " : " else " := ") ++ - Printer.pr_lconstr_env envpar Evd.empty c) fields) ++ str" }" ++ - Printer.pr_universe_ctx (Univ.instantiate_univ_context mib.mind_universes)) + Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }" ++ + Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes)) let pr_mutual_inductive_body env mind mib = if mib.mind_record <> None && not !Flags.raw_print then @@ -267,6 +272,7 @@ let print_body is_impl env mp (l,body) = if cb.const_polymorphic then Univ.UContext.instance cb.const_universes else Univ.Instance.empty in + let sigma = Evd.empty in (match cb.const_body with | Def _ -> def "Definition" ++ spc () | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () @@ -275,17 +281,17 @@ let print_body is_impl env mp (l,body) = | None -> mt () | Some env -> str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env Evd.empty (* No evars in modules *) + hov 0 (Printer.pr_ltype_env env sigma (Vars.subst_instance_constr u (Typeops.type_of_constant_type env cb.const_type))) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ hov 2 (str ":= " ++ - Printer.pr_lconstr_env env Evd.empty + Printer.pr_lconstr_env env sigma (Vars.subst_instance_constr u (Mod_subst.force_constr l))) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx (Univ.instantiate_univ_context cb.const_universes)) + Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context cb.const_universes)) | SFBmind mib -> try let env = Option.get env in diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 42d22bc3c4..8ca622171f 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -229,7 +229,8 @@ let inversion_scheme env sigma t sort dep_option inv_op = let add_inversion_lemma name env sigma t sort dep inv_op = let invProof, ctx = inversion_scheme env sigma t sort dep inv_op in - let entry = definition_entry ~poly:(Flags.use_polymorphic_flag ()) ~univs:ctx invProof in + let entry = definition_entry ~poly:(Flags.use_polymorphic_flag ()) + ~univs:(snd ctx) invProof in let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in () diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 0811708695..e8a7c0f600 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1806,9 +1806,9 @@ let declare_projection n instance_id r = in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in + let pl, ctx = Evd.universe_context sigma in let cst = - Declare.definition_entry ~types:typ ~poly - ~univs:(Evd.universe_context sigma) term + Declare.definition_entry ~types:typ ~poly ~univs:ctx term in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) diff --git a/toplevel/class.ml b/toplevel/class.ml index f925a2d07e..da6624032f 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -225,7 +225,7 @@ let build_id_coercion idf_opt source poly = in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry - (definition_entry ~types:typ_f ~poly ~univs:(Evd.universe_context sigma) + (definition_entry ~types:typ_f ~poly ~univs:(snd (Evd.universe_context sigma)) ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) in let decl = (constr_entry, IsDefinition IdentityCoercion) in diff --git a/toplevel/classes.ml b/toplevel/classes.ml index e750f0ca26..c354c7d32f 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -185,7 +185,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro nf t in Evarutil.check_evars env Evd.empty !evars termtype; - let ctx = Evd.universe_context !evars in + let pl, ctx = Evd.universe_context !evars in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) @@ -381,7 +381,7 @@ let context poly l = let impl = List.exists test impls in let decl = (Discharge, poly, Definitional) in let nstatus = - pi3 (Command.declare_assumption false decl (t, !uctx) [] impl + pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl Vernacexpr.NoInline (Loc.ghost, id)) in let () = uctx := Univ.ContextSet.empty in diff --git a/toplevel/command.ml b/toplevel/command.ml index 433ef4dccd..73fd3d1a4a 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -83,7 +83,7 @@ let interp_definition pl bl p red_option c ctypopt = let evdref = ref (Evd.from_ctx ctx) in let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in let nb_args = List.length ctx in - let imps,ce = + let imps,pl,ce = match ctypopt with None -> let subst = evd_comb0 Evd.nf_univ_variables evdref in @@ -94,8 +94,8 @@ let interp_definition pl bl p red_option c ctypopt = let body = nf (it_mkLambda_or_LetIn c ctx) in let vars = Universes.universes_of_constr body in let evd = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.universe_context ?names:pl evd in - imps1@(Impargs.lift_implicits nb_args imps2), + let pl, uctx = Evd.universe_context ?names:pl evd in + imps1@(Impargs.lift_implicits nb_args imps2), pl, definition_entry ~univs:uctx ~poly:p body | Some ctyp -> let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in @@ -120,14 +120,14 @@ let interp_definition pl bl p red_option c ctypopt = let vars = Univ.LSet.union (Universes.universes_of_constr body) (Universes.universes_of_constr typ) in let ctx = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.universe_context ?names:pl ctx in - imps1@(Impargs.lift_implicits nb_args impsty), + let pl, uctx = Evd.universe_context ?names:pl ctx in + imps1@(Impargs.lift_implicits nb_args impsty), pl, definition_entry ~types:typ ~poly:p ~univs:uctx body in - red_constant_entry (rel_context_length ctx) ce !evdref red_option, !evdref, imps + red_constant_entry (rel_context_length ctx) ce !evdref red_option, !evdref, pl, imps -let check_definition (ce, evd, imps) = +let check_definition (ce, evd, _, imps) = check_evars_are_solved (Global.env ()) evd (Evd.empty,evd); ce @@ -140,11 +140,12 @@ let get_locality id = function | Local -> true | Global -> false -let declare_global_definition ident ce local k imps = +let declare_global_definition ident ce local k pl imps = let local = get_locality ident local in let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in + let () = Universes.register_universe_binders gr pl in let () = definition_message ident in gr @@ -152,7 +153,7 @@ let declare_definition_hook = ref ignore let set_declare_definition_hook = (:=) declare_definition_hook let get_declare_definition_hook () = !declare_definition_hook -let declare_definition ident (local, p, k) ce imps hook = +let declare_definition ident (local, p, k) ce pl imps hook = let () = !declare_definition_hook ce in let r = match local with | Discharge when Lib.sections_are_opened () -> @@ -168,13 +169,14 @@ let declare_definition ident (local, p, k) ce imps hook = in gr | Discharge | Local | Global -> - declare_global_definition ident ce local k imps in + declare_global_definition ident ce local k pl imps in Lemmas.call_hook (Future.fix_exn_of ce.const_entry_body) hook local r -let _ = Obligations.declare_definition_ref := declare_definition +let _ = Obligations.declare_definition_ref := + (fun i k c imps hook -> declare_definition i k c [] imps hook) let do_definition ident k pl bl red_option c ctypopt hook = - let (ce, evd, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in + let (ce, evd, pl, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in if Flags.is_program_mode () then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in @@ -192,13 +194,14 @@ let do_definition ident k pl bl red_option c ctypopt hook = ignore(Obligations.add_definition ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in - ignore(declare_definition ident k ce imps + ignore(declare_definition ident k ce pl imps (Lemmas.mk_hook (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) -let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = match local with +let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = +match local with | Discharge when Lib.sections_are_opened () -> let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in @@ -225,6 +228,7 @@ let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = ma let kn = declare_constant ident ~local decl in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in + let () = Universes.register_universe_binders gr pl in let () = assumption_message ident in let () = Typeclasses.declare_instance None false gr in let () = if is_coe then Class.try_add_new_coercion gr local p in @@ -241,11 +245,11 @@ let interp_assumption evdref env impls bl c = let ctx = Evd.universe_context_set evd in ((nf ty, ctx), impls) -let declare_assumptions idl is_coe k (c,ctx) imps impl_is_on nl = +let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl = let refs, status, _ = List.fold_left (fun (refs,status,ctx) id -> let ref',u',status' = - declare_assumption is_coe k (c,ctx) imps impl_is_on nl id in + declare_assumption is_coe k (c,ctx) pl imps impl_is_on nl id in (ref',u')::refs, status' && status, Univ.ContextSet.empty) ([],true,ctx) idl in @@ -277,7 +281,7 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let l = List.map (on_pi2 (nf_evar evd)) l in snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,(ctx,imps)) -> let t = replace_vars subst t in - let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) imps false nl in + let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) [] imps false nl in let subst' = List.map2 (fun (_,id) (c,u) -> (id,Universes.constr_of_global_univ (c,u))) idl refs @@ -293,9 +297,9 @@ let do_assumptions_bound_univs coe kind nl id pl c = let ty = nf ty in let vars = Universes.universes_of_constr ty in let evd = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.universe_context ?names:pl evd in let uctx = Univ.ContextSet.of_context uctx in - let (_, _, st) = declare_assumption coe kind (ty, uctx) impls false nl id in + let (_, _, st) = declare_assumption coe kind (ty, uctx) pl impls false nl id in st let do_assumptions kind nl l = match l with @@ -314,7 +318,8 @@ let do_assumptions kind nl l = match l with | None -> id | Some _ -> let loc = fst id in - let msg = Pp.str "Assumptions with bound universes can only be defined once at a time." in + let msg = + Pp.str "Assumptions with bound universes can only be defined one at a time." in user_err_loc (loc, "", msg) in (coe, (List.map map idl, c)) @@ -587,7 +592,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in let ctx_params = map_rel_context nf ctx_params in let evd = !evdref in - let uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.universe_context ?names:pl evd in List.iter (check_evars env_params Evd.empty evd) arities; iter_rel_context (check_evars env0 Evd.empty evd) ctx_params; List.iter (fun (_,ctyps,_) -> @@ -616,7 +621,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = mind_entry_polymorphic = poly; mind_entry_private = if prv then Some false else None; mind_entry_universes = uctx }, - impls + pl, impls (* Very syntactical equality *) let eq_local_binders bl1 bl2 = @@ -665,7 +670,7 @@ let is_recursive mie = List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc | _ -> false -let declare_mutual_inductive_with_eliminations mie impls = +let declare_mutual_inductive_with_eliminations mie pl impls = (* spiwack: raises an error if the structure is supposed to be non-recursive, but isn't *) begin match mie.mind_entry_finite with @@ -680,12 +685,15 @@ let declare_mutual_inductive_with_eliminations mie impls = let (_, kn), prim = declare_mind mie in let mind = Global.mind_of_delta_kn kn in List.iteri (fun i (indimpls, constrimpls) -> - let ind = (mind,i) in - maybe_declare_manual_implicits false (IndRef ind) indimpls; - List.iteri - (fun j impls -> - maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) - constrimpls) + let ind = (mind,i) in + let gr = IndRef ind in + maybe_declare_manual_implicits false gr indimpls; + Universes.register_universe_binders gr pl; + List.iteri + (fun j impls -> + maybe_declare_manual_implicits false + (ConstructRef (ind, succ j)) impls) + constrimpls) impls; let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in if_verbose msg_info (minductive_message warn_prim names); @@ -700,14 +708,14 @@ type one_inductive_impls = let do_mutual_inductive indl poly prv finite = let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) - let mie,impls = interp_mutual_inductive indl ntns poly prv finite in + let mie,pl,impls = interp_mutual_inductive indl ntns poly prv finite in (* Declare the mutual inductive block with its associated schemes *) - ignore (declare_mutual_inductive_with_eliminations mie impls); + ignore (declare_mutual_inductive_with_eliminations mie pl impls); (* Declare the possible notations of inductive types *) List.iter Metasyntax.add_notation_interpretation ntns; (* Declare the coercions *) List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes - + (* 3c| Fixpoints and co-fixpoints *) (* An (unoptimized) function that maps preorders to partial orders... @@ -811,11 +819,12 @@ let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx -let declare_fix ?(opaque = false) (_,poly,_ as kind) ctx f ((def,_),eff) t imps = +let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in - declare_definition f kind ce imps (Lemmas.mk_hook (fun _ r -> r)) + declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r)) -let _ = Obligations.declare_fix_ref := declare_fix +let _ = Obligations.declare_fix_ref := + (fun ?opaque k ctx f d t imps -> declare_fix ?opaque k [] ctx f d t imps) let prepare_recursive_declaration fixnames fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in @@ -1003,7 +1012,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let hook l gr = let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in - let univs = Evd.universe_context !evdref in + let pl, univs = Evd.universe_context !evdref in (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (Evarutil.nf_evar !evdref body) in (** FIXME: include locality *) @@ -1140,8 +1149,8 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - let ctx = Evd.universe_context ?names:pl evd in - ignore (List.map4 (declare_fix (local, poly, Fixpoint) ctx) + let pl, ctx = Evd.universe_context ?names:pl evd in + ignore (List.map4 (declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; @@ -1173,8 +1182,8 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.universe_context ?names:pl evd in - ignore (List.map4 (declare_fix (local, poly, CoFixpoint) ctx) + let pl, ctx = Evd.universe_context ?names:pl evd in + ignore (List.map4 (declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames diff --git a/toplevel/command.mli b/toplevel/command.mli index a031677b47..8e2d9c6fc3 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -33,10 +33,11 @@ val get_declare_definition_hook : unit -> (Safe_typing.private_constants definit val interp_definition : lident list option -> local_binder list -> polymorphic -> red_expr option -> constr_expr -> - constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * Impargs.manual_implicits + constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * + Universes.universe_binders * Impargs.manual_implicits val declare_definition : Id.t -> definition_kind -> - Safe_typing.private_constants definition_entry -> Impargs.manual_implicits -> + Safe_typing.private_constants definition_entry -> Universes.universe_binders -> Impargs.manual_implicits -> Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference val do_definition : Id.t -> definition_kind -> lident list option -> @@ -53,7 +54,7 @@ val do_definition : Id.t -> definition_kind -> lident list option -> nor in a module type and meant to be instantiated. *) val declare_assumption : coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> - Impargs.manual_implicits -> + Universes.universe_binders -> Impargs.manual_implicits -> bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> global_reference * Univ.Instance.t * bool @@ -92,13 +93,13 @@ type one_inductive_impls = val interp_mutual_inductive : structured_inductive_expr -> decl_notation list -> polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> - mutual_inductive_entry * one_inductive_impls list + mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list (** Registering a mutual inductive definition together with its associated schemes *) val declare_mutual_inductive_with_eliminations : - mutual_inductive_entry -> one_inductive_impls list -> + mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> mutual_inductive (** Entry points for the vernacular commands Inductive and CoInductive *) @@ -169,5 +170,5 @@ val do_cofixpoint : val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit -val declare_fix : ?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> +val declare_fix : ?opaque:bool -> definition_kind -> Universes.universe_binders -> Univ.universe_context -> Id.t -> Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index 0b021254e2..f16e6e3f3f 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -129,7 +129,7 @@ let define id internal ctx c t = const_entry_secctx = None; const_entry_type = t; const_entry_polymorphic = true; - const_entry_universes = Evd.universe_context ctx; + const_entry_universes = snd (Evd.universe_context ctx); const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; diff --git a/toplevel/record.ml b/toplevel/record.ml index b1be4c92a6..dc2c9264b8 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -153,7 +153,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = let ce t = Evarutil.check_evars env0 Evd.empty evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); - Evd.universe_context evars, nf arity, template, imps, newps, impls, newfs + Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs let degenerate_decl (na,b,t) = let id = match na with @@ -376,7 +376,7 @@ let declare_structure finite poly ctx id idbuild paramimpls params arity templat mind_entry_polymorphic = poly; mind_entry_private = None; mind_entry_universes = ctx } in - let kn = Command.declare_mutual_inductive_with_eliminations mie [(paramimpls,[])] in + let kn = Command.declare_mutual_inductive_with_eliminations mie [] [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ~kind binder_name coers fieldimpls fields in @@ -532,11 +532,11 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then error "Priorities only allowed for type class substructures"; (* Now, younger decl in params and fields is on top *) - let ctx, arity, template, implpars, params, implfs, fields = + let (pl, ctx), arity, template, implpars, params, implfs, fields = States.with_state_protection (fun () -> typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in let sign = structure_signature (fields@params) in - match kind with + let gr = match kind with | Class def -> let gr = declare_class finite def poly ctx (loc,idstruc) idbuild implpars params arity template implfs fields is_coe coers priorities sign in @@ -549,3 +549,6 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id idbuild implpars params arity template implfs fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in IndRef ind + in + Universes.register_universe_binders gr pl; + gr diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 2879947a91..31bfc004a8 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1527,7 +1527,7 @@ let vernac_check_may_eval redexp glopt rc = let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in Evarconv.check_problems_are_solved env sigma'; let sigma',nf = Evarutil.nf_evars_and_universes sigma' in - let uctx = Evd.universe_context sigma' in + let pl, uctx = Evd.universe_context sigma' in let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in let c = nf c in let j = @@ -1542,7 +1542,7 @@ let vernac_check_may_eval redexp glopt rc = let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in msg_notice (print_judgment env sigma' j ++ pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ - Printer.pr_universe_ctx uctx) + Printer.pr_universe_ctx sigma uctx) | Some r -> Tacintern.dump_glob_red_expr r; let (sigma',r_interp) = interp_redexp env sigma' r in -- cgit v1.2.3 From 78378ba9a79b18a658828d7a110414ad18b9a732 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 29 Oct 2015 07:39:36 +0100 Subject: Accept option -compat 8.5. (Fix bug #4393) --- toplevel/coqinit.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 19d4363ab8..eca344b27c 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -130,6 +130,7 @@ let init_ocaml_path () = [ "grammar" ]; [ "ide" ] ] let get_compat_version = function + | "8.5" -> Flags.Current | "8.4" -> Flags.V8_4 | "8.3" -> Flags.V8_3 | "8.2" -> Flags.V8_2 -- cgit v1.2.3 From dd1998f1a9bc2aae2e83aa4e349318d2466b6aea Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 29 Oct 2015 15:39:20 +0100 Subject: Cleanup API and comments of 908dcd613 --- kernel/safe_typing.ml | 7 +++---- kernel/term_typing.ml | 40 +++++++++++++++++++++------------------- kernel/term_typing.mli | 22 +++++++++++++--------- 3 files changed, 37 insertions(+), 32 deletions(-) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index b71cd31b5c..97b74cadb9 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -218,8 +218,8 @@ let empty_private_constants = [] let add_private x xs = x :: xs let concat_private xs ys = xs @ ys let mk_pure_proof = Term_typing.mk_pure_proof -let inline_private_constants_in_constr = Term_typing.handle_side_effects -let inline_private_constants_in_definition_entry = Term_typing.handle_entry_side_effects +let inline_private_constants_in_constr = Term_typing.inline_side_effects +let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x) let constant_entry_of_private_constant = function @@ -517,8 +517,7 @@ let add_constant dir l decl senv = match decl with | ConstantEntry (true, ce) -> let exports, ce = - Term_typing.validate_side_effects_for_export - senv.revstruct senv.env ce in + Term_typing.export_side_effects senv.revstruct senv.env ce in exports, ConstantEntry (false, ce) | _ -> [], decl in diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index d75bd73fb6..a566028d40 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -60,11 +60,11 @@ let rec uniq_seff = function | [] -> [] | x :: xs -> x :: uniq_seff (List.filter (fun y -> not (equal_eff x y)) xs) (* The list of side effects is in reverse order (most recent first). - * To keep the "tological" order between effects we have to uniqize from the - * tail *) + * To keep the "topological" order between effects we have to uniq-ize from + * the tail *) let uniq_seff l = List.rev (uniq_seff (List.rev l)) -let handle_side_effects env body ctx side_eff = +let inline_side_effects env body ctx side_eff = let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } = let cbl = match se with | SEsubproof (c,cb,b) -> [c,cb,b] @@ -118,6 +118,8 @@ let handle_side_effects env body ctx side_eff = (* CAVEAT: we assure a proper order *) List.fold_left handle_sideff (body,ctx,[]) (uniq_seff side_eff) +(* Given the list of signatures of side effects, checks if they match. + * I.e. if they are ordered descendants of the current revstruct *) let check_signatures curmb sl = let is_direct_ancestor (sl, curmb) (mb, how_many) = match curmb with @@ -135,7 +137,7 @@ let check_signatures curmb sl = let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in sl -let trust_seff sl b e = +let skip_trusted_seff sl b e = let rec aux sl b e acc = match sl, kind_of_term b with | (None|Some 0), _ -> b, e, acc @@ -185,21 +187,21 @@ let infer_declaration ~trust env kn dcl = let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = - Future.chain ~greedy:true ~pure:true body (fun ((body, ctx),side_eff) -> - let body, ctx, signatures = - handle_side_effects env body ctx side_eff in - let trusted_signatures = check_signatures trust signatures in - let env' = push_context_set ctx env in + Future.chain ~greedy:true ~pure:true body (fun ((body,uctx),side_eff) -> + let body, uctx, signatures = + inline_side_effects env body uctx side_eff in + let valid_signatures = check_signatures trust signatures in + let env' = push_context_set uctx env in let j = - let body, env', zip_ctx = trust_seff trusted_signatures body env' in + let body,env',ectx = skip_trusted_seff valid_signatures body env' in let j = infer env' body in - unzip zip_ctx j in + unzip ectx j in let j = hcons_j j in let subst = Univ.LMap.empty in let _typ = constrain_type env' j c.const_entry_polymorphic subst (`SomeWJ (typ,tyj)) in feedback_completion_typecheck feedback_id; - j.uj_val, ctx) in + j.uj_val, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in def, RegularArity typ, None, c.const_entry_polymorphic, c.const_entry_universes, @@ -210,7 +212,7 @@ let infer_declaration ~trust env kn dcl = let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in let univsctx = Univ.ContextSet.of_context c.const_entry_universes in - let body, ctx, _ = handle_side_effects env body + let body, ctx, _ = inline_side_effects env body (Univ.ContextSet.union univsctx ctx) side_eff in let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in @@ -396,9 +398,9 @@ type side_effect_role = | Schema of inductive * string type exported_side_effect = - constant * constant_body * side_effects Entries.constant_entry * side_effect_role + constant * constant_body * side_effects constant_entry * side_effect_role -let validate_side_effects_for_export mb env ce = +let export_side_effects mb env ce = match ce with | ParameterEntry _ | ProjectionEntry _ -> [], ce | DefinitionEntry c -> @@ -481,12 +483,12 @@ let translate_local_def mb env id centry = let translate_mind env kn mie = Indtypes.check_inductive env kn mie -let handle_entry_side_effects env ce = { ce with +let inline_entry_side_effects env ce = { ce with const_entry_body = Future.chain ~greedy:true ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> - let body, ctx',_ = handle_side_effects env body ctx side_eff in + let body, ctx',_ = inline_side_effects env body ctx side_eff in (body, ctx'), []); } -let handle_side_effects env body side_eff = - pi1 (handle_side_effects env body Univ.ContextSet.empty side_eff) +let inline_side_effects env body side_eff = + pi1 (inline_side_effects env body Univ.ContextSet.empty side_eff) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 509160ccc7..2e6aa161b4 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -19,30 +19,34 @@ val translate_local_assum : env -> types -> types val mk_pure_proof : constr -> side_effects proof_output -val handle_side_effects : env -> constr -> side_effects -> constr +val inline_side_effects : env -> constr -> side_effects -> constr (** Returns the term where side effects have been turned into let-ins or beta redexes. *) -val handle_entry_side_effects : env -> side_effects definition_entry -> side_effects definition_entry -(** Same as {!handle_side_effects} but applied to entries. Only modifies the +val inline_entry_side_effects : + env -> side_effects definition_entry -> side_effects definition_entry +(** Same as {!inline_side_effects} but applied to entries. Only modifies the {!Entries.const_entry_body} field. It is meant to get a term out of a not yet type checked proof. *) val uniq_seff : side_effects -> side_effects -val translate_constant : structure_body -> env -> constant -> side_effects constant_entry -> constant_body +val translate_constant : + structure_body -> env -> constant -> side_effects constant_entry -> + constant_body -(* Checks weather the side effects in constant_entry can be trusted. - * Returns the list of effects to be exported. - * Note: It forces the Future.computation. *) type side_effect_role = | Subproof | Schema of inductive * string type exported_side_effect = - constant * constant_body * side_effects Entries.constant_entry * side_effect_role + constant * constant_body * side_effects constant_entry * side_effect_role -val validate_side_effects_for_export : +(* Given a constant entry containing side effects it exports them (either + * by re-checking them or trusting them). Returns the constant bodies to + * be pushed in the safe_env by safe typing. The main constant entry + * needs to be translated as usual after this step. *) +val export_side_effects : structure_body -> env -> side_effects constant_entry -> exported_side_effect list * side_effects constant_entry -- cgit v1.2.3 From 654b69cbeb55a0cab3c2328d73355ad2510d1a85 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 29 Oct 2015 14:21:25 +0100 Subject: Fixing another instance of bug #3267 in eauto, this time in the presence of hints modifying the context and of a "using" clause. Incidentally opening Hints by default in debugger. --- dev/base_include | 1 + tactics/eauto.ml4 | 21 +++++++++++++-------- test-suite/bugs/closed/3267.v | 11 +++++++++++ 3 files changed, 25 insertions(+), 8 deletions(-) diff --git a/dev/base_include b/dev/base_include index d58b6ad13c..dac1f6093c 100644 --- a/dev/base_include +++ b/dev/base_include @@ -148,6 +148,7 @@ open Tactic_debug open Decl_proof_instr open Decl_mode +open Hints open Auto open Autorewrite open Contradiction diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index ca430ec111..7b4b6f9163 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -204,7 +204,8 @@ type search_state = { last_tactic : std_ppcmds Lazy.t; dblist : hint_db list; localdb : hint_db list; - prev : prev_search_state + prev : prev_search_state; + local_lemmas : Evd.open_constr list; } and prev_search_state = (* for info eauto *) @@ -263,7 +264,7 @@ module SearchProblem = struct List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb; - prev = ps}) l + prev = ps; local_lemmas = s.local_lemmas}) l in let intro_tac = let l = filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro, (-1), lazy (str "intro")] in @@ -277,7 +278,8 @@ module SearchProblem = struct hintl (List.hd s.localdb) in { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb; prev = ps }) + localdb = ldb :: List.tl s.localdb; prev = ps; + local_lemmas = s.local_lemmas}) l in let rec_tacs = @@ -289,7 +291,8 @@ module SearchProblem = struct let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; - prev = ps; dblist = s.dblist; localdb = List.tl s.localdb } + prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; + local_lemmas = s.local_lemmas } else let newlocal = let hyps = pf_hyps g in @@ -297,12 +300,13 @@ module SearchProblem = struct let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in let hyps' = pf_hyps gls in if hyps' == hyps then List.hd s.localdb - else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true []) + else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) in { depth = pred s.depth; priority = cost; tacres = lgls; dblist = s.dblist; last_tactic = pp; prev = ps; - localdb = newlocal @ List.tl s.localdb }) + localdb = newlocal @ List.tl s.localdb; + local_lemmas = s.local_lemmas }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) @@ -367,7 +371,7 @@ let pr_info dbg s = (** Eauto main code *) -let make_initial_state dbg n gl dblist localdb = +let make_initial_state dbg n gl dblist localdb lems = { depth = n; priority = 0; tacres = tclIDTAC gl; @@ -375,6 +379,7 @@ let make_initial_state dbg n gl dblist localdb = dblist = dblist; localdb = [localdb]; prev = if dbg == Info then Init else Unknown; + local_lemmas = lems; } let e_search_auto debug (in_depth,p) lems db_list gl = @@ -388,7 +393,7 @@ let e_search_auto debug (in_depth,p) lems db_list gl = in try pr_dbg_header d; - let s = tac (make_initial_state d p gl db_list local_db) in + let s = tac (make_initial_state d p gl db_list local_db lems) in pr_info d s; s.tacres with Not_found -> diff --git a/test-suite/bugs/closed/3267.v b/test-suite/bugs/closed/3267.v index 5ce1ddf0c4..8175d66ac7 100644 --- a/test-suite/bugs/closed/3267.v +++ b/test-suite/bugs/closed/3267.v @@ -34,3 +34,14 @@ Module d. debug eauto. Defined. End d. + +(* An other variant which was still failing in 8.5 beta2 *) + +Parameter A B : Prop. +Axiom a:B. + +Hint Extern 1 => match goal with H:_ -> id _ |- _ => try (unfold id in H) end. +Goal (B -> id A) -> A. +intros. +eauto using a. +Abort. -- cgit v1.2.3 From dc13be3390c7b1d375d11842abb36e63aeb91cad Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 29 Oct 2015 16:53:15 +0100 Subject: Avoid an anomaly when destructing an unknown ident. (Fix bug #4395) It is too bad that OCaml does not warn when catching an exception over a closure rather than inside it. --- tactics/tacinterp.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 6c125ed2d9..355745d970 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -985,10 +985,10 @@ let interp_induction_arg ist gl arg = let try_cast_id id' = if Tactics.is_quantified_hypothesis id' gl then keep,ElimOnIdent (loc,id') - else - (try keep,ElimOnConstr (fun env sigma -> sigma,(constr_of_id env id',NoBindings)) + else keep, ElimOnConstr (fun env sigma -> + try sigma, (constr_of_id env id', NoBindings) with Not_found -> - user_err_loc (loc,"", + user_err_loc (loc, "interp_induction_arg", pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis.")) in try -- cgit v1.2.3 From 7f8a31e21edd533ba12399b7ee5647ef30e38fe5 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 29 Oct 2015 17:22:08 +0100 Subject: Manually expand the debugging versions of "trivial" and "auto". (Fix bug #4392) Without this expansion, camlp4 fails to properly factor a user notation starting with either "trivial" or "auto". --- parsing/g_tactic.ml4 | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 69593f993c..d3eb6bbcbb 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -452,16 +452,6 @@ GEXTEND Gram [ [ "using"; l = LIST1 constr SEP "," -> l | -> [] ] ] ; - trivial: - [ [ IDENT "trivial" -> Off - | IDENT "info_trivial" -> Info - | IDENT "debug"; IDENT "trivial" -> Debug ] ] - ; - auto: - [ [ IDENT "auto" -> Off - | IDENT "info_auto" -> Info - | IDENT "debug"; IDENT "auto" -> Debug ] ] - ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; @@ -627,9 +617,18 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Automation tactic *) - | d = trivial; lems = auto_using; db = hintbases -> TacAtom (!@loc, TacTrivial (d,lems,db)) - | d = auto; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (d,n,lems,db)) + | IDENT "trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Off, lems, db)) + | IDENT "info_trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Info, lems, db)) + | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Debug, lems, db)) + | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Off, n, lems, db)) + | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Info, n, lems, db)) + | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Debug, n, lems, db)) (* Context management *) | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) -- cgit v1.2.3 From f02f64a21863ce03f2da4ff04cd003051f96801f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 29 Oct 2015 18:18:43 +0100 Subject: Removing some goal unsafeness in inductive schemes. --- engine/sigma.ml | 12 +++++++++ engine/sigma.mli | 6 +++++ plugins/funind/functional_principles_types.ml | 10 +++++--- pretyping/indrec.ml | 10 +++++--- pretyping/indrec.mli | 8 +++--- tactics/elimschemes.ml | 9 ++++--- tactics/eqschemes.ml | 8 +++--- tactics/tacticals.ml | 11 ++++++-- tactics/tactics.ml | 36 +++++++++++++++------------ 9 files changed, 75 insertions(+), 35 deletions(-) diff --git a/engine/sigma.ml b/engine/sigma.ml index e3e83b6024..e886b0d1e7 100644 --- a/engine/sigma.ml +++ b/engine/sigma.ml @@ -36,6 +36,18 @@ let new_evar sigma ?naming info = let define evk c sigma = Sigma ((), Evd.define evk c sigma, ()) +let fresh_sort_in_family ?rigid env sigma s = + let (sigma, s) = Evd.fresh_sort_in_family ?rigid env sigma s in + Sigma (s, sigma, ()) + +let fresh_constant_instance env sigma cst = + let (sigma, cst) = Evd.fresh_constant_instance env sigma cst in + Sigma (cst, sigma, ()) + +let fresh_inductive_instance env sigma ind = + let (sigma, ind) = Evd.fresh_inductive_instance env sigma ind in + Sigma (ind, sigma, ()) + let fresh_constructor_instance env sigma pc = let (sigma, c) = Evd.fresh_constructor_instance env sigma pc in Sigma (c, sigma, ()) diff --git a/engine/sigma.mli b/engine/sigma.mli index 6ac56bb3e2..cb948dba59 100644 --- a/engine/sigma.mli +++ b/engine/sigma.mli @@ -66,6 +66,12 @@ val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma (** Polymorphic universes *) +val fresh_sort_in_family : ?rigid:Evd.rigid -> Environ.env -> + 'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma +val fresh_constant_instance : + Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma +val fresh_inductive_instance : + Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma val fresh_constructor_instance : Environ.env -> 'r t -> constructor -> (pconstructor, 'r) sigma diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index c47602bda0..bbe2f1a3ad 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -12,6 +12,7 @@ open Tactics open Indfun_common open Functional_principles_proofs open Misctypes +open Sigma.Notations exception Toberemoved_with_rel of int*constr exception Toberemoved @@ -648,12 +649,15 @@ let build_case_scheme fa = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes in - let ind_fun = + let (ind, sf) = let ind = first_fun_kn,funs_indexes in (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let sigma, scheme = - (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (scheme, sigma, _) = + Indrec.build_case_analysis_scheme_default env sigma ind sf + in + let sigma = Sigma.to_evar_map sigma in let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 54d47fbe00..6dfc32bf1a 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -28,6 +28,7 @@ open Inductiveops open Environ open Reductionops open Nametab +open Sigma.Notations type dep_flag = bool @@ -120,13 +121,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = mkLambda_string "f" t (add_branch (push_rel (Anonymous, None, t) env) (k+1)) in - let sigma, s = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in + let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in let typP = make_arity env' dep indf s in let c = it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar - in sigma, c + in + Sigma (c, sigma, p) (* check if the type depends recursively on one of the inductive scheme *) @@ -474,7 +476,9 @@ let mis_make_indrec env sigma listdepkind mib u = it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in + let evd' = Sigma.to_evar_map sigma in evdref := evd'; c in (* Body of mis_make_indrec *) diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index f616c96792..81416a322b 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -25,13 +25,13 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> evar_map -> pinductive -> - dep_flag -> sorts_family -> evar_map * constr +val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive -> + dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma (** Build a dependent case elimination predicate unless type is in Prop *) -val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> - sorts_family -> evar_map * constr +val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive -> + sorts_family -> (constr, 'r) Sigma.sigma (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop *) diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 8a6d93cf7c..59cce19ef3 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -18,6 +18,7 @@ open Indrec open Declarations open Typeops open Ind_tables +open Sigma.Notations (* Induction/recursion schemes *) @@ -102,10 +103,10 @@ let rec_dep_scheme_kind_from_type = let build_case_analysis_scheme_in_type dep sort ind = let env = Global.env () in - let sigma = Evd.from_env env in - let sigma, indu = Evd.fresh_inductive_instance env sigma ind in - let sigma, c = build_case_analysis_scheme env sigma indu dep sort in - c, Evd.evar_universe_context sigma + let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in + let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in + let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context (Sigma.to_evar_map sigma) let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index b2603315d5..76bf13a577 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -58,6 +58,7 @@ open Namegen open Inductiveops open Ind_tables open Indrec +open Sigma.Notations let hid = Id.of_string "H" let xid = Id.of_string "X" @@ -630,9 +631,10 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (**********************************************************************) let build_r2l_rew_scheme dep env ind k = - let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in - let sigma', c = build_case_analysis_scheme env sigma indu dep k in - c, Evd.evar_universe_context sigma' + let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in + let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in + let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context (Sigma.to_evar_map sigma) let build_l2r_rew_scheme = build_l2r_rew_scheme let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bdbc0aa21f..f2e013641a 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -16,6 +16,7 @@ open Context open Declarations open Tacmach open Clenv +open Sigma.Notations (************************************************************************) (* Tacticals re-exported from the Refiner module *) @@ -225,12 +226,18 @@ let gl_make_elim ind gl = pf_apply Evd.fresh_global gl gr let gl_make_case_dep ind gl = - pf_apply Indrec.build_case_analysis_scheme gl ind true + let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind true (elimination_sort_of_goal gl) + in + (Sigma.to_evar_map sigma, r) let gl_make_case_nodep ind gl = - pf_apply Indrec.build_case_analysis_scheme gl ind false + let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind false (elimination_sort_of_goal gl) + in + (Sigma.to_evar_map sigma, r) let make_elim_branch_assumptions ba gl = let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 289d5109a5..65d2749b58 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1249,12 +1249,11 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in - let t = Retyping.get_type_of env sigma c in - let (mind,_) = reduce_to_quantified_ind env sigma t in + let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in + let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in - let sigma, elim = + let Sigma (elim, sigma, p) = if occur_term c concl then build_case_analysis_scheme env sigma mind true sort else @@ -1264,7 +1263,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = {elimindex = None; elimbody = (elim,NoBindings); elimrename = Some (false, constructors_nrealdecls (fst mind))}) in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let general_case_analysis with_evars clear_flag (c,lbindc as cx) = @@ -1444,8 +1443,9 @@ let descend_in_conjunctions avoid tac (err, info) c = let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> - let elim = build_case_analysis_scheme env sigma (ind,u) false sort in - NotADefinedRecordUseScheme (snd elim) in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in + NotADefinedRecordUseScheme elim in Tacticals.New.tclFIRST (List.init n (fun i -> Proofview.Goal.enter { enter = begin fun gl -> @@ -3668,11 +3668,16 @@ let guess_elim isrec dep s hyp0 gl = let evd, elimc = if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl else + let env = Tacmach.New.pf_env gl in + let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in if use_dependent_propositions_elimination () && dep then - Tacmach.New.pf_apply build_case_analysis_scheme gl mind true s + let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma mind true s in + (Sigma.to_evar_map sigma, ind) else - Tacmach.New.pf_apply build_case_analysis_scheme_default gl mind s in + let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in + (Sigma.to_evar_map sigma, ind) + in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in evd, ((elimc, NoBindings), elimt), mkIndU mind @@ -4025,10 +4030,9 @@ let induction_gen clear_flag isrec with_evars elim | _ -> [] in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in - let sigma = Sigma.Unsafe.of_evar_map sigma in let t = typ_of env sigma c in let is_arg_pure_hyp = isVar c && not (mem_named_context (destVar c) (Global.named_context())) @@ -4251,11 +4255,11 @@ let elim_type t = let case_type t = Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> - let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in - let evd, elimc = - Tacmach.New.pf_apply build_case_analysis_scheme_default gl ind (Tacticals.New.elimination_sort_of_goal gl) - in - Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) + let env = Tacmach.New.pf_env gl in + let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in + let s = Tacticals.New.elimination_sort_of_goal gl in + let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma ind s in + Sigma (elim_scheme_type elimc t, evd, p) end } -- cgit v1.2.3 From 250df8586a776eaadc3553b5ceef98d3696fffdb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 29 Oct 2015 19:14:51 +0100 Subject: Removing the evar_map argument from s_enter. --- proofs/proofview.ml | 10 ++++------ proofs/proofview.mli | 4 ++-- tactics/auto.ml | 3 ++- tactics/autorewrite.ml | 3 ++- tactics/contradiction.ml | 3 ++- tactics/equality.ml | 4 ++-- tactics/evar_tactics.ml | 3 ++- tactics/extratactics.ml4 | 3 ++- tactics/inv.ml | 3 ++- tactics/tactics.ml | 49 +++++++++++++++++++++++++++++++----------------- 10 files changed, 52 insertions(+), 33 deletions(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index bded518e78..96ba88233e 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -978,7 +978,7 @@ module Goal = struct end type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin @@ -987,8 +987,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let gl = gmake env sigma goal in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.s_enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1004,8 +1003,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.s_enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1263,5 +1261,5 @@ module Notations = struct type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index aafd4c5759..66603b9764 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -464,7 +464,7 @@ module Goal : sig val enter : ([ `LZ ], unit tactic) enter -> unit tactic type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing @@ -608,5 +608,5 @@ module Notations : sig type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end diff --git a/tactics/auto.ml b/tactics/auto.ml index 4a520612f8..4fb4b32632 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -119,7 +119,8 @@ let exact poly (c,clenv) = let ctx = Evd.evar_universe_context clenv.evd in ctx, c in - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (exact_check c', sigma) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 43a8d7f06a..e4ff1c9069 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -94,7 +94,8 @@ type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tac let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in let sigma = Sigma.to_evar_map sigma in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 0cc74ff446..5ccf4a9e4f 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -24,7 +24,8 @@ let mk_absurd_proof t = mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma c in diff --git a/tactics/equality.ml b/tactics/equality.ml index 56878f1125..2edd67ef8d 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -347,7 +347,7 @@ let type_of_clause cls gl = match cls with | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let isatomic = isProd (whd_zeta hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in @@ -1483,7 +1483,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index c9fc01088c..4c4d745035 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -70,7 +70,8 @@ let instantiate_tac_by_name id c = let let_evar name typ = let src = (Loc.ghost,Evar_kinds.GoalEvar) in - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let id = match name with | Names.Anonymous -> diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index e1997c7051..5201d54d6a 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -618,7 +618,8 @@ let out_arg = function | ArgArg x -> x let hResolve id c occ t = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in diff --git a/tactics/inv.ml b/tactics/inv.ml index a9fa52e928..ed1a627956 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -432,7 +432,8 @@ let rewrite_equations_tac as_mode othin id neqns names ba = tac let raw_inversion inv_kind id status names = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 65d2749b58..62f3069275 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -610,7 +610,8 @@ let e_reduct_option ?(check=false) redfun = function from conversions. *) let e_change_in_concl (redfun,sty) = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in Sigma.Unsafe.of_pair (convert_concl_no_check c sty, sigma) @@ -633,7 +634,8 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma', (id,Some b',ty') let e_change_in_hyp redfun (id,where) = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in let sigma, c = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in @@ -1247,7 +1249,8 @@ let general_elim with_evars clear_flag (c, lbindc) elim = (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in @@ -1297,7 +1300,7 @@ let find_eliminator c gl = let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE - (Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + (Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma, elim = find_eliminator c gl in let tac = (general_elim with_evars clear_flag cx elim) @@ -1469,7 +1472,8 @@ let descend_in_conjunctions avoid tac (err, info) c = (****************************************************) let solve_remaining_apply_goals = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in @@ -1736,7 +1740,8 @@ let new_exact_no_check c = Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in @@ -1952,7 +1957,8 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl @@ -2371,7 +2377,8 @@ let decode_hyp = function *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let t = match ty with Some t -> t | _ -> typ_of env sigma c in let Sigma ((newcl, eq_tac), sigma, p) = match with_eq with @@ -2447,7 +2454,8 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in @@ -2458,7 +2466,8 @@ let letin_tac with_eq id c ty occs = end } let letin_pat_tac with_eq id c occs = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let check t = true in @@ -2616,7 +2625,8 @@ let generalize_gen_let lconstr gl = if Option.is_empty b then Some c else None) lconstr)) gl let new_generalize_gen_let lconstr = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Sigma.to_evar_map sigma in @@ -3794,7 +3804,8 @@ let induction_tac with_evars params indvars elim gl = induction applies with the induction hypotheses *) let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in @@ -3961,7 +3972,8 @@ let check_enough_applied env sigma elim = let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in @@ -4247,14 +4259,15 @@ let elim_scheme_type elim t = end } let elim_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) end } let case_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in let s = Tacticals.New.elimination_sort_of_goal gl in @@ -4512,7 +4525,8 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context() and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in @@ -4591,7 +4605,8 @@ let tclABSTRACT name_op tac = abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in try let core_flags = { (default_unify_flags ()).core_unify_flags with -- cgit v1.2.3 From 0796ca73cbe37bb4803bf0e7153c1c67ff4dd24a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 29 Oct 2015 19:44:40 +0100 Subject: Removing unused and useless exported function in Hints. --- tactics/auto.mli | 2 -- 1 file changed, 2 deletions(-) diff --git a/tactics/auto.mli b/tactics/auto.mli index 215544a591..1132478aac 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -29,8 +29,6 @@ val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> ([ `NF ], 'r) Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic - val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic (** [ConclPattern concl pat tacast]: -- cgit v1.2.3 From 4afb91237fa89fd9dc018a567382e34d6b1e616f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 29 Oct 2015 19:56:42 +0100 Subject: Removing some goal unsafeness in Equality. --- tactics/equality.ml | 35 +++++++++++++++++++++-------------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index 2edd67ef8d..7a8a3a97b3 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -317,8 +317,8 @@ let find_elim hdcncl lft2rgt dep cls ot gl = Logic.eq or Jmeq just before *) assert false in - let sigma, elim = Evd.fresh_global (Global.env ()) (Tacmach.New.project gl) (ConstRef c) in - sigma, elim, Safe_typing.empty_private_constants + let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + Sigma ((elim, Safe_typing.empty_private_constants), sigma, p) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -336,10 +336,10 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) - let sigma, elim = - Evd.fresh_global (Global.env ()) (Tacmach.New.project gl) (ConstRef c) + let Sigma (elim, sigma, p) = + Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in - sigma, elim, eff + Sigma ((elim, eff), sigma, p) | _ -> assert false let type_of_clause cls gl = match cls with @@ -352,14 +352,14 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in - let (sigma,elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in let tac = Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let adjust_rewriting_direction args lft2rgt = @@ -1451,6 +1451,7 @@ let decomp_tuple_term env c t = in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = + let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env dep_pair1 typ in @@ -1475,7 +1476,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in - sigma,body,expected_goal + Sigma.Unsafe.of_pair ((body, expected_goal), sigma) (* Like "replace" but decompose dependent equalities *) (* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) @@ -1484,10 +1485,12 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let cutSubstInConcl l2r eqn = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in + let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = tclTHENFIRST (tclTHENLIST [ @@ -1496,22 +1499,26 @@ let cutSubstInConcl l2r eqn = ]) (change_concl expected) (* Put in normalized form *) in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let cutSubstInHyp l2r eqn id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in - tclTHENFIRST + let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in + let tac = + tclTHENFIRST (tclTHENLIST [ - (Proofview.Unsafe.tclEVARS sigma); (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) + in + Sigma (tac, sigma, p) end } let try_rewrite tac = -- cgit v1.2.3 From 78edfe09f34db4a28fb41a1f6fd3bb4922d09ec8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 29 Oct 2015 15:09:14 -0400 Subject: Collect subproof universes in handle_side_effects. --- kernel/safe_typing.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 97b74cadb9..e0a07dcc3a 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -254,7 +254,9 @@ let universes_of_private eff = if cb.const_polymorphic then acc else (Univ.ContextSet.of_context cb.const_universes) :: acc) acc l - | Entries.SEsubproof _ -> acc) + | Entries.SEsubproof (c, cb, e) -> + if cb.const_polymorphic then acc + else Univ.ContextSet.of_context cb.const_universes :: acc) [] eff let env_of_safe_env senv = senv.env -- cgit v1.2.3 From a3a17b514a2ffaba54cd182fdf27b7e84366ab44 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 29 Oct 2015 15:11:29 -0400 Subject: Handle side-effects of Vernacular commands inside proofs better, so that universes are declared correctly in the enclosing proofs evar_map's. --- pretyping/evd.ml | 9 +++++++++ pretyping/evd.mli | 2 ++ proofs/proof_global.ml | 6 ++++++ proofs/proof_global.mli | 5 +++++ stm/stm.ml | 32 ++++++++++++++++++++------------ test-suite/success/sideff.v | 12 ++++++++++++ 6 files changed, 54 insertions(+), 12 deletions(-) create mode 100644 test-suite/success/sideff.v diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 36d9c25fdd..db6b366b75 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1358,6 +1358,15 @@ let add_universe_name evd s l = let universes evd = evd.universes.uctx_universes +let update_sigma_env evd env = + let univs = Environ.universes env in + let eunivs = + { evd.universes with uctx_initial_universes = univs; + uctx_universes = univs } + in + let eunivs = merge_uctx true univ_rigid eunivs eunivs.uctx_local in + { evd with universes = eunivs } + (* Conversion w.r.t. an evar map and its local universes. *) let conversion_gen env evd pb t u = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 3c16b27ad9..671d62021a 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -560,6 +560,8 @@ val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_sub val nf_constraints : evar_map -> evar_map +val update_sigma_env : evar_map -> env -> evar_map + (** Polymorphic universes *) val fresh_sort_in_family : ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 809ed41c7e..c303f486c5 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -695,3 +695,9 @@ let copy_terminators ~src ~tgt = assert(List.length src = List.length tgt); List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt +let update_global_env () = + with_current_proof (fun _ p -> + Proof.in_proof p (fun sigma -> + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in + (p, ()))) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index f8615e8499..a22545080b 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -89,6 +89,11 @@ val start_dependent_proof : Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit +(** Update the proofs global environment after a side-effecting command + (e.g. a sublemma definition) has been run inside it. Assumes + there_are_pending_proofs. *) +val update_global_env : unit -> unit + (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof diff --git a/stm/stm.ml b/stm/stm.ml index 88a1fbbf48..02361c738d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -123,6 +123,10 @@ let pr_open_cur_subgoals () = try Printer.pr_open_subgoals () with Proof_global.NoCurrentProof -> str"" +let update_global_env () = + if Proof_global.there_are_pending_proofs () then + Proof_global.update_global_env () + module Vcs_ = Vcs.Make(Stateid) type future_proof = Proof_global.closed_proof_output Future.computation type proof_mode = string @@ -135,6 +139,7 @@ type branch_type = proof_mode * Stateid.t * Stateid.t * vernac_qed_type * Vcs_.Branch.t ] type cmd_t = { ctac : bool; (* is a tactic, needed by the 8.4 semantics of Undo *) + ceff : bool; (* is a side-effecting command *) cast : ast; cids : Id.t list; cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch ] } @@ -721,6 +726,7 @@ end = struct (* {{{ *) try prerr_endline("defining "^str_id^" (cache="^ if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); + (* set id and good id *) f (); if cache = `Yes then freeze `No id else if cache = `Shallow then freeze `Shallow id; @@ -730,7 +736,7 @@ end = struct (* {{{ *) Hooks.(call state_computed id ~in_cache:false); VCS.reached id true; if Proof_global.there_are_pending_proofs () then - VCS.goals id (Proof_global.get_open_goals ()); + VCS.goals id (Proof_global.get_open_goals ()) with e -> let (e, info) = Errors.push e in let good_id = !cur_id in @@ -1753,8 +1759,9 @@ let known_state ?(redefine_qed=false) ~cache id = let cherry_pick_non_pstate () = Summary.freeze_summary ~marshallable:`No ~complement:true pstate, Lib.freeze ~marshallable:`No in - let inject_non_pstate (s,l) = Summary.unfreeze_summary s; Lib.unfreeze l in - + let inject_non_pstate (s,l) = + Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () + in let rec pure_cherry_pick_non_pstate id = Future.purify (fun id -> prerr_endline ("cherry-pick non pstate " ^ Stateid.to_string id); reach id; @@ -1784,9 +1791,9 @@ let known_state ?(redefine_qed=false) ~cache id = reach view.next; Query.vernac_interp cancel view.next id x ), cache, false - | `Cmd { cast = x } -> (fun () -> - reach view.next; vernac_interp id x - ), cache, true + | `Cmd { cast = x; ceff = eff } -> (fun () -> + reach view.next; vernac_interp id x; + if eff then update_global_env ()), cache, true | `Fork ((x,_,_,_), None) -> (fun () -> reach view.next; vernac_interp id x; wall_clock_last_fork := Unix.gettimeofday () @@ -1885,7 +1892,7 @@ let known_state ?(redefine_qed=false) ~cache id = in aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (`Ast (x,_)) -> (fun () -> - reach view.next; vernac_interp id x; + reach view.next; vernac_interp id x; update_global_env () ), cache, true | `Sideff (`Id origin) -> (fun () -> reach view.next; @@ -2135,7 +2142,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) else `MainQueue in - VCS.commit id (Cmd {ctac=false;cast = x; cids = []; cqueue = queue }); + VCS.commit id (Cmd {ctac=false;ceff=false;cast = x; cids = []; cqueue = queue }); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQuery (false,_), VtLater -> anomaly(str"classifier: VtQuery + VtLater must imply part_of_script") @@ -2158,7 +2165,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = anomaly(str"VtProofMode must be executed VtNow") | VtProofMode mode, VtNow -> let id = VCS.new_node ~id:newtip () in - VCS.commit id (Cmd {ctac=false;cast = x;cids=[];cqueue = `MainQueue}); + VCS.commit id (Cmd {ctac=false;ceff=false;cast = x;cids=[];cqueue = `MainQueue}); List.iter (fun bn -> match VCS.get_branch bn with | { VCS.root; kind = `Master; pos } -> () @@ -2176,7 +2183,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = | VtProofStep paral, w -> let id = VCS.new_node ~id:newtip () in let queue = if paral then `TacQueue (ref false) else `MainQueue in - VCS.commit id (Cmd {ctac = true;cast = x;cids = [];cqueue = queue }); + VCS.commit id (Cmd {ctac = true;ceff = false;cast = x;cids = [];cqueue = queue }); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQed keep, w -> let valid = if tty then Some(VCS.get_branch_pos head) else None in @@ -2192,7 +2199,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = | VtSideff l, w -> let id = VCS.new_node ~id:newtip () in VCS.checkout VCS.Branch.master; - VCS.commit id (Cmd {ctac=false;cast=x;cids=l;cqueue=`MainQueue}); + VCS.commit id (Cmd {ctac=false;ceff=true;cast=x;cids=l;cqueue=`MainQueue}); VCS.propagate_sideff (Some x); VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); `Ok @@ -2216,7 +2223,8 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = VCS.branch bname (`Proof ("Classic", VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode "Classic"; end else begin - VCS.commit id (Cmd {ctac=false; cast = x; cids = []; cqueue = `MainQueue}); + VCS.commit id (Cmd {ctac = false; ceff = true; + cast = x; cids = []; cqueue = `MainQueue}); VCS.propagate_sideff (Some x); VCS.checkout_shallowest_proof_branch (); end in diff --git a/test-suite/success/sideff.v b/test-suite/success/sideff.v new file mode 100644 index 0000000000..3c0b81568a --- /dev/null +++ b/test-suite/success/sideff.v @@ -0,0 +1,12 @@ +Definition idw (A : Type) := A. +Lemma foobar : unit. +Proof. + Require Import Program. + apply (const tt tt). +Qed. + +Lemma foobar' : unit. + Lemma aux : forall A : Type, A -> unit. + Proof. intros. pose (foo := idw A). exact tt. Show Universes. Qed. + apply (@aux unit tt). +Qed. -- cgit v1.2.3 From bf1eef119ef8f0e6a2ae4b66165d6e22c1ce9236 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 29 Oct 2015 20:04:58 +0100 Subject: Monotonizing Tactics.change_arg. --- plugins/funind/recdef.ml | 10 +++++++--- tactics/tacinterp.ml | 23 +++++++++++++++-------- tactics/tactics.ml | 10 ++++++---- tactics/tactics.mli | 2 +- 4 files changed, 29 insertions(+), 16 deletions(-) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 685a5e8bdf..dd5381c760 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -38,6 +38,7 @@ open Auto open Eauto open Indfun_common +open Sigma.Notations @@ -687,9 +688,12 @@ let mkDestructEq : observe_tclTHENLIST (str "mkDestructEq") [Simple.generalize new_hyps; (fun g2 -> - Proofview.V82.of_tactic (change_in_concl None - (fun patvars sigma -> - pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2); + let changefun patvars = { run = fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in + Sigma.Unsafe.of_pair (c, sigma) + } in + Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 1673aac0a5..b3a17df360 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -2147,16 +2147,20 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp patvars sigma = + let c_interp patvars = { Sigma.run = begin fun sigma -> let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in + let sigma = Sigma.to_evar_map sigma in let ist = { ist with lfun = lfun' } in - if is_onhyps && is_onconcl - then interp_type ist (pf_env gl) sigma c - else interp_constr ist (pf_env gl) sigma c - in + let (sigma, c) = + if is_onhyps && is_onconcl + then interp_type ist (pf_env gl) sigma c + else interp_constr ist (pf_env gl) sigma c + in + Sigma.Unsafe.of_pair (c, sigma) + end } in (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)) gl end @@ -2171,16 +2175,19 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.tactic begin fun gl -> let (sigma,sign,op) = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in - let c_interp patvars sigma = + let c_interp patvars = { Sigma.run = begin fun sigma -> let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let ist = { ist with lfun = lfun' } in - try interp_constr ist env sigma c + try + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) with e when to_catch e (* Hack *) -> errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") - in + end } in (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) { gl with sigma = sigma } end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 62f3069275..fc453cfaf9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -642,10 +642,10 @@ let e_change_in_hyp redfun (id,where) = Sigma.Unsafe.of_pair (convert_hyp c, sigma) end } -type change_arg = Pattern.patvar_map -> evar_map -> evar_map * constr +type change_arg = Pattern.patvar_map -> constr Sigma.run -let make_change_arg c = - fun pats sigma -> (sigma, replace_vars (Id.Map.bindings pats) c) +let make_change_arg c pats = + { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in @@ -667,7 +667,9 @@ let check_types env sigma mayneedglobalcheck deep newc origc = (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = - let sigma, t' = t sigma in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (t', sigma, p) = t.run sigma in + let sigma = Sigma.to_evar_map sigma in check_types env sigma mayneedglobalcheck deep t' c; let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); diff --git a/tactics/tactics.mli b/tactics/tactics.mli index d62d27ca34..8a4717b7ba 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -125,7 +125,7 @@ val exact_proof : Constrexpr.constr_expr -> tactic type tactic_reduction = env -> evar_map -> constr -> constr -type change_arg = patvar_map -> evar_map -> evar_map * constr +type change_arg = patvar_map -> constr Sigma.run val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> tactic -- cgit v1.2.3 From 48ffb1173702f86fa6cb6392f7876d7da5e5d6b6 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Thu, 29 Oct 2015 20:52:32 +0100 Subject: Make the code of compare functions linear in the number of constructors. This scheme has been advised by @gashe on #79. Interestingly there are several comparison functions in Coq which were already implemented with this scheme. --- library/globnames.ml | 12 ++++++------ printing/printer.ml | 23 +++++++++++------------ 2 files changed, 17 insertions(+), 18 deletions(-) diff --git a/library/globnames.ml b/library/globnames.ml index 3befaa9a94..5fdb6115ee 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -112,12 +112,12 @@ let global_ord_gen ord_cst ord_ind ord_cons x y = | ConstructRef consx, ConstructRef consy -> ord_cons consx consy | VarRef v1, VarRef v2 -> Id.compare v1 v2 - | VarRef _, (ConstRef _ | IndRef _ | ConstructRef _) -> -1 - | ConstRef _, VarRef _ -> 1 - | ConstRef _, (IndRef _ | ConstructRef _) -> -1 - | IndRef _, (VarRef _ | ConstRef _) -> 1 - | IndRef _, ConstructRef _ -> -1 - | ConstructRef _, (VarRef _ | ConstRef _ | IndRef _) -> 1 + | VarRef _, _ -> -1 + | _, VarRef _ -> 1 + | ConstRef _, _ -> -1 + | _, ConstRef _ -> 1 + | IndRef _, _ -> -1 + | _ , IndRef _ -> -1 let global_hash_gen hash_cst hash_ind hash_cons gr = let open Hashset.Combine in diff --git a/printing/printer.ml b/printing/printer.ml index 18e4902255..12782a428a 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -724,18 +724,17 @@ module OrderedContextObject = struct type t = context_object let compare x y = - match x , y with - | Variable i1 , Variable i2 -> Id.compare i1 i2 - | Axiom (k1,_) , Axiom (k2, _) -> con_ord k1 k2 - | Opaque k1 , Opaque k2 -> con_ord k1 k2 - | Transparent k1 , Transparent k2 -> con_ord k1 k2 - | Axiom _ , Variable _ -> 1 - | Opaque _ , Variable _ - | Opaque _ , Axiom _ -> 1 - | Transparent _ , Variable _ - | Transparent _ , Axiom _ - | Transparent _ , Opaque _ -> 1 - | _ , _ -> -1 + match x , y with + | Variable i1 , Variable i2 -> Id.compare i1 i2 + | Variable _ , _ -> -1 + | _ , Variable _ -> 1 + | Axiom (k1,_) , Axiom (k2, _) -> con_ord k1 k2 + | Axiom _ , _ -> -1 + | _ , Axiom _ -> 1 + | Opaque k1 , Opaque k2 -> con_ord k1 k2 + | Opaque _ , _ -> -1 + | _ , Opaque _ -> 1 + | Transparent k1 , Transparent k2 -> con_ord k1 k2 end module ContextObjectSet = Set.Make (OrderedContextObject) -- cgit v1.2.3 From 441ea07e3c8ba56b9e7d44e7802246dc06814415 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Fri, 30 Oct 2015 10:06:24 +0100 Subject: More uniformity in the style of comparison functions. --- library/globnames.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/library/globnames.ml b/library/globnames.ml index 5fdb6115ee..829e2cefcc 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -107,17 +107,16 @@ let global_eq_gen eq_cst eq_ind eq_cons x y = let global_ord_gen ord_cst ord_ind ord_cons x y = if x == y then 0 else match x, y with - | ConstRef cx, ConstRef cy -> ord_cst cx cy - | IndRef indx, IndRef indy -> ord_ind indx indy - | ConstructRef consx, ConstructRef consy -> ord_cons consx consy | VarRef v1, VarRef v2 -> Id.compare v1 v2 - | VarRef _, _ -> -1 | _, VarRef _ -> 1 + | ConstRef cx, ConstRef cy -> ord_cst cx cy | ConstRef _, _ -> -1 | _, ConstRef _ -> 1 + | IndRef indx, IndRef indy -> ord_ind indx indy | IndRef _, _ -> -1 | _ , IndRef _ -> -1 + | ConstructRef consx, ConstructRef consy -> ord_cons consx consy let global_hash_gen hash_cst hash_ind hash_cons gr = let open Hashset.Combine in -- cgit v1.2.3 From 8d99e4bf4c54e9eabb0910740f79375ff399b844 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 30 Oct 2015 16:10:33 +0100 Subject: Fix typo. --- ide/coqOps.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index ba9ab9672e..c7e0810fdc 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -559,7 +559,7 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - logger Pp.Error "You muse close the proof with Qed or Admitted"; + logger Pp.Error "You must close the proof with Qed or Admitted"; self#discard_command_queue queue; conclude [] | `Skip(start,stop), (_,s) :: topstack -> -- cgit v1.2.3 From 77cf18eb844b45776b2ec67be9f71e8dd4ca002c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 30 Oct 2015 11:48:40 -0400 Subject: Add a way to get the right fix_exn in external vernacular commands involving Futures. --- library/declare.ml | 4 ++-- library/declare.mli | 3 ++- stm/stm.ml | 8 ++++++-- stm/stm.mli | 1 + toplevel/obligations.ml | 14 ++++++++------ 5 files changed, 19 insertions(+), 11 deletions(-) diff --git a/library/declare.ml b/library/declare.ml index 63e5a72245..5968fbf38b 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -225,9 +225,9 @@ let declare_constant_common id cst = update_tables c; c -let definition_entry ?(opaque=false) ?(inline=false) ?types +let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Safe_typing.empty_private_constants) body = - { const_entry_body = Future.from_val ((body,Univ.ContextSet.empty), eff); + { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; const_entry_polymorphic = poly; diff --git a/library/declare.mli b/library/declare.mli index fdbd235614..c6119a58ac 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -48,7 +48,8 @@ type internal_flag = | UserIndividualRequest (* Defaut definition entries, transparent with no secctx or proj information *) -val definition_entry : ?opaque:bool -> ?inline:bool -> ?types:types -> +val definition_entry : ?fix_exn:Future.fix_exn -> + ?opaque:bool -> ?inline:bool -> ?types:types -> ?poly:polymorphic -> ?univs:Univ.universe_context -> ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry diff --git a/stm/stm.ml b/stm/stm.ml index 02361c738d..42be4fca71 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -596,6 +596,7 @@ module State : sig ?safe_id:Stateid.t -> ?redefine:bool -> ?cache:Summary.marshallable -> ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit + val fix_exn_ref : (iexn -> iexn) ref val install_cached : Stateid.t -> unit val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool @@ -619,6 +620,7 @@ end = struct (* {{{ *) (* cur_id holds Stateid.dummy in case the last attempt to define a state * failed, so the global state may contain garbage *) let cur_id = ref Stateid.dummy + let fix_exn_ref = ref (fun x -> x) (* helpers *) let freeze_global_state marshallable = @@ -726,8 +728,10 @@ end = struct (* {{{ *) try prerr_endline("defining "^str_id^" (cache="^ if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); - (* set id and good id *) + let good_id = match safe_id with None -> !cur_id | Some id -> id in + fix_exn_ref := exn_on id ~valid:good_id; f (); + fix_exn_ref := (fun x -> x); if cache = `Yes then freeze `No id else if cache = `Shallow then freeze `Shallow id; prerr_endline ("setting cur id to "^str_id); @@ -2559,5 +2563,5 @@ let process_error_hook = Hooks.process_error_hook let interp_hook = Hooks.interp_hook let with_fail_hook = Hooks.with_fail_hook let unreachable_state_hook = Hooks.unreachable_state_hook - +let get_fix_exn () = !State.fix_exn_ref (* vim:set foldmethod=marker: *) diff --git a/stm/stm.mli b/stm/stm.mli index 18ed6fc2e8..0c05c93d4d 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -136,3 +136,4 @@ val process_error_hook : Future.fix_exn Hook.t val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof -> Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t val with_fail_hook : (bool -> (unit -> unit) -> unit) Hook.t +val get_fix_exn : unit -> (Exninfo.iexn -> Exninfo.iexn) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index e488f84f8a..9019f486be 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -508,16 +508,17 @@ let declare_definition prg = let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None) (Evd.evar_universe_context_subst prg.prg_ctx) in let opaque = prg.prg_opaque in + let fix_exn = Stm.get_fix_exn () in let ce = - definition_entry ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) - ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) + definition_entry ~fix_exn + ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) + ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) in progmap_remove prg; !declare_definition_ref prg.prg_name prg.prg_kind ce prg.prg_implicits - (Lemmas.mk_hook (fun l r -> - Lemmas.call_hook (fun exn -> exn) prg.prg_hook l r; r)) - + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r; r)) + open Pp let rec lam_index n t acc = @@ -618,8 +619,9 @@ let declare_obligation prg obl body ty uctx = if get_shrink_obligations () && not poly then shrink_body body else [], body, [||] in + let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in let ce = - { const_entry_body = Future.from_val((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants); + { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; const_entry_secctx = None; const_entry_type = if List.is_empty ctx then ty else None; const_entry_polymorphic = poly; -- cgit v1.2.3 From 668c2edc15aad38229eb46c022571df2cbf31079 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 30 Oct 2015 17:18:12 +0100 Subject: Manually expand red_tactic so that notations do not break reduction tactics. (Fix bug #3654) --- parsing/g_tactic.ml4 | 41 +++++++++++++++++++++++++---------------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index d3eb6bbcbb..c94ac846f1 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -339,21 +339,6 @@ GEXTEND Gram | d = delta_flag -> all_with d ] ] ; - red_tactic: - [ [ IDENT "red" -> Red false - | IDENT "hnf" -> Hnf - | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) - | IDENT "cbv"; s = strategy_flag -> Cbv s - | IDENT "cbn"; s = strategy_flag -> Cbn s - | IDENT "lazy"; s = strategy_flag -> Lazy s - | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) - | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po - | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po - | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul - | IDENT "fold"; cl = LIST1 constr -> Fold cl - | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl ] ] - ; - (* This is [red_tactic] including possible extensions *) red_expr: [ [ IDENT "red" -> Red false | IDENT "hnf" -> Hnf @@ -676,7 +661,31 @@ GEXTEND Gram TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) (* Conversion *) - | r = red_tactic; cl = clause_dft_concl -> TacAtom (!@loc, TacReduce (r, cl)) + | IDENT "red"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Red false, cl)) + | IDENT "hnf"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Hnf, cl)) + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl)) + | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv s, cl)) + | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbn s, cl)) + | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Lazy s, cl)) + | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl)) + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvVm po, cl)) + | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvNative po, cl)) + | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Unfold ul, cl)) + | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Fold l, cl)) + | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Pattern pl, cl)) + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> let p,cl = merge_occurrences (!@loc) cl oc in -- cgit v1.2.3 From b49c80406f518d273056b2143f55e23deeea2813 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 30 Oct 2015 18:15:58 +0100 Subject: Command.declare_definition: grab the fix_exn early (follows 77cf18e) When a future is fully forced (joined), the fix_exn is dropped, since joined futures are values (hence they cannot raise exceptions). When a future for a transparent definition enters the environment it is joined. If one needs to pick its fix_exn, he should do it before that. --- toplevel/command.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/toplevel/command.ml b/toplevel/command.ml index 73fd3d1a4a..3d338ee0a3 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -154,6 +154,7 @@ let set_declare_definition_hook = (:=) declare_definition_hook let get_declare_definition_hook () = !declare_definition_hook let declare_definition ident (local, p, k) ce pl imps hook = + let fix_exn = Future.fix_exn_of ce.const_entry_body in let () = !declare_definition_hook ce in let r = match local with | Discharge when Lib.sections_are_opened () -> @@ -170,7 +171,7 @@ let declare_definition ident (local, p, k) ce pl imps hook = gr | Discharge | Local | Global -> declare_global_definition ident ce local k pl imps in - Lemmas.call_hook (Future.fix_exn_of ce.const_entry_body) hook local r + Lemmas.call_hook fix_exn hook local r let _ = Obligations.declare_definition_ref := (fun i k c imps hook -> declare_definition i k c [] imps hook) -- cgit v1.2.3 From 559c0a4a40410745f73822e893b3d1581056ea7a Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 2 Nov 2015 15:01:15 +0100 Subject: STM: never reopen a branch containing side effects --- stm/stm.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/stm/stm.ml b/stm/stm.ml index 42be4fca71..a6a64f2094 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2317,6 +2317,12 @@ let edit_at id = | { step = `Fork _ } -> false | { next } -> aux next in aux (VCS.get_branch_pos (VCS.current_branch ())) in + let rec is_pure id = + let view = VCS.visit id in + match view.step with + | `Cmd _ -> is_pure view.next + | `Fork _ -> true + | _ -> false in let is_ancestor_of_cur_branch id = Vcs_.NodeSet.mem id (VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in @@ -2377,7 +2383,7 @@ let edit_at id = | _, Some _, None -> assert false | false, Some (qed_id,start), Some(mode,bn) -> let tip = VCS.cur_tip () in - if has_failed qed_id && not !Flags.async_proofs_never_reopen_branch + if has_failed qed_id && is_pure (VCS.visit qed_id).next && not !Flags.async_proofs_never_reopen_branch then reopen_branch start id mode qed_id tip bn else backto id (Some bn) | true, Some (qed_id,_), Some(mode,bn) -> -- cgit v1.2.3 From 6e376c8097d75b6e63a7e52332a721f7928992e9 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 2 Nov 2015 15:01:58 +0100 Subject: STM: fix undo into a branch containing side effects The "master" label used to be reset to the wrong id --- stm/stm.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/stm/stm.ml b/stm/stm.ml index a6a64f2094..89034706a4 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2333,7 +2333,9 @@ let edit_at id = let rec master_for_br root tip = if Stateid.equal tip Stateid.initial then tip else match VCS.visit tip with - | { step = (`Fork _ | `Sideff _ | `Qed _) } -> tip + | { step = (`Fork _ | `Qed _) } -> tip + | { step = `Sideff (`Ast(_,id)) } -> id + | { step = `Sideff _ } -> tip | { next } -> master_for_br root next in let reopen_branch start at_id mode qed_id tip old_branch = let master_id, cancel_switch, keep = -- cgit v1.2.3 From 69be6a29cf9f774cb4afe94d76b157ba50984c1d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 31 Oct 2015 15:12:02 +0100 Subject: Made that the syntax [id]:tac also applies to the shelve, which is after all its main interest! --- proofs/proofview.ml | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index de6d605670..4fc0c164e3 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -384,20 +384,23 @@ let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t let tclFOCUSID id t = let open Proof in Pv.get >>= fun initial -> - let rec aux n = function - | [] -> tclZERO (NoSuchGoals 1) - | g::l -> - if Names.Id.equal (Evd.evar_ident g initial.solution) id then - let (focused,context) = focus n n initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - else - aux (n+1) l in - aux 1 initial.comb - - + try + let ev = Evd.evar_key id initial.solution in + try + let n = CList.index Evar.equal ev initial.comb in + (* goal is already under focus *) + let (focused,context) = focus n n initial in + Pv.set focused >> + t >>= fun result -> + Pv.modify (fun next -> unfocus context next) >> + return result + with Not_found -> + (* otherwise, save current focus and work purely on the shelve *) + Comb.set [ev] >> + t >>= fun result -> + Comb.set initial.comb >> + return result + with Not_found -> tclZERO (NoSuchGoals 1) (** {7 Dispatching on goals} *) -- cgit v1.2.3 From 4e643d134f02cfa9a73754c3cf48048541324834 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 31 Oct 2015 15:49:09 +0100 Subject: Adding syntax "Show id" to show goal named id (shelved or not). --- CHANGES | 2 +- intf/vernacexpr.mli | 3 ++- parsing/g_proofs.ml4 | 4 +++- printing/ppvernac.ml | 3 ++- printing/printer.ml | 21 ++++++++++++++++----- printing/printer.mli | 3 ++- toplevel/vernacentries.ml | 1 + 7 files changed, 27 insertions(+), 10 deletions(-) diff --git a/CHANGES b/CHANGES index cf0f4446f4..019c6cdb24 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,7 @@ Vernacular commands - New option "Strict Universe Declaration", set by default. It enforces the declaration of all polymorphic universes appearing in a definition when introducing it. +- New command "Show id" to show goal named id. Tactics @@ -36,7 +37,6 @@ Tactics - Hints costs are now correctly taken into account (potential source of incompatibilities). - API - Some functions from pretyping/typing.ml and their derivatives were potential diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index f89f076b5f..99264dbe0a 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -40,7 +40,8 @@ type scope_name = string type goal_reference = | OpenSubgoals | NthGoal of int - | GoalId of goal_identifier + | GoalId of Id.t + | GoalUid of goal_identifier type printable = | PrintTables diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 7f5459bfa6..017f0ea50b 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -73,8 +73,10 @@ GEXTEND Gram | IDENT "Unfocused" -> VernacUnfocused | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n)) + | IDENT "Show"; id = ident -> VernacShow (ShowGoal (GoalId id)) + | IDENT "Show"; IDENT "Goal" -> VernacShow (ShowGoal (GoalId (Names.Id.of_string "Goal"))) | IDENT "Show"; IDENT "Goal"; n = string -> - VernacShow (ShowGoal (GoalId n)) + VernacShow (ShowGoal (GoalUid n)) | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> VernacShow (ShowGoalImplicitly n) | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 00c276bdbe..72b9cafe3f 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -594,7 +594,8 @@ module Make let pr_goal_reference = function | OpenSubgoals -> mt () | NthGoal n -> spc () ++ int n - | GoalId n -> spc () ++ str n in + | GoalId id -> spc () ++ pr_id id + | GoalUid n -> spc () ++ str n in let pr_showable = function | ShowGoal n -> keyword "Show" ++ pr_goal_reference n | ShowGoalImplicitly n -> keyword "Show Implicit Arguments" ++ pr_opt int n diff --git a/printing/printer.ml b/printing/printer.ml index 202b4f2bc7..2e112f9ace 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -455,14 +455,17 @@ let pr_ne_evar_set hd tl sigma l = else mt () +let pr_selected_subgoal name sigma g = + let pg = default_pr_goal { sigma=sigma ; it=g; } in + v 0 (str "subgoal " ++ name ++ pr_goal_tag g ++ pr_goal_name sigma g + ++ str " is:" ++ cut () ++ pg) + let default_pr_subgoal n sigma = let rec prrec p = function | [] -> error "No such goal." | g::rest -> if Int.equal p 1 then - let pg = default_pr_goal { sigma=sigma ; it=g; } in - v 0 (str "subgoal " ++ int n ++ pr_goal_tag g ++ pr_goal_name sigma g - ++ str " is:" ++ cut () ++ pg) + pr_selected_subgoal (int n) sigma g else prrec (p-1) rest in @@ -652,9 +655,17 @@ let pr_nth_open_subgoal n = let pr_goal_by_id id = let p = Proof_global.give_me_the_proof () in - let g = Goal.get_by_uid id in + try + Proof.in_proof p (fun sigma -> + let g = Evd.evar_key id sigma in + pr_selected_subgoal (pr_id id) sigma g) + with Not_found -> error "No such goal." + +let pr_goal_by_uid uid = + let p = Proof_global.give_me_the_proof () in + let g = Goal.get_by_uid uid in let pr gs = - v 0 (str "goal / evar " ++ str id ++ str " is:" ++ cut () + v 0 (str "goal / evar " ++ str uid ++ str " is:" ++ cut () ++ pr_goal gs) in try diff --git a/printing/printer.mli b/printing/printer.mli index 0a44e4f103..5c60b89366 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -176,7 +176,8 @@ module ContextObjectMap : CMap.ExtS val pr_assumptionset : env -> Term.types ContextObjectMap.t -> std_ppcmds -val pr_goal_by_id : string -> std_ppcmds +val pr_goal_by_id : Id.t -> std_ppcmds +val pr_goal_by_uid : string -> std_ppcmds type printer_pr = { pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds; diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 31bfc004a8..b6a1a53fa8 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1786,6 +1786,7 @@ let vernac_show = function | OpenSubgoals -> pr_open_subgoals () | NthGoal n -> pr_nth_open_subgoal n | GoalId id -> pr_goal_by_id id + | GoalUid id -> pr_goal_by_uid id in msg_notice info | ShowGoalImplicitly None -> -- cgit v1.2.3 From 5a5f2b4253b5834e09f43cb36a81ce6f53cc2da3 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 2 Nov 2015 16:39:03 +0100 Subject: Follow-up fix on Enrico's 6e376c8097d75b6e, with Enrico. --- stm/stm.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index 89034706a4..14142aa0c5 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2317,12 +2317,17 @@ let edit_at id = | { step = `Fork _ } -> false | { next } -> aux next in aux (VCS.get_branch_pos (VCS.current_branch ())) in - let rec is_pure id = + let rec is_pure_aux id = let view = VCS.visit id in match view.step with - | `Cmd _ -> is_pure view.next + | `Cmd _ -> is_pure_aux view.next | `Fork _ -> true | _ -> false in + let is_pure id = + match (VCS.visit id).step with + | `Qed (_,last_step) -> is_pure_aux last_step + | _ -> assert false + in let is_ancestor_of_cur_branch id = Vcs_.NodeSet.mem id (VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in @@ -2385,7 +2390,7 @@ let edit_at id = | _, Some _, None -> assert false | false, Some (qed_id,start), Some(mode,bn) -> let tip = VCS.cur_tip () in - if has_failed qed_id && is_pure (VCS.visit qed_id).next && not !Flags.async_proofs_never_reopen_branch + if has_failed qed_id && is_pure qed_id && not !Flags.async_proofs_never_reopen_branch then reopen_branch start id mode qed_id tip bn else backto id (Some bn) | true, Some (qed_id,_), Some(mode,bn) -> -- cgit v1.2.3 From 739d8e50b3681491bd82b516dbbba892ac5b424b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 2 Nov 2015 13:48:53 -0500 Subject: Refresh rigid universes as well, and in 8.4 compatibility mode, make them rigid to disallow minimization. --- pretyping/evarsolve.ml | 18 +++++++++++------- pretyping/evarutil.ml | 6 ++++-- test-suite/bugs/closed/4394.v | 13 +++++++++++++ 3 files changed, 28 insertions(+), 9 deletions(-) create mode 100644 test-suite/bugs/closed/4394.v diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index f06207c3b9..3c3720388f 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -42,11 +42,15 @@ let get_polymorphic_positions f = templ.template_param_levels) | _ -> assert false -(** - forall A (l : list A) -> typeof A = Type i <= Datatypes.j -> i not refreshed - hd ?A (l : list t) -> A = t +let default_universe_status u = + if Flags.version_less_or_equal Flags.V8_4 then univ_rigid + else u + +let refresh_level evd s = + match Evd.is_sort_variable evd s with + | None -> true + | Some l -> not (Evd.is_flexible_level evd l) -*) let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = let evdref = ref evd in let modified = ref false in @@ -54,10 +58,10 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = match kind_of_term t with | Sort (Type u as s) when (match Univ.universe_level u with - | None -> true - | Some l -> not onlyalg && Option.is_empty (Evd.is_sort_variable evd s)) -> + | None -> true + | Some l -> not onlyalg && refresh_level evd s) -> let status = if inferred then Evd.univ_flexible_alg else Evd.univ_flexible in - let s' = evd_comb0 (new_sort_variable status) evdref in + let s' = evd_comb0 (new_sort_variable (default_universe_status status)) evdref in let evd = if dir then set_leq_sort env !evdref s' s else set_leq_sort env !evdref s s' diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index d3d6901b66..b27803bd05 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -715,7 +715,8 @@ let define_pure_evar_as_product evd evk = let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in let concl = whd_betadeltaiota evenv evd evi.evar_concl in let s = destSort concl in - let evd1,(dom,u1) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in + let evd1,(dom,u1) = + new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in @@ -724,8 +725,9 @@ let define_pure_evar_as_product evd evk = (* Impredicative product, conclusion must fall in [Prop]. *) new_evar newenv evd1 concl ~src ~filter else + let status = univ_flexible_alg in let evd3, (rng, srng) = - new_type_evar newenv evd1 univ_flexible_alg ~src ~filter in + new_type_evar newenv evd1 status ~src ~filter in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in evd3, rng diff --git a/test-suite/bugs/closed/4394.v b/test-suite/bugs/closed/4394.v new file mode 100644 index 0000000000..751f1e697d --- /dev/null +++ b/test-suite/bugs/closed/4394.v @@ -0,0 +1,13 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) +Require Import Equality List. +Unset Strict Universe Declaration. +Inductive Foo I A := foo (B : Type) : A -> I B -> Foo I A. +Definition Family := Type -> Type. +Definition fooFamily family : Family := Foo family. +Inductive Empty {T} : T -> Prop := . +Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) nil)) (b : unit) : + Empty (a, b) -> False. +Proof. + intro e. + dependent induction e. +Qed. \ No newline at end of file -- cgit v1.2.3 From c920b420a27bd561967e316dcaca41d5e019a7b8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 2 Nov 2015 14:41:17 -0500 Subject: Fix bug #4151: discrepancy between exact and eexact/eassumption. --- pretyping/evd.ml | 10 +- pretyping/evd.mli | 9 +- tactics/eauto.ml4 | 3 +- tactics/tactics.ml | 5 +- test-suite/bugs/closed/4151.v | 403 ++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 413 insertions(+), 17 deletions(-) create mode 100644 test-suite/bugs/closed/4151.v diff --git a/pretyping/evd.ml b/pretyping/evd.ml index db6b366b75..82c068be07 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1369,7 +1369,7 @@ let update_sigma_env evd env = (* Conversion w.r.t. an evar map and its local universes. *) -let conversion_gen env evd pb t u = +let test_conversion_gen env evd pb t u = match pb with | Reduction.CONV -> Reduction.trans_conv_universes @@ -1379,14 +1379,8 @@ let conversion_gen env evd pb t u = full_transparent_state ~evars:(existential_opt_value evd) env evd.universes.uctx_universes t u -(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *) -(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *) - -let conversion env d pb t u = - conversion_gen env d pb t u; d - let test_conversion env d pb t u = - try conversion_gen env d pb t u; true + try test_conversion_gen env d pb t u; true with _ -> false let eq_constr_univs evd t u = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 671d62021a..5c508419a4 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -573,14 +573,11 @@ val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> Globnames.global_reference -> evar_map * constr (******************************************************************** - Conversion w.r.t. an evar map: might generate universe unifications - that are kept in the evarmap. - Raises [NotConvertible]. *) - -val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map + Conversion w.r.t. an evar map, not unifying universes. See + [Reductionops.infer_conv] for conversion up-to universes. *) val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool -(** This one forgets about the assignemts of universes. *) +(** WARNING: This does not allow unification of universes *) val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool (** Syntactic equality up to universes, recording the associated constraints *) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 7b4b6f9163..aa285fa98a 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -33,7 +33,8 @@ DECLARE PLUGIN "eauto" let eauto_unif_flags = auto_flags_of_state full_transparent_state -let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_unsafe_type_of gl c) and t2 = pf_concl gl in +let e_give_exact ?(flags=eauto_unif_flags) c gl = + let t1 = (pf_unsafe_type_of gl c) and t2 = pf_concl gl in if occur_existential t1 || occur_existential t2 then tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl else Proofview.V82.of_tactic (exact_check c) gl diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0b920066fd..56896bbc42 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -223,8 +223,9 @@ let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> try - let sigma = Tacmach.New.pf_apply Evd.conversion gl pb x y in - Proofview.Unsafe.tclEVARS sigma + let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in + if b then Proofview.Unsafe.tclEVARS sigma + else Tacticals.New.tclFAIL 0 (str "Not convertible") with (* Reduction.NotConvertible *) _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") diff --git a/test-suite/bugs/closed/4151.v b/test-suite/bugs/closed/4151.v new file mode 100644 index 0000000000..fec64555f4 --- /dev/null +++ b/test-suite/bugs/closed/4151.v @@ -0,0 +1,403 @@ +Lemma foo (H : forall A, A) : forall A, A. + Show Universes. + eexact H. +Qed. + +(* File reduced by coq-bug-finder from original input, then from 6390 lines to 397 lines *) +(* coqc version 8.5beta1 (March 2015) compiled on Mar 17 2015 12:34:25 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (1b3759e78f227eb85a128c58b8ce8c11509dd8c3) *) +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Import Coq.Lists.SetoidList. +Require Export Coq.Program.Program. + +Global Set Implicit Arguments. +Global Set Asymmetric Patterns. + +Fixpoint combine_sig_helper {T} {P : T -> Prop} (ls : list T) : (forall x, In x ls -> P x) -> list (sig P). + admit. +Defined. + +Lemma Forall_forall1_transparent_helper_1 {A P} {x : A} {xs : list A} {l : list A} + (H : Forall P l) (H' : x::xs = l) +: P x. + admit. +Defined. +Lemma Forall_forall1_transparent_helper_2 {A P} {x : A} {xs : list A} {l : list A} + (H : Forall P l) (H' : x::xs = l) +: Forall P xs. + admit. +Defined. + +Fixpoint Forall_forall1_transparent {A} (P : A -> Prop) (l : list A) {struct l} +: Forall P l -> forall x, In x l -> P x + := match l as l return Forall P l -> forall x, In x l -> P x with + | nil => fun _ _ f => match f : False with end + | x::xs => fun H x' H' => + match H' with + | or_introl H'' => eq_rect x + P + (Forall_forall1_transparent_helper_1 H eq_refl) + _ + H'' + | or_intror H'' => @Forall_forall1_transparent A P xs (Forall_forall1_transparent_helper_2 H eq_refl) _ H'' + end + end. + +Definition combine_sig {T P ls} (H : List.Forall P ls) : list (@sig T P) + := combine_sig_helper ls (@Forall_forall1_transparent T P ls H). +Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type + := match ls with + | nil => P nil + | x::xs => (P (x::xs) * Forall_tails P xs)%type + end. + +Record string_like (CharType : Type) := + { + String :> Type; + Singleton : CharType -> String where "[ x ]" := (Singleton x); + Empty : String; + Concat : String -> String -> String where "x ++ y" := (Concat x y); + bool_eq : String -> String -> bool; + bool_eq_correct : forall x y : String, bool_eq x y = true <-> x = y; + Length : String -> nat; + Associativity : forall x y z, (x ++ y) ++ z = x ++ (y ++ z); + LeftId : forall x, Empty ++ x = x; + RightId : forall x, x ++ Empty = x; + Singleton_Length : forall x, Length (Singleton x) = 1; + Length_correct : forall s1 s2, Length s1 + Length s2 = Length (s1 ++ s2); + Length_Empty : Length Empty = 0; + Empty_Length : forall s1, Length s1 = 0 -> s1 = Empty; + Not_Singleton_Empty : forall x, Singleton x <> Empty; + SplitAt : nat -> String -> String * String; + SplitAt_correct : forall n s, fst (SplitAt n s) ++ snd (SplitAt n s) = s; + SplitAt_concat_correct : forall s1 s2, SplitAt (Length s1) (s1 ++ s2) = (s1, s2); + SplitAtLength_correct : forall n s, Length (fst (SplitAt n s)) = min (Length s) n + }. + +Delimit Scope string_like_scope with string_like. +Bind Scope string_like_scope with String. +Arguments Length {_%type_scope _} _%string_like. +Notation "[[ x ]]" := (@Singleton _ _ x) : string_like_scope. +Infix "++" := (@Concat _ _) : string_like_scope. +Infix "=s" := (@bool_eq _ _) (at level 70, right associativity) : string_like_scope. + +Definition str_le {CharType} {String : string_like CharType} (s1 s2 : String) + := Length s1 < Length s2 \/ s1 = s2. +Infix "≤s" := str_le (at level 70, right associativity). + +Record StringWithSplitState {CharType} (String : string_like CharType) (split_stateT : String -> Type) := + { string_val :> String; + state_val : split_stateT string_val }. + +Module Export ContextFreeGrammar. + Require Import Coq.Strings.String. + + Section cfg. + Variable CharType : Type. + + Section definitions. + + Inductive item := + | Terminal (_ : CharType) + | NonTerminal (_ : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions; + Start_productions :> productions := Lookup Start_symbol; + Valid_nonterminals : list string; + Valid_productions : list productions := map Lookup Valid_nonterminals + }. + End definitions. + + End cfg. + +End ContextFreeGrammar. +Module Export BaseTypes. + Import Coq.Strings.String. + + Local Open Scope string_like_scope. + + Inductive any_grammar CharType := + | include_item (_ : item CharType) + | include_production (_ : production CharType) + | include_productions (_ : productions CharType) + | include_nonterminal (_ : string). + Global Coercion include_item : item >-> any_grammar. + Global Coercion include_production : production >-> any_grammar. + + Section recursive_descent_parser. + Context {CharType : Type} + {String : string_like CharType} + {G : grammar CharType}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + initial_nonterminals_data : nonterminals_listT; + is_valid_nonterminal : nonterminals_listT -> string -> bool; + remove_nonterminal : nonterminals_listT -> string -> nonterminals_listT; + nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal = true + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + ntl_wf : well_founded nonterminals_listT_R }. + + Class parser_computational_types_dataT := + { predata :> parser_computational_predataT; + split_stateT : String -> nonterminals_listT -> any_grammar CharType -> String -> Type }. + + Class parser_computational_dataT' `{parser_computational_types_dataT} := + { split_string_for_production + : forall (str0 : String) (valid : nonterminals_listT) (it : item CharType) (its : production CharType) (str : StringWithSplitState String (split_stateT str0 valid (it::its : production CharType))), + list (StringWithSplitState String (split_stateT str0 valid it) + * StringWithSplitState String (split_stateT str0 valid its)); + split_string_for_production_correct + : forall str0 valid it its str, + let P f := List.Forall f (@split_string_for_production str0 valid it its str) in + P (fun s1s2 => (fst s1s2 ++ snd s1s2 =s str) = true) }. + End recursive_descent_parser. + +End BaseTypes. +Import Coq.Strings.String. + +Section cfg. + Context CharType (String : string_like CharType) (G : grammar CharType). + Context (names_listT : Type) + (initial_names_data : names_listT) + (is_valid_name : names_listT -> string -> bool) + (remove_name : names_listT -> string -> names_listT) + (names_listT_R : names_listT -> names_listT -> Prop) + (remove_name_dec : forall ls name, + is_valid_name ls name = true + -> names_listT_R (remove_name ls name) ls) + (remove_name_1 + : forall ls ps ps', + is_valid_name (remove_name ls ps) ps' = true + -> is_valid_name ls ps' = true) + (remove_name_2 + : forall ls ps ps', + is_valid_name (remove_name ls ps) ps' = false + <-> is_valid_name ls ps' = false \/ ps = ps') + (ntl_wf : well_founded names_listT_R). + + Inductive minimal_parse_of + : forall (str0 : String) (valid : names_listT) + (str : String), + productions CharType -> Type := + | MinParseHead : forall str0 valid str pat pats, + @minimal_parse_of_production str0 valid str pat + -> @minimal_parse_of str0 valid str (pat::pats) + | MinParseTail : forall str0 valid str pat pats, + @minimal_parse_of str0 valid str pats + -> @minimal_parse_of str0 valid str (pat::pats) + with minimal_parse_of_production + : forall (str0 : String) (valid : names_listT) + (str : String), + production CharType -> Type := + | MinParseProductionNil : forall str0 valid, + @minimal_parse_of_production str0 valid (Empty _) nil + | MinParseProductionCons : forall str0 valid str strs pat pats, + str ++ strs ≤s str0 + -> @minimal_parse_of_item str0 valid str pat + -> @minimal_parse_of_production str0 valid strs pats + -> @minimal_parse_of_production str0 valid (str ++ strs) (pat::pats) + with minimal_parse_of_item + : forall (str0 : String) (valid : names_listT) + (str : String), + item CharType -> Type := + | MinParseTerminal : forall str0 valid x, + @minimal_parse_of_item str0 valid [[ x ]]%string_like (Terminal x) + | MinParseNonTerminal + : forall str0 valid str name, + @minimal_parse_of_name str0 valid str name + -> @minimal_parse_of_item str0 valid str (NonTerminal CharType name) + with minimal_parse_of_name + : forall (str0 : String) (valid : names_listT) + (str : String), + string -> Type := + | MinParseNonTerminalStrLt + : forall str0 valid name str, + Length str < Length str0 + -> is_valid_name initial_names_data name = true + -> @minimal_parse_of str initial_names_data str (Lookup G name) + -> @minimal_parse_of_name str0 valid str name + | MinParseNonTerminalStrEq + : forall str valid name, + is_valid_name initial_names_data name = true + -> is_valid_name valid name = true + -> @minimal_parse_of str (remove_name valid name) str (Lookup G name) + -> @minimal_parse_of_name str valid str name. +End cfg. + +Local Coercion is_true : bool >-> Sortclass. + +Local Open Scope string_like_scope. + +Section general. + Context {CharType} {String : string_like CharType} {G : grammar CharType}. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_stateT : String -> Type; + data' :> _ := {| BaseTypes.predata := predata ; BaseTypes.split_stateT := fun _ _ _ => split_stateT |}; + split_string_for_production + : forall it its, + StringWithSplitState String split_stateT + -> list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT); + split_string_for_production_correct + : forall it its (str : StringWithSplitState String split_stateT), + let P f := List.Forall f (split_string_for_production it its str) in + P (fun s1s2 => + (fst s1s2 ++ snd s1s2 =s str) = true); + premethods :> parser_computational_dataT' + := @Build_parser_computational_dataT' + _ String data' + (fun _ _ => split_string_for_production) + (fun _ _ => split_string_for_production_correct) }. + + Definition split_list_completeT `{data : boolean_parser_dataT} + {str0 valid} + (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) + (split_list : list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT)) + (it : item CharType) (its : production CharType) + := ({ s1s2 : String * String + & (fst s1s2 ++ snd s1s2 =s str) + * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) + * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type) + -> ({ s1s2 : StringWithSplitState String split_stateT * StringWithSplitState String split_stateT + & (In s1s2 split_list) + * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) + * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type). +End general. + +Section recursive_descent_parser. + Context {CharType} + {String : string_like CharType} + {G : grammar CharType}. + Context `{data : @boolean_parser_dataT _ String}. + + Section bool. + Section parts. + Definition parse_item + (str_matches_nonterminal : string -> bool) + (str : StringWithSplitState String split_stateT) + (it : item CharType) + : bool + := match it with + | Terminal ch => [[ ch ]] =s str + | NonTerminal nt => str_matches_nonterminal nt + end. + + Section production. + Context {str0} + (parse_nonterminal + : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Fixpoint parse_production + (str : StringWithSplitState String split_stateT) + (pf : str ≤s str0) + (prod : production CharType) + : bool. + Proof. + refine + match prod with + | nil => + + str =s Empty _ + | it::its + => let parse_production' := fun str pf => parse_production str pf its in + fold_right + orb + false + (let mapF f := map f (combine_sig (split_string_for_production_correct it its str)) in + mapF (fun s1s2p => + (parse_item + (parse_nonterminal (fst (proj1_sig s1s2p)) _) + (fst (proj1_sig s1s2p)) + it) + && parse_production' (snd (proj1_sig s1s2p)) _)%bool) + end; + revert pf; clear; intros; admit. + Defined. + End production. + + End parts. + End bool. +End recursive_descent_parser. + +Section sound. + Context CharType (String : string_like CharType) (G : grammar CharType). + Context `{data : @boolean_parser_dataT CharType String}. + + Section production. + Context (str0 : String) + (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Definition parse_nonterminal_completeT P + := forall valid (str : StringWithSplitState String split_stateT) pf nonterminal (H_sub : P str0 valid nonterminal), + minimal_parse_of_name _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal + -> @parse_nonterminal str pf nonterminal = true. + + Lemma parse_production_complete + valid Pv + (parse_nonterminal_complete : parse_nonterminal_completeT Pv) + (Hinit : forall str (pf : str ≤s str0) nonterminal, + minimal_parse_of_name String G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal + -> Pv str0 valid nonterminal) + (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) + (prod : production CharType) + (split_string_for_production_complete' + : forall str0 valid str pf, + Forall_tails + (fun prod' => + match prod' return Type with + | nil => True + | it::its => split_list_completeT (G := G) (valid := valid) (str0 := str0) str pf (split_string_for_production it its str) it its + end) + prod) + : minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str prod + -> parse_production parse_nonterminal str pf prod = true. + admit. + Defined. + End production. + Context (str0 : String) + (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Goal forall (a : production CharType), + (forall (str1 : String) (valid : nonterminals_listT) + (str : StringWithSplitState String split_stateT) + (pf : str ≤s str1), + Forall_tails + (fun prod' : list (item CharType) => + match prod' with + | [] => True + | it :: its => + split_list_completeT (G := G) (valid := valid) str pf + (split_string_for_production it its str) it its + end) a) -> + forall (str : String) (pf : str ≤s str0) (st : split_stateT str), + parse_production parse_nonterminal + {| string_val := str; state_val := st |} pf a = true. + Proof. + intros a X **. + eapply parse_production_complete. + Focus 3. + exact X. + Undo. + assumption. + Undo. + eassumption. (* no applicable tactic *) \ No newline at end of file -- cgit v1.2.3 From dc65d720f3928fd987f82e1571521b52844dd248 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 2 Nov 2015 15:22:07 -0500 Subject: Fix bug #4397: refreshing types in abstract_generalize. --- tactics/tactics.ml | 37 ++++++++++++++++++++++++------------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 56896bbc42..7756553e2d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3253,7 +3253,7 @@ let is_defined_variable env id = match lookup_named id env with | (_, Some _, _) -> true let abstract_args gl generalize_vars dep id defined f args = - let sigma = project gl in + let sigma = ref (project gl) in let env = pf_env gl in let concl = pf_concl gl in let dep = dep || dependent (mkVar id) concl in @@ -3270,11 +3270,12 @@ let abstract_args gl generalize_vars dep id defined f args = *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let (name, _, ty), arity = - let rel, c = Reductionops.splay_prod_n env sigma 1 prod in + let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in List.hd rel, c in let argty = pf_unsafe_type_of gl arg in - let ty = (* refresh_universes_strict *) ty in + let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in + let () = sigma := sigma' in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in @@ -3313,8 +3314,9 @@ let abstract_args gl generalize_vars dep id defined f args = true, mkApp (f', before), after in if dogen then + let tyf' = pf_unsafe_type_of gl f' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (pf_unsafe_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' + Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = @@ -3323,9 +3325,12 @@ let abstract_args gl generalize_vars dep id defined f args = hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in - let body, c' = if defined then Some c', typ_of ctxenv Evd.empty c' else None, c' in - Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls, - dep, succ (List.length ctx), vars) + let body, c' = + if defined then Some c', typ_of ctxenv !sigma c' + else None, c' + in + let term = make_abstract_generalize gl id concl dep ctx body c' eqs args refls in + Some (term, !sigma, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = @@ -3347,20 +3352,26 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in match newc with | None -> Proofview.tclUNIT () - | Some (newc, dep, n, vars) -> + | Some (newc, sigma, dep, n, vars) -> let tac = if dep then - Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; - Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))] - else - Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); Proofview.V82.tactic (clear [id]); Tacticals.New.tclDO n intro] + Tacticals.New.tclTHENLIST + [Proofview.Unsafe.tclEVARS sigma; + Proofview.V82.tactic (refine newc); + rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; + Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))] + else Tacticals.New.tclTHENLIST + [Proofview.Unsafe.tclEVARS sigma; + Proofview.V82.tactic (refine newc); + Proofview.V82.tactic (clear [id]); + Tacticals.New.tclDO n intro] in if List.is_empty vars then tac else Tacticals.New.tclTHEN tac (Tacticals.New.tclFIRST [revert vars ; Proofview.V82.tactic (fun gl -> tclMAP (fun id -> - tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)]) + tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)]) end let rec compare_upto_variables x y = -- cgit v1.2.3 From 5f8f9e5b8eb22a413090229bc317fc2f36c053ac Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Fri, 30 Oct 2015 13:32:42 -0400 Subject: Update compatibility file for some of bug #4392 Now doing ```coq Tactic Notation "left" "~" := left. Tactic Notation "left" "*" := left. ``` will no longer break the `left` tactic in Coq 8.4. List obtained via ``` grep -o '^ \[[^]]*\]' tactics/coretactics.ml4 | sed s'/^ \[ \(.*\) \]/Tactic Notation \1 := \1./g' | sed s'/\(:=.*\)"/\1/g' | sed s'/\(:=.*\)"/\1/g' | sed s'/\(:=.*\)"/\1/g' | sed s'/\(:=.*\)"/\1/g' | sed s'/\(:=.*\) \(constr\|bindings\|constr_with_bindings\|quantified_hypothesis\|ne_hyp_list\)(\([^)]*\))/\1 \3/g' ```--- theories/Compat/Coq84.v | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index 83016976e8..b04d5168f2 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -34,6 +34,27 @@ Tactic Notation "constructor" := constructor_84. Tactic Notation "constructor" int_or_var(n) := constructor_84_n n. Tactic Notation "constructor" "(" tactic(tac) ")" := constructor_84_tac tac. +(** Some tactic notations do not factor well with tactics; we add global parsing entries for some tactics that would otherwise be overwritten by custom variants. See https://coq.inria.fr/bugs/show_bug.cgi?id=4392. *) +Tactic Notation "reflexivity" := reflexivity. +Tactic Notation "assumption" := assumption. +Tactic Notation "etransitivity" := etransitivity. +Tactic Notation "cut" constr(c) := cut c. +Tactic Notation "exact_no_check" constr(c) := exact_no_check c. +Tactic Notation "vm_cast_no_check" constr(c) := vm_cast_no_check c. +Tactic Notation "casetype" constr(c) := casetype c. +Tactic Notation "elimtype" constr(c) := elimtype c. +Tactic Notation "lapply" constr(c) := lapply c. +Tactic Notation "transitivity" constr(c) := transitivity c. +Tactic Notation "left" := left. +Tactic Notation "eleft" := eleft. +Tactic Notation "right" := right. +Tactic Notation "eright" := eright. +Tactic Notation "constructor" := constructor. +Tactic Notation "econstructor" := econstructor. +Tactic Notation "symmetry" := symmetry. +Tactic Notation "split" := split. +Tactic Notation "esplit" := esplit. + Global Set Regular Subst Tactic. (** Some names have changed in the standard library, so we add aliases. *) -- cgit v1.2.3 From f4ff8f4f8b0bd2c721e4984faf7360d6fab93b05 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 4 Nov 2015 09:44:56 +0100 Subject: Test file for #4397. --- test-suite/bugs/closed/4397.v | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 test-suite/bugs/closed/4397.v diff --git a/test-suite/bugs/closed/4397.v b/test-suite/bugs/closed/4397.v new file mode 100644 index 0000000000..3566353d84 --- /dev/null +++ b/test-suite/bugs/closed/4397.v @@ -0,0 +1,3 @@ +Require Import Equality. +Theorem foo (u : unit) (H : u = u) : True. +dependent destruction H. -- cgit v1.2.3 From b30ca8ac9e0225e6505fea0004ea37e7649c9cb6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 3 Nov 2015 17:25:49 -0500 Subject: Fix bug in proofs/logic.ml type_of_global_reference_knowing_conclusion is buggy in general. --- proofs/logic.ml | 6 ++++-- tactics/tactics.ml | 2 +- test-suite/bugs/closed/4394.v | 14 ++++++++++---- 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/proofs/logic.ml b/proofs/logic.ml index 5c48995fc7..3273c95728 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -356,9 +356,11 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | App (f,l) -> let (acc',hdty,sigma,applicand) = if is_template_polymorphic env f then - let sigma, ty = + let ty = (* Template sort-polymorphism of definition and inductive types *) - type_of_global_reference_knowing_conclusion env sigma f conclty + let firstmeta = Array.findi (fun i x -> occur_meta x) l in + let args, _ = Option.cata (fun i -> CArray.chop i l) (l, [||]) firstmeta in + type_of_global_reference_knowing_parameters env sigma f args in goalacc, ty, sigma, f else diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 7756553e2d..2a46efd8ef 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3329,7 +3329,7 @@ let abstract_args gl generalize_vars dep id defined f args = if defined then Some c', typ_of ctxenv !sigma c' else None, c' in - let term = make_abstract_generalize gl id concl dep ctx body c' eqs args refls in + let term = make_abstract_generalize {gl with sigma = !sigma} id concl dep ctx body c' eqs args refls in Some (term, !sigma, dep, succ (List.length ctx), vars) else None diff --git a/test-suite/bugs/closed/4394.v b/test-suite/bugs/closed/4394.v index 751f1e697d..60c9354597 100644 --- a/test-suite/bugs/closed/4394.v +++ b/test-suite/bugs/closed/4394.v @@ -1,13 +1,19 @@ (* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) + Require Import Equality List. -Unset Strict Universe Declaration. -Inductive Foo I A := foo (B : Type) : A -> I B -> Foo I A. +Inductive Foo (I : Type -> Type) (A : Type) : Type := +| foo (B : Type) : A -> I B -> Foo I A. Definition Family := Type -> Type. -Definition fooFamily family : Family := Foo family. +Definition FooToo : Family -> Family := Foo. +Definition optionize (I : Type -> Type) (A : Type) := option (I A). +Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo (optionize I) A := foo (optionize I) A A. +Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. +Definition barRec : Rec (optionize id) := {| rec := bar id |}. Inductive Empty {T} : T -> Prop := . Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) nil)) (b : unit) : Empty (a, b) -> False. Proof. intro e. dependent induction e. -Qed. \ No newline at end of file +Qed. + -- cgit v1.2.3 From 95a4fcf8cd36e29034e886682ed3a6e2914ce04f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 4 Nov 2015 12:52:35 -0500 Subject: Univs: compatibility with 8.4. When refreshing a type variable, always use a rigid universe to force the most general universe constraint, as in 8.4. --- pretyping/evarsolve.ml | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 3c3720388f..ee666e1154 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -42,10 +42,6 @@ let get_polymorphic_positions f = templ.template_param_levels) | _ -> assert false -let default_universe_status u = - if Flags.version_less_or_equal Flags.V8_4 then univ_rigid - else u - let refresh_level evd s = match Evd.is_sort_variable evd s with | None -> true @@ -60,8 +56,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = (match Univ.universe_level u with | None -> true | Some l -> not onlyalg && refresh_level evd s) -> - let status = if inferred then Evd.univ_flexible_alg else Evd.univ_flexible in - let s' = evd_comb0 (new_sort_variable (default_universe_status status)) evdref in + let s' = evd_comb0 (new_sort_variable univ_rigid) evdref in let evd = if dir then set_leq_sort env !evdref s' s else set_leq_sort env !evdref s s' -- cgit v1.2.3 From acc54398bd244b15d4dbc396836c279eabf3bf6b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 4 Nov 2015 13:37:10 -0500 Subject: Hint Cut documentation and cleanup of printing (was duplicated and inconsistent). --- CHANGES | 2 ++ doc/refman/RefMan-tac.tex | 37 ++++++++++++++++++++++++++++++++++++- tactics/eauto.ml4 | 17 ++--------------- tactics/hints.ml | 14 +++++++++----- tactics/hints.mli | 1 + test-suite/success/Hints.v | 44 ++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 94 insertions(+), 21 deletions(-) diff --git a/CHANGES b/CHANGES index 019c6cdb24..af874bf1cc 100644 --- a/CHANGES +++ b/CHANGES @@ -36,6 +36,8 @@ Tactics of incompatibilities). - Hints costs are now correctly taken into account (potential source of incompatibilities). +- Documented the Hint Cut command that allows control of the + proof-search during typeclass resolution (see reference manual). API diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index a21e5631fc..1551b8eefd 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3788,12 +3788,47 @@ Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. Goal forall a b:list (nat * nat), {a = b} + {a <> b}. -info_auto with eqdec. +Info 1 auto with eqdec. \end{coq_example} \begin{coq_eval} Abort. \end{coq_eval} +\item \texttt{Cut} {\textit{regexp}} +\label{HintCut} +\comindex{Hint Cut} + + \textit{Warning:} these hints currently only apply to typeclass proof search and + the \texttt{typeclasses eauto} tactic. + + This command can be used to cut the proof-search tree according to a + regular expression matching paths to be cut. The grammar for regular + expressions is the following: +\[\begin{array}{lcll} + e & ::= & \ident & \text{ hint or instance identifier } \\ + & & \texttt{*} & \text{ any hint } \\ + & & e | e' & \text{ disjunction } \\ + & & e ; e' & \text{ sequence } \\ + & & ! e & \text{ Kleene star } \\ + & & \texttt{emp} & \text{ empty } \\ + & & \texttt{eps} & \text{ epsilon } \\ + & & \texttt{(} e \texttt{)} & +\end{array}\] + +The \texttt{emp} regexp does not match any search path while +\texttt{eps} matches the empty path. During proof search, the path of +successive successful hints on a search branch is recorded, as a list of +identifiers for the hints (note \texttt{Hint Extern}'s do not have an +associated identitier). Before applying any hint $\ident$ the current +path $p$ extended with $\ident$ is matched against the current cut +expression $c$ associated to the hint database. If matching succeeds, +the hint is \emph{not} applied. The semantics of \texttt{Hint Cut} $e$ +is to set the cut expression to $c | e$, the initial cut expression +being \texttt{emp}. + + + + \end{itemize} \Rem One can use an \texttt{Extern} hint with no pattern to do diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index aa285fa98a..ee7b94b0d1 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -632,12 +632,7 @@ TACTIC EXTEND convert_concl_no_check | ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ] END - -let pr_hints_path_atom prc _ _ a = - match a with - | PathAny -> str"." - | PathHints grs -> - pr_sequence Printer.pr_global grs +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom ARGUMENT EXTEND hints_path_atom TYPED AS hints_path_atom @@ -646,15 +641,7 @@ ARGUMENT EXTEND hints_path_atom | [ "*" ] -> [ PathAny ] END -let pr_hints_path prc prx pry c = - let rec aux = function - | PathAtom a -> pr_hints_path_atom prc prx pry a - | PathStar p -> str"(" ++ aux p ++ str")*" - | PathSeq (p, p') -> aux p ++ spc () ++ aux p' - | PathOr (p, p') -> str "(" ++ aux p ++ str"|" ++ aux p' ++ str")" - | PathEmpty -> str"ø" - | PathEpsilon -> str"ε" - in aux c +let pr_hints_path prc prx pry c = Hints.pp_hints_path c ARGUMENT EXTEND hints_path TYPED AS hints_path diff --git a/tactics/hints.ml b/tactics/hints.ml index 4ba9adafec..5630d20b5d 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -382,15 +382,19 @@ let rec normalize_path h = let path_derivate hp hint = normalize_path (path_derivate hp hint) +let pp_hints_path_atom a = + match a with + | PathAny -> str"*" + | PathHints grs -> pr_sequence pr_global grs + let rec pp_hints_path = function - | PathAtom (PathAny) -> str"." - | PathAtom (PathHints grs) -> pr_sequence pr_global grs - | PathStar p -> str "(" ++ pp_hints_path p ++ str")*" + | PathAtom pa -> pp_hints_path_atom pa + | PathStar p -> str "!(" ++ pp_hints_path p ++ str")" | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p' | PathOr (p, p') -> str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")" - | PathEmpty -> str"Ø" - | PathEpsilon -> str"ε" + | PathEmpty -> str"emp" + | PathEpsilon -> str"eps" let subst_path_atom subst p = match p with diff --git a/tactics/hints.mli b/tactics/hints.mli index af4d3d1f66..3a0521f665 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -70,6 +70,7 @@ type hints_path = val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool val path_derivate : hints_path -> hints_path_atom -> hints_path +val pp_hints_path_atom : hints_path_atom -> Pp.std_ppcmds val pp_hints_path : hints_path -> Pp.std_ppcmds module Hint_db : diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index cc8cec4707..f934a5c74a 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -62,3 +62,47 @@ Axiom cast_coalesce : ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2). Hint Rewrite cast_coalesce : ltamer. + +Require Import Program. +Module HintCut. +Class A (f : nat -> nat) := a : True. +Class B (f : nat -> nat) := b : True. +Class C (f : nat -> nat) := c : True. +Class D (f : nat -> nat) := d : True. +Class E (f : nat -> nat) := e : True. + +Instance a_is_b f : A f -> B f. +Proof. easy. Qed. +Instance b_is_c f : B f -> C f. +Proof. easy. Qed. +Instance c_is_d f : C f -> D f. +Proof. easy. Qed. +Instance d_is_e f : D f -> E f. +Proof. easy. Qed. + +Instance a_compose f g : A f -> A g -> A (compose f g). +Proof. easy. Qed. +Instance b_compose f g : B f -> B g -> B (compose f g). +Proof. easy. Qed. +Instance c_compose f g : C f -> C g -> C (compose f g). +Proof. easy. Qed. +Instance d_compose f g : D f -> D g -> D (compose f g). +Proof. easy. Qed. +Instance e_compose f g : E f -> E g -> E (compose f g). +Proof. easy. Qed. + +Instance a_id : A id. +Proof. easy. Qed. + +Instance foo f : + E (id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ + id ∘ id ∘ id ∘ id ∘ id ∘ f ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id). +Proof. + Fail Timeout 1 apply _. (* 3.7s *) + +Hint Cut [!*; (a_is_b | b_is_c | c_is_d | d_is_e) ; + (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances. + + Timeout 1 Fail apply _. (* 0.06s *) +Abort. +End HintCut. \ No newline at end of file -- cgit v1.2.3 From 209faf81c432c39d4537f8b1dc5c9947d4349d30 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 4 Nov 2015 14:35:02 -0500 Subject: Univs: update refman, better printers for universe contexts. --- doc/refman/Universes.tex | 119 ++++++++++++++++++++++++++++------------------- kernel/univ.ml | 4 +- pretyping/evd.ml | 5 +- pretyping/pretyping.ml | 2 +- 4 files changed, 77 insertions(+), 53 deletions(-) diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index cd8222269d..f47973601b 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -7,9 +7,7 @@ \asection{General Presentation} \begin{flushleft} - \em The status of Universe Polymorphism is experimental. Some features - are not compatible with it (yet): bytecode compilation does not handle - polymorphic definitions, it treats them as opaque constants. + \em The status of Universe Polymorphism is experimental. \end{flushleft} This section describes the universe polymorphic extension of Coq. @@ -65,7 +63,7 @@ Now \texttt{pidentity} is used at two different levels: at the head of the application it is instantiated at \texttt{Top.3} while in the argument position it is instantiated at \texttt{Top.4}. This definition is only valid as long as \texttt{Top.4} is strictly smaller than -\texttt{Top.3}, as show by the constraints. Not that this definition is +\texttt{Top.3}, as show by the constraints. Note that this definition is monomorphic (not universe polymorphic), so in turn the two universes are actually global levels. @@ -119,18 +117,28 @@ producing global universe constraints, one can use the \begin{itemize} \item \texttt{Lemma}, \texttt{Axiom}, and all the other ``definition'' keywords support polymorphism. -\item \texttt{Variables}, \texttt{Context} in a section support polymorphism. - This means that the - variables are discharged polymorphically over definitions that use - them. In other words, two definitions in the section sharing a common - variable will both get parameterized by the universes produced by the - variable declaration. This is in contrast to a ``mononorphic'' variable - which introduces global universes, making the two definitions depend on - the \emph{same} global universes associated to the variable. +\item \texttt{Variables}, \texttt{Context}, \texttt{Universe} and + \texttt{Constraint} in a section support polymorphism. This means + that the universe variables (and associated constraints) are + discharged polymorphically over definitions that use them. In other + words, two definitions in the section sharing a common variable will + both get parameterized by the universes produced by the variable + declaration. This is in contrast to a ``mononorphic'' variable which + introduces global universes and constraints, making the two + definitions depend on the \emph{same} global universes associated to + the variable. \item \texttt{Hint \{Resolve, Rewrite\}} will use the auto/rewrite hint polymorphically, not at a single instance. \end{itemize} +\asection{Global and local universes} + +Each universe is declared in a global or local environment before it can +be used. To ensure compatibility, every \emph{global} universe is set to +be strictly greater than \Set~when it is introduced, while every +\emph{local} (i.e. polymorphically quantified) universe is introduced as +greater or equal to \Set. + \asection{Conversion and unification} The semantics of conversion and unification have to be modified a little @@ -173,23 +181,48 @@ This definition is elaborated by minimizing the universe of id to level generated at the application of id and a constraint that $\Set \le i$. This minimization process is applied only to fresh universe variables. It simply adds an equation between the variable and its lower -bound if it is an atomic universe (i.e. not an algebraic max()). +bound if it is an atomic universe (i.e. not an algebraic \texttt{max()} +universe). -\asection{Explicit Universes} +The option \texttt{Unset Universe Minimization ToSet} disallows +minimization to the sort $\Set$ and only collapses floating universes +between themselves. -\begin{flushleft} - \em The design and implementation of explicit universes is very - experimental and is likely to change in future versions. -\end{flushleft} +\asection{Explicit Universes} The syntax has been extended to allow users to explicitly bind names to -universes and explicitly instantiate polymorphic -definitions. Currently, binding is implicit at the first occurrence of a -universe name. For example, i and j below are introduced by the -annotations attached to Types. +universes and explicitly instantiate polymorphic definitions. + +\subsection{\tt Universe {\ident}. + \comindex{Universe} + \label{UniverseCmd}} + +In the monorphic case, this command declare a new global universe named +{\ident}. It supports the polymorphic flag only in sections, meaning the +universe quantification will be discharged on each section definition +independently. + +\subsection{\tt Constraint {\ident} {\textit{ord}} {\ident}. + \comindex{Constraint} + \label{ConstraintCmd}} + +This command declare a new constraint between named universes. +The order relation can be one of $<$, $\le$ or $=$. If consistent, +the constraint is then enforced in the global environment. Like +\texttt{Universe}, it can be used with the \texttt{Polymorphic} prefix +in sections only to declare constraints discharged at section closing time. + +\begin{ErrMsgs} +\item \errindex{Undeclared universe {\ident}}. +\item \errindex{Universe inconsistency} +\end{ErrMsgs} + +\subsection{Polymorphic definitions} +For polymorphic definitions, the declaration of (all) universe levels +introduced by a definition uses the following syntax: \begin{coq_example*} -Polymorphic Definition le (A : Type@{i}) : Type@{j} := A. +Polymorphic Definition le@{i j} (A : Type@{i}) : Type@{j} := A. \end{coq_example*} \begin{coq_example} Print le. @@ -197,40 +230,32 @@ Print le. During refinement we find that $j$ must be larger or equal than $i$, as we are using $A : Type@{i} <= Type@{j}$, hence the generated -constraint. Note that the names here are not bound in the final -definition, they just allow to specify locally what relations should -hold. In the term and in general in proof mode, universe names -introduced in the types can be referred to in terms. +constraint. At the end of a definition or proof, we check that the only +remaining universes are the ones declared. In the term and in general in +proof mode, introduced universe names can be referred to in +terms. Note that local universe names shadow global universe names. +During a proof, one can use \texttt{Show Universes} to display +the current context of universes. Definitions can also be instantiated explicitly, giving their full instance: \begin{coq_example} Check (pidentity@{Set}). -Check (le@{i j}). +Universes k l. +Check (le@{k l}). \end{coq_example} User-named universes are considered rigid for unification and are never minimized. -Finally, two commands allow to name \emph{global} universes and constraints. - -\subsection{\tt Universe {\ident}. - \comindex{Universe} - \label{UniverseCmd}} +\subsection{\tt Unset Strict Universe Declaration. + \optindex{StrictUniverseDeclaration} + \label{StrictUniverseDeclaration}} -This command declare a new global universe named {\ident}. - -\subsection{\tt Constraint {\ident} {\textit{ord}} {\ident}. - \comindex{Constraint} - \label{ConstraintCmd}} - -This command declare a new constraint between named universes. -The order relation can be one of $<$, $<=$ or $=$. If consistent, -the constraint is then enforced in the global environment. - -\begin{ErrMsgs} -\item \errindex{Undeclared universe {\ident}}. -\item \errindex{Universe inconsistency} -\end{ErrMsgs} +The command \texttt{Unset Strict Universe Declaration} allows one to +freely use identifiers for universes without declaring them first, with +the semantics that the first use declares it. In this mode, the universe +names are not associated with the definition or proof once it has been +defined. This is meant mainly for debugging purposes. %%% Local Variables: %%% mode: latex diff --git a/kernel/univ.ml b/kernel/univ.ml index 064dde3a64..6c2316988e 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1768,7 +1768,7 @@ struct let pr prl (univs, cst as ctx) = if is_empty ctx then mt() else - Instance.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst) + h 0 (Instance.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let hcons (univs, cst) = (Instance.hcons univs, hcons_constraints cst) @@ -1842,7 +1842,7 @@ struct let pr prl (univs, cst as ctx) = if is_empty ctx then mt() else - LSet.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst) + h 0 (LSet.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let constraints (univs, cst) = cst let levels (univs, cst) = univs diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 82c068be07..4a9466f4f3 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -280,9 +280,8 @@ type evar_universe_context = uctx_univ_variables : Universes.universe_opt_subst; (** The local universes that are unification variables *) uctx_univ_algebraic : Univ.universe_set; - (** The subset of unification variables that - can be instantiated with algebraic universes as they appear in types - and universe instances only. *) + (** The subset of unification variables that can be instantiated with + algebraic universes as they appear in inferred types only. *) uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *) } diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index d484df69c1..d354a6c3c4 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -118,7 +118,7 @@ let _ = { optsync = true; optdepr = false; optname = "minimization to Set"; - optkey = ["Universe";"set";"Minimization"]; + optkey = ["Universe";"Minimization";"ToSet"]; optread = Universes.is_set_minimization; optwrite = (:=) Universes.set_minimization }) -- cgit v1.2.3 From 7c102bb3a3798a234701fdc28a8e8ec28ee2549c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 4 Nov 2015 18:09:02 -0500 Subject: Univs: missing checks in evarsolve with candidates and missing a whd_evar in refresh_universes. --- pretyping/evarsolve.ml | 17 ++++++++++------- test-suite/bugs/closed/HoTT_coq_014.v | 6 +++--- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index ee666e1154..35bc1de593 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -50,24 +50,24 @@ let refresh_level evd s = let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = let evdref = ref evd in let modified = ref false in - let rec refresh dir t = + let rec refresh status dir t = match kind_of_term t with | Sort (Type u as s) when (match Univ.universe_level u with | None -> true | Some l -> not onlyalg && refresh_level evd s) -> - let s' = evd_comb0 (new_sort_variable univ_rigid) evdref in + let s' = evd_comb0 (new_sort_variable status) evdref in let evd = if dir then set_leq_sort env !evdref s' s else set_leq_sort env !evdref s s' in modified := true; evdref := evd; mkSort s' | Prod (na,u,v) -> - mkProd (na,u,refresh dir v) + mkProd (na,u,refresh status dir v) | _ -> t (** Refresh the types of evars under template polymorphic references *) and refresh_term_evars onevars top t = - match kind_of_term t with + match kind_of_term (whd_evar !evdref t) with | App (f, args) when is_template_polymorphic env f -> let pos = get_polymorphic_positions f in refresh_polymorphic_positions args pos @@ -76,7 +76,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = Array.iter (refresh_term_evars onevars false) args | Evar (ev, a) when onevars -> let evi = Evd.find !evdref ev in - let ty' = refresh true evi.evar_concl in + let ty' = refresh univ_flexible true evi.evar_concl in if !modified then evdref := Evd.add !evdref ev {evi with evar_concl = ty'} else () @@ -98,7 +98,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = if isArity t then (match pbty with | None -> t - | Some dir -> refresh dir t) + | Some dir -> refresh univ_rigid dir t) else (refresh_term_evars false true t; t) in if !modified then !evdref, t' else !evdref, t @@ -1274,7 +1274,10 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = | [c,evd] -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) - if Evd.is_undefined evd evk then Evd.define evk c evd else evd + if Evd.is_undefined evd evk then + let evd' = Evd.define evk c evd in + check_evar_instance evd' evk c conv_algo + else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in restrict_evar evd evk None (UpdateWith candidates) diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index ae3e50d7ee..223a98de1c 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -3,9 +3,9 @@ Set Implicit Arguments. Generalizable All Variables. Set Universe Polymorphism. -Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' { - Object :> _ := obj; - Morphism' : obj -> obj -> Type; +Polymorphic Record SpecializedCategory@{l k} (obj : Type@{l}) := Build_SpecializedCategory' { + Object :> Type@{l} := obj; + Morphism' : obj -> obj -> Type@{k}; Identity' : forall o, Morphism' o o; Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d' -- cgit v1.2.3 From 42cd40e4edcc29804d1b73d8cb076f8578ce66fa Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 4 Nov 2015 19:58:09 -0500 Subject: Checker was forgetting to register global universes introduced by opaque proofs. --- checker/check.ml | 9 ++++----- checker/declarations.ml | 6 ++++-- checker/declarations.mli | 5 +++-- checker/safe_typing.ml | 4 ++-- checker/safe_typing.mli | 4 ++-- 5 files changed, 15 insertions(+), 13 deletions(-) diff --git a/checker/check.ml b/checker/check.ml index 2bc470aead..21c8f1c5bb 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -46,7 +46,7 @@ type library_t = { library_opaques : Cic.opaque_table; library_deps : Cic.library_deps; library_digest : Cic.vodigest; - library_extra_univs : Univ.constraints } + library_extra_univs : Univ.ContextSet.t } module LibraryOrdered = struct @@ -97,7 +97,7 @@ let access_opaque_univ_table dp i = let t = LibraryMap.find dp !opaque_univ_tables in assert (i < Array.length t); Future.force t.(i) - with Not_found -> Univ.empty_constraint + with Not_found -> Univ.ContextSet.empty let _ = Declarations.indirect_opaque_access := access_opaque_table @@ -347,9 +347,8 @@ let intern_from_file (dir, f) = LibraryMap.add sd.md_name opaque_csts !opaque_univ_tables) opaque_csts; let extra_cst = - Option.default Univ.empty_constraint - (Option.map (fun (_,cs,_) -> - Univ.ContextSet.constraints cs) opaque_csts) in + Option.default Univ.ContextSet.empty + (Option.map (fun (_,cs,_) -> cs) opaque_csts) in mk_library sd md f table digest extra_cst let get_deps (dir, f) = diff --git a/checker/declarations.ml b/checker/declarations.ml index 36e6a7caba..32d1713a88 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -426,7 +426,7 @@ let subst_lazy_constr sub = function let indirect_opaque_access = ref ((fun dp i -> assert false) : DirPath.t -> int -> constr) let indirect_opaque_univ_access = - ref ((fun dp i -> assert false) : DirPath.t -> int -> Univ.constraints) + ref ((fun dp i -> assert false) : DirPath.t -> int -> Univ.ContextSet.t) let force_lazy_constr = function | Indirect (l,dp,i) -> @@ -435,7 +435,7 @@ let force_lazy_constr = function let force_lazy_constr_univs = function | OpaqueDef (Indirect (l,dp,i)) -> !indirect_opaque_univ_access dp i - | _ -> Univ.empty_constraint + | _ -> Univ.ContextSet.empty let subst_constant_def sub = function | Undef inl -> Undef inl @@ -457,6 +457,8 @@ let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Def _ | Undef _ -> false +let opaque_univ_context cb = force_lazy_constr_univs cb.const_body + let subst_rel_declaration sub (id,copt,t as x) = let copt' = Option.smartmap (subst_mps sub) copt in let t' = subst_mps sub t in diff --git a/checker/declarations.mli b/checker/declarations.mli index 3c6db6ab71..456df83699 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -2,17 +2,18 @@ open Names open Cic val force_constr : constr_substituted -> constr -val force_lazy_constr_univs : Cic.constant_def -> Univ.constraints +val force_lazy_constr_univs : Cic.constant_def -> Univ.ContextSet.t val from_val : constr -> constr_substituted val indirect_opaque_access : (DirPath.t -> int -> constr) ref -val indirect_opaque_univ_access : (DirPath.t -> int -> Univ.constraints) ref +val indirect_opaque_univ_access : (DirPath.t -> int -> Univ.ContextSet.t) ref (** Constant_body *) val body_of_constant : constant_body -> constr option val constant_has_body : constant_body -> bool val is_opaque : constant_body -> bool +val opaque_univ_context : constant_body -> Univ.ContextSet.t (* Mutual inductives *) diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index d3bc8373a5..81a3cc035b 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -28,7 +28,7 @@ let set_engagement c = let full_add_module dp mb univs digest = let env = !genv in let env = push_context_set ~strict:true mb.mod_constraints env in - let env = add_constraints univs env in + let env = push_context_set ~strict:true univs env in let env = Modops.add_module mb env in genv := add_digest env dp digest @@ -83,7 +83,7 @@ let import file clib univs digest = check_engagement env clib.comp_enga; let mb = clib.comp_mod in Mod_checking.check_module - (add_constraints univs + (push_context_set ~strict:true univs (push_context_set ~strict:true mb.mod_constraints env)) mb.mod_mp mb; stamp_library file digest; full_add_module clib.comp_name mb univs digest diff --git a/checker/safe_typing.mli b/checker/safe_typing.mli index e16e64e6a2..892a8d2cc9 100644 --- a/checker/safe_typing.mli +++ b/checker/safe_typing.mli @@ -15,6 +15,6 @@ val get_env : unit -> env val set_engagement : engagement -> unit val import : - CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit + CUnix.physical_path -> compiled_library -> Univ.ContextSet.t -> Cic.vodigest -> unit val unsafe_import : - CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit + CUnix.physical_path -> compiled_library -> Univ.ContextSet.t -> Cic.vodigest -> unit -- cgit v1.2.3 From 0fd6ad21121c7c179375b9a50c3135abab1781b2 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 5 Nov 2015 16:44:16 +0100 Subject: Update version numbers and magic numbers for 8.5beta3 release. --- CHANGES | 2 +- configure.ml | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/CHANGES b/CHANGES index af874bf1cc..7b50dfae56 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,4 @@ -Changes from V8.5beta2 to ... +Changes from V8.5beta2 to V8.5beta3 =================================== Vernacular commands diff --git a/configure.ml b/configure.ml index 173429ba8e..51033c3d01 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.5beta2" -let coq_macos_version = "8.4.92" (** "[...] should be a string comprised of +let coq_version = "8.5beta3" +let coq_macos_version = "8.4.93" (** "[...] should be a string comprised of three non-negative, period-separed integers [...]" *) -let vo_magic = 8492 -let state_magic = 58502 +let vo_magic = 8493 +let state_magic = 58503 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] -- cgit v1.2.3 From 5cbb42e08a8032ada1788a0542a45177f798a6ac Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 15:05:12 -0500 Subject: Fix bug #4273 Syntactic analysis of dependencies when atomizing arguments in destruct was not dealing properly with primitive projections hiding their parameters. --- tactics/tactics.ml | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2a46efd8ef..e215ff42f9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2825,6 +2825,14 @@ let induct_discharge dests avoid' tac (avoid,ra) names = s'embêter à regarder si un letin_tac ne fait pas des substitutions aussi sur l'argument voisin *) +let expand_projections env sigma c = + let rec aux env c = + match kind_of_term c with + | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] + | _ -> map_constr_with_full_binders push_rel aux env c + in aux env c + + (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = @@ -2833,11 +2841,14 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in let typ0 = reduce_to_quantified_ref indref tmptyp0 in - let prods, indtyp = decompose_prod typ0 in + let prods, indtyp = decompose_prod_assum typ0 in let hd,argl = decompose_app indtyp in + let env' = push_rel_context prods env in + let sigma = Proofview.Goal.sigma gl in let params = List.firstn nparams argl in + let params' = List.map (expand_projections env' sigma) params in (* le gl est important pour ne pas préévaluer *) - let rec atomize_one i args avoid = + let rec atomize_one i args args' avoid = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN @@ -2846,22 +2857,23 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = else let c = List.nth argl (i-1) in match kind_of_term c with - | Var id when not (List.exists (occur_var env id) args) && - not (List.exists (occur_var env id) params) -> + | Var id when not (List.exists (occur_var env id) args') && + not (List.exists (occur_var env id) params') -> (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) - atomize_one (i-1) (c::args) (id::avoid) + atomize_one (i-1) (c::args) (c::args') (id::avoid) | _ -> - if List.exists (dependent c) params || - List.exists (dependent c) args + let c' = expand_projections env' sigma c in + if List.exists (dependent c) params' || + List.exists (dependent c) args' then (* This is a case where the argument is constrained in a way which would require some kind of inversion; we follow the (old) discipline of not generalizing over this term, since we don't try to invert the constraint anyway. *) - atomize_one (i-1) (c::args) avoid + atomize_one (i-1) (c::args) (c'::args') avoid else (* We reason blindly on the term and do as if it were generalizable, ignoring the constraints coming from @@ -2874,9 +2886,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) - (atomize_one (i-1) (mkVar x::args) (x::avoid)) + (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) in - atomize_one (List.length argl) [] [] + atomize_one (List.length argl) [] [] [] end (* [cook_sign] builds the lists [beforetoclear] (preceding the -- cgit v1.2.3 From ce6392e74fbe0edd5ebcaecb362fec5da9b4703b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 15:10:29 -0500 Subject: Add test-suite file for #4273. --- test-suite/bugs/closed/4273.v | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 test-suite/bugs/closed/4273.v diff --git a/test-suite/bugs/closed/4273.v b/test-suite/bugs/closed/4273.v new file mode 100644 index 0000000000..591ea4b5b2 --- /dev/null +++ b/test-suite/bugs/closed/4273.v @@ -0,0 +1,9 @@ + + +Set Primitive Projections. +Record total2 (P : nat -> Prop) := tpair { pr1 : nat; pr2 : P pr1 }. +Theorem onefiber' (q : total2 (fun y => y = 0)) : True. +Proof. assert (foo:=pr2 _ q). simpl in foo. + destruct foo. (* Error: q is used in conclusion. *) exact I. Qed. + +Print onefiber'. \ No newline at end of file -- cgit v1.2.3 From 6b3d6f9326de9e53805d14e78577411c7174a998 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 14:00:41 +0100 Subject: Fixing complexity issue with f_equal. Thanks to J.-H. Jourdan for reporting it. A "cut" was not appropriately chained on the second goal but on both goals, with the chaining on the first goal introducing noise. --- plugins/cc/cctac.ml | 4 ++-- test-suite/complexity/f_equal.v | 14 ++++++++++++++ 2 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 test-suite/complexity/f_equal.v diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 068cb25cf2..371f76cf32 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -501,9 +501,9 @@ let f_equal = let concl = Proofview.Goal.concl gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) - Tacticals.New.tclTHEN + Tacticals.New.tclTHENS (mk_eq _eq c1 c2 Tactics.cut) - (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)) + [Proofview.tclUNIT ();Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)] with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v new file mode 100644 index 0000000000..30e87939ec --- /dev/null +++ b/test-suite/complexity/f_equal.v @@ -0,0 +1,14 @@ +(* Checks that f_equal does not reduce the term uselessly *) +(* Expected time < 1.00s *) + +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal stupid 23 = stupid 23. +f_equal. -- cgit v1.2.3 From 951b33251addefa79d62c4344f2690014dfd62dd Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 14:19:06 +0100 Subject: More on how to compile doc. --- INSTALL.doc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/INSTALL.doc b/INSTALL.doc index 7658800584..2472d2b2a6 100644 --- a/INSTALL.doc +++ b/INSTALL.doc @@ -22,8 +22,8 @@ To produce all the documents, the following tools are needed: - dvips - bibtex - makeindex - - fig2dev - - convert + - fig2dev (transfig) + - convert (ImageMagick) - hevea - hacha -- cgit v1.2.3 From 76bc7f9d164c20583c6561127bf36e7247a37c6b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 18:19:38 +0100 Subject: Fixing complexity file f_equal.v. --- test-suite/complexity/f_equal.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v index 30e87939ec..86698fa872 100644 --- a/test-suite/complexity/f_equal.v +++ b/test-suite/complexity/f_equal.v @@ -11,4 +11,4 @@ match n with end. Goal stupid 23 = stupid 23. -f_equal. +Timeout 5 Time f_equal. -- cgit v1.2.3 From a8b248096e5120f58157b0fc3bd06ca07118a8ab Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 6 Nov 2015 17:04:24 +0100 Subject: Fixing #4406 coqdep: No recursive search of ml (-I). --- tools/coqdep_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index c111137571..ca42c99470 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -548,7 +548,7 @@ let add_rec_dir add_file phys_dir log_dir = (** -I semantic: do not go in subdirs. *) let add_caml_dir phys_dir = - handle_unix_error (add_directory true add_caml_known phys_dir) [] + handle_unix_error (add_directory false add_caml_known phys_dir) [] let rec treat_file old_dirname old_name = -- cgit v1.2.3 From c5d380548ef5597b77c7ab1fce252704deefeaf1 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 6 Nov 2015 18:49:21 +0100 Subject: Fixed #4407. Like coqc: detect if the current directory was set by options, if not: add it with empty logical path. TODO: check if coq_makefile is still correct wrt to this modification, I think yes, actually it should end being more correct. --- tools/coqdep.ml | 37 +++++++++++++++++++++---------------- tools/coqdep_boot.ml | 12 ++++++------ tools/coqdep_common.ml | 34 +++++++++++++++++++++++++++------- tools/coqdep_common.mli | 22 ++++++++++++++++++++-- 4 files changed, 74 insertions(+), 31 deletions(-) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 110d306022..e0e017e88a 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -426,8 +426,9 @@ let coq_dependencies_dump chan dumpboxes = end let usage () = - eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-R dir coqdir] +\n"; + eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-Q dir coqdir] [-R dir coqdir] +\n"; eprintf " extra options:\n"; + eprintf " -sort : output the file names ordered by dependencies\n"; eprintf " -coqlib dir : set the coq standard library directory\n"; eprintf " -exclude-dir f : skip subdirectories named 'f' during -R search\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; @@ -442,16 +443,17 @@ let rec parse = function | "-boot" :: ll -> option_boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll - | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r []; - add_dir add_known r (split_period ln); - parse ll + | "-I" :: r :: "-as" :: ln :: ll -> + add_rec_dir_no_import add_known r []; + add_rec_dir_no_import add_known r (split_period ln); + parse ll | "-I" :: r :: "-as" :: [] -> usage () | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () - | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll + | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll | "-R" :: r :: "-as" :: [] -> usage () - | "-R" :: r :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll - | "-Q" :: r :: ln :: ll -> add_dir add_known r (split_period ln); parse ll + | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll + | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import add_known r (split_period ln); parse ll | "-R" :: ([] | [_]) -> usage () | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll @@ -471,23 +473,26 @@ let rec parse = function let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); + (* Add current dir with empty logical path if not set by options above. *) + (try ignore (Coqdep_common.find_dir_logpath (Sys.getcwd())) + with Not_found -> add_norec_dir_import add_known "." []); if not Coq_config.has_natdynlink then option_natdynlk := false; (* NOTE: These directories are searched from last to first *) if !option_boot then begin - add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "plugins" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"]; + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin Envars.set_coqlib ~fail:Errors.error; let coqlib = Envars.coqlib () in - add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; - add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; let user = coqlib//"user-contrib" in - if Sys.file_exists user then add_dir add_coqlib_known user []; - List.iter (fun s -> add_dir add_coqlib_known s []) + if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) (Envars.xdg_dirs (fun x -> Pp.msg_warning (Pp.str x))); - List.iter (fun s -> add_dir add_coqlib_known s []) Envars.coqpath; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; List.iter (fun (f,d) -> add_mllib_known f d ".mllib") !mllibAccu; diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index 64ce66d2d1..088ea6bfcf 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -35,15 +35,15 @@ let _ = if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); if !option_c then begin - add_rec_dir add_known "." []; - add_rec_dir (fun _ -> add_caml_known) "." ["Coq"]; + add_rec_dir_import add_known "." []; + add_rec_dir_import (fun _ -> add_caml_known) "." ["Coq"]; end else begin - add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "plugins" ["Coq"]; + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; add_caml_dir "tactics"; - add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end; if !option_c then mL_dependencies (); coq_dependencies () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index ca42c99470..02fd19a1e2 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -220,6 +220,18 @@ let absolute_file_name basename odir = let dir = match odir with Some dir -> dir | None -> "." in absolute_dir dir // basename +(** [find_dir_logpath dir] Return the logical path of directory [dir] + if it has been given one. Raise [Not_found] otherwise. In + particular we can check if "." has been attributed a logical path + after processing all options and silently give the default one if + it hasn't. We may also use this to warn if ap hysical path is met + twice.*) +let register_dir_logpath,find_dir_logpath = + let tbl: (string, string list) Hashtbl.t = Hashtbl.create 19 in + let reg physdir logpath = Hashtbl.add tbl (absolute_dir physdir) logpath in + let fnd physdir = Hashtbl.find tbl (absolute_dir physdir) in + reg,fnd + let file_name s = function | None -> s | Some "." -> s @@ -339,7 +351,8 @@ let escape = Buffer.contents s' let compare_file f1 f2 = - absolute_dir (Filename.dirname f1) = absolute_dir (Filename.dirname f2) + absolute_file_name (Filename.basename f1) (Some (Filename.dirname f1)) + = absolute_file_name (Filename.basename f2) (Some (Filename.dirname f2)) let canonize f = let f' = absolute_dir (Filename.dirname f) // Filename.basename f in @@ -514,11 +527,13 @@ let add_known recur phys_dir log_dir f = List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () -(* Visits all the directories under [dir], including [dir], - or just [dir] if [recur=false] *) - +(** Visit directory [phys_dir] (recursively unless [recur=false]) and + apply function add_file to each regular file encountered. + [log_dir] is the logical name of the [phys_dir]. + [add_file] takes both directory names and the file. *) let rec add_directory recur add_file phys_dir log_dir = let dirh = opendir phys_dir in + register_dir_logpath phys_dir log_dir; try while true do let f = readdir dirh in @@ -531,19 +546,24 @@ let rec add_directory recur add_file phys_dir log_dir = if StrSet.mem f !norec_dirnames then () else if StrSet.mem phys_f !norec_dirs then () - else + else (* TODO: warn if already seen this physycal dir? *) add_directory recur add_file phys_f (log_dir@[f]) | S_REG -> add_file phys_dir log_dir f | _ -> () done with End_of_file -> closedir dirh +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path (which is not recursive). *) +let add_norec_dir_import add_file phys_dir log_dir = + try add_directory false (add_file true) phys_dir log_dir with Unix_error _ -> () + (** -Q semantic: go in subdirs but only full logical paths are known. *) -let add_dir add_file phys_dir log_dir = +let add_rec_dir_no_import add_file phys_dir log_dir = try add_directory true (add_file false) phys_dir log_dir with Unix_error _ -> () (** -R semantic: go in subdirs and suffixes of logical paths are known. *) -let add_rec_dir add_file phys_dir log_dir = +let add_rec_dir_import add_file phys_dir log_dir = handle_unix_error (add_directory true (add_file true) phys_dir) log_dir (** -I semantic: do not go in subdirs. *) diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli index d610a0558d..50cae40d9a 100644 --- a/tools/coqdep_common.mli +++ b/tools/coqdep_common.mli @@ -8,6 +8,14 @@ module StrSet : Set.S with type elt = string +(** [find_dir_logpath dir] Return the logical path of directory [dir] + if it has been given one. Raise [Not_found] otherwise. In + particular we can check if "." has been attributed a logical path + after processing all options and silently give the default one if + it hasn't. We may also use this to warn if ap hysical path is met + twice.*) +val find_dir_logpath: string -> string list + val option_c : bool ref val option_noglob : bool ref val option_boot : bool ref @@ -47,9 +55,19 @@ val add_directory : bool -> (string -> string list -> string -> unit) -> string -> string list -> unit val add_caml_dir : string -> unit -val add_dir : + +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path. *) +val add_norec_dir_import : + (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + +(** -Q semantic: go in subdirs but only full logical paths are known. *) +val add_rec_dir_no_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit -val add_rec_dir : + +(** -R semantic: go in subdirs and suffixes of logical paths are known. *) +val add_rec_dir_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + val treat_file : dir -> string -> unit val error_cannot_parse : string -> int * int -> 'a -- cgit v1.2.3 From bbef0e8702bf5e2dcad9bb4c47f92858d4eea9b4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 11:02:40 +0100 Subject: Fixing documention of Add Printing Coercion. --- doc/refman/Coercion.tex | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/doc/refman/Coercion.tex b/doc/refman/Coercion.tex index e4aa69353d..16006a6adf 100644 --- a/doc/refman/Coercion.tex +++ b/doc/refman/Coercion.tex @@ -312,12 +312,13 @@ Conversely, to skip the printing of coercions, use {\tt Unset Printing Coercions}. By default, coercions are not printed. -\asubsection{\tt Set Printing Coercion {\qualid}.} -\optindex{Printing Coercion} +\asubsection{\tt Add Printing Coercion {\qualid}.} +\comindex{Add Printing Coercion} +\comindex{Remove Printing Coercion} This command forces coercion denoted by {\qualid} to be printed. To skip the printing of coercion {\qualid}, use - {\tt Unset Printing Coercion {\qualid}}. + {\tt Remove Printing Coercion {\qualid}}. By default, a coercion is never printed. \asection{Classes as Records} -- cgit v1.2.3 From e9f1b6abaf062e8fbb4892f7ec8856dcf81c2757 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 31 Oct 2015 15:12:02 +0100 Subject: Tests for syntax "Show id" and [id]:tac (shelved or not). --- test-suite/success/destruct.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 83a33f75dc..59cd25cd76 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -97,6 +97,7 @@ Abort. Goal exists x, S x = S 0. eexists. +Show x. (* Incidentally test Show on a named goal *) destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S 0). Abort. @@ -105,6 +106,7 @@ Goal exists x, S 0 = S x. eexists. destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S ?x). +[x]: exact 0. (* Incidentally test applying a tactic to a goal on the shelve *) Abort. Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. -- cgit v1.2.3 From eec77191b33bbca4c9d8b1b92b0c622ef430a3a8 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 1 Nov 2015 11:20:34 +0100 Subject: Preservation of the name of evars/goals when applying pose/set/intro/clearbody. For pose/set/clearbody, I think it is clear that we want to preserve the name and this commit do it. For revert, I first did not preserve the name, then considered in 2ba2ca96be88 that it was better to preserve it. For intro, like for revert actually, I did not preserve the name, based on the idea that the type was changing (*). For instance if we have ?f:nat->nat, do we really want to keep the name f in ?f:nat after an intro. For revert, I changed my mind based on the idea that if we had a better control of the name if we keep the name that if the system invents a new one based on the type. I think this is more reasonable than (*), so this commit preserves the name for intro. For generalize, it is still not done because of generalize being in the old proof engine. --- tactics/tactics.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e215ff42f9..37b715ebe2 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -164,7 +164,7 @@ let unsafe_intro env store (id, c, t) b = let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar id) b in - let sigma, ev = new_evar_instance nctx sigma nb ~store ninst in + let sigma, ev = new_evar_instance nctx sigma nb ~principal:true ~store ninst in sigma, mkNamedLambda_or_LetIn (id, c, t) ev end @@ -1834,7 +1834,7 @@ let clear_body ids = in check_hyps <*> check_concl <*> Proofview.Refine.refine ~unsafe:true begin fun sigma -> - Evarutil.new_evar env sigma concl + Evarutil.new_evar env sigma ~principal:true concl end end @@ -2599,7 +2599,7 @@ let new_generalize_gen_let lconstr = in Proofview.Unsafe.tclEVARS sigma <*> Proofview.Refine.refine begin fun sigma -> - let (sigma, ev) = Evarutil.new_evar env sigma newcl in + let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in (sigma, (applist (ev, args))) end end -- cgit v1.2.3 From 4bd5dcfeb558f826d90123357a3e5336f96b2213 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 22 Sep 2015 18:45:27 +0200 Subject: Adding an amazing property of Prop. --- doc/stdlib/index-list.html.template | 1 + theories/Logic/PropFacts.v | 50 +++++++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+) create mode 100644 theories/Logic/PropFacts.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 866193ffb4..33de399c0d 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -59,6 +59,7 @@ through the Require Import command.

theories/Logic/WeakFan.v theories/Logic/WKL.v theories/Logic/FinFun.v + theories/Logic/PropFacts.v
Structures: diff --git a/theories/Logic/PropFacts.v b/theories/Logic/PropFacts.v new file mode 100644 index 0000000000..309539e5ca --- /dev/null +++ b/theories/Logic/PropFacts.v @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Prop) + (inj : forall A B, (f A <-> f B) -> (A <-> B)) + (ext : forall A B, A <-> B -> f A <-> f B) + : forall A, f (f A) <-> A. +Proof. +intros. +enough (f (f (f A)) <-> f A) by (apply inj; assumption). +split; intro H. +- now_show (f A). + enough (f A <-> True) by firstorder. + enough (f (f A) <-> f True) by (apply inj; assumption). + split; intro H'. + + now_show (f True). + enough (f (f (f A)) <-> f True) by firstorder. + apply ext; firstorder. + + now_show (f (f A)). + enough (f (f A) <-> True) by firstorder. + apply inj; firstorder. +- now_show (f (f (f A))). + enough (f A <-> f (f (f A))) by firstorder. + apply ext. + split; intro H'. + + now_show (f (f A)). + enough (f A <-> f (f A)) by firstorder. + apply ext; firstorder. + + now_show A. + enough (f A <-> A) by firstorder. + apply inj; firstorder. +Defined. -- cgit v1.2.3 From c23f0cab6ee1e9c9b63347cd2624b64591871cb1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 22:17:04 +0100 Subject: Experimenting printing the type of the defined term of a LetIn when this type is a proposition. This is based on the assumption that in Prop, what matters first is the statement. --- pretyping/detyping.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index b5228094a2..df15be9b30 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -661,7 +661,13 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = match bk with | BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r) | BLambda -> GLambda (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r) - | BLetIn -> GLetIn (dl, na',detype (lax,false) avoid env sigma (Option.get body), r) + | BLetIn -> + let c = detype (lax,false) avoid env sigma (Option.get body) in + (* Heuristic: we display the type if in Prop *) + let s = Retyping.get_sort_family_of (snd env) sigma ty in + let c = if s != InProp then c else + GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in + GLetIn (dl, na', c, r) let detype_rel_context ?(lax=false) where avoid env sigma sign = let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in -- cgit v1.2.3 From 479d4cd6e9934a47debf6201fccf7ebb1aea1b09 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 22:21:10 +0100 Subject: Implementing assert and cut with LetIn rather than using a beta-redex. Hopefully, it will provide with nicer proof terms, in combination with the commit printing the type of LetIn when the defined term is a proof. --- proofs/logic.ml | 2 +- tactics/tactics.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/proofs/logic.ml b/proofs/logic.ml index a38a36bdcc..e80f5a64c7 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -532,7 +532,7 @@ let prim_refiner r sigma goal = push_named_context_val (id,None,t) sign,t,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in - let oterm = Term.mkApp (mkNamedLambda id t ev2 , [| ev1 |]) in + let oterm = Term.mkNamedLetIn id ev1 t ev2 in let sigma = Goal.V82.partial_solution_to sigma goal sg2 oterm in if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5f7fcce572..936c5988f6 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1062,8 +1062,8 @@ let cut c = Proofview.Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in - let f = mkLambda (Name id, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - Sigma (mkApp (f, [|x|]), h, p +> q) + let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in + Sigma (f, h, p +> q) end } else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") -- cgit v1.2.3 From a593bb93b3047986bf9ac335ab21530621962885 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 22:37:13 +0100 Subject: Preventing an unwanted warning 5 "this function application is partial" which e.g. OCaml 4.02.1 displays. --- plugins/micromega/coq_micromega.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 470e21c820..c008a3aa71 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -82,10 +82,10 @@ let _ = optread = (fun () -> !lia_enum); optwrite = (fun x -> lia_enum := x) } in - ignore (declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth)) ; - ignore (declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth)) ; - ignore (declare_bool_option lia_enum_opt) - + let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in + let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in + let _ = declare_bool_option lia_enum_opt in + () (** * Initialize a tag type to the Tag module declaration (see Mutils). -- cgit v1.2.3 From 9e0cabdaf2055a9bef075d122260a96bb51df2aa Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 23:06:14 +0100 Subject: Fixing output test Existentials.v after eec77191b. --- test-suite/output/Existentials.out | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out index 483a9ea792..52e1e0ed01 100644 --- a/test-suite/output/Existentials.out +++ b/test-suite/output/Existentials.out @@ -1,5 +1,5 @@ Existential 1 = -?Goal0 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] +?Goal1 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] Existential 2 = ?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) -Existential 3 = ?e : [q : nat n : nat m : nat |- n = ?y] +Existential 3 = ?Goal0 : [q : nat n : nat m : nat |- n = ?y] -- cgit v1.2.3 From b382bb1b42319d7be422f92fd196df8bfbe21a83 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 8 Nov 2015 09:47:12 +0100 Subject: Adapting output test inference.v after c23f0cab6 (experimenting printing the type of the defined term of a LetIn). --- test-suite/output/inference.out | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index f2d1447785..c5a393408e 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -6,7 +6,7 @@ fun e : option L => match e with : option L -> option L fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H : forall m n p : nat, S m <= S n + p -> m <= n + p -fun n : nat => let x := A n in ?y ?y0 : T n +fun n : nat => let x := A n : T n in ?y ?y0 : T n : forall n : nat, T n where ?y : [n : nat x := A n : T n |- ?T0 -> T n] -- cgit v1.2.3 From b3aba0467a99ce8038816b845cf883be3521fce8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 9 Nov 2015 13:39:00 +0100 Subject: Pushing the backtrace in conversion anomalies. --- pretyping/reductionops.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0714c93b4f..156c9a2772 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1251,13 +1251,18 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV +let report_anomaly _ = + let e = UserError ("", Pp.str "Conversion test raised an anomaly") in + let e = Errors.push e in + iraise e + let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in let _ = f ~evars reds env (Evd.universes sigma) x y in true with Reduction.NotConvertible -> false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma @@ -1275,7 +1280,7 @@ let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true with Reduction.NotConvertible -> false | Univ.UniverseInconsistency _ -> false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let sigma_compare_sorts env pb s0 s1 sigma = match pb with @@ -1316,7 +1321,7 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) with | Reduction.NotConvertible -> sigma, false | Univ.UniverseInconsistency _ when catch_incon -> sigma, false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) -- cgit v1.2.3 From 08fa634493b8635a77174bbdcd0e1529e3c40279 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 9 Nov 2015 18:43:50 +0100 Subject: Fix bug #4404: [remember] gives Error: Conversion test raised an anomaly. --- tactics/tactics.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 37b715ebe2..0a013e95f7 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2345,7 +2345,12 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let t = match ty with Some t -> t | _ -> typ_of env sigma c in + let (sigma, t) = match ty with + | Some t -> (sigma, t) + | None -> + let t = typ_of env sigma c in + Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t + in let eq_tac gl = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with -- cgit v1.2.3 From 5587499e721f4aa1f2cf35596a8f7aa58d852592 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 10 Nov 2015 11:17:20 +0100 Subject: Test for bug #4404. --- test-suite/bugs/closed/4404.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/4404.v diff --git a/test-suite/bugs/closed/4404.v b/test-suite/bugs/closed/4404.v new file mode 100644 index 0000000000..27b43a61d4 --- /dev/null +++ b/test-suite/bugs/closed/4404.v @@ -0,0 +1,4 @@ +Inductive Foo : Type -> Type := foo A : Foo A. +Goal True. + remember Foo. + -- cgit v1.2.3 From bde12b7066d7d1f3849d529428b2be3343a27787 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 17:37:42 +0100 Subject: Fixing a bug in reporting ill-formed constructor. For instance, Inductive a (x:=1) := C : a -> True. was wrongly reporting Error: The type of constructor C is not valid; its conclusion must be "a" applied to its parameter. Also "simplifying" explain_ind_err. --- kernel/indtypes.ml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 8b03df64c6..5e899d07be 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -337,7 +337,7 @@ let typecheck_inductive env mie = type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int - | LocalNotConstructor + | LocalNotConstructor of rel_context * constr list | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -348,7 +348,7 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env nbpar c nargs err = +let explain_ind_err id ntyp env nbpar c err = let (lpar,c') = mind_extract_params nbpar c in match err with | LocalNonPos kt -> @@ -356,9 +356,11 @@ let explain_ind_err id ntyp env nbpar c nargs err = | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) - | LocalNotConstructor -> + | LocalNotConstructor (paramsctxt,args)-> + let nparams = rel_context_nhyps paramsctxt in raise (InductiveError - (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs))) + (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams, + List.length args - nparams))) | LocalNonPar (n,i,l) -> raise (InductiveError (NonPar (env,c',n,mkRel i, mkRel (l+nbpar)))) @@ -547,7 +549,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname begin match hd with | Rel j when Int.equal j (n + ntypes - i - 1) -> check_correct_par ienv hyps (ntypes - i) largs - | _ -> raise (IllFormedInd LocalNotConstructor) + | _ -> raise (IllFormedInd (LocalNotConstructor(hyps,largs))) end else if not (List.for_all (noccur_between n ntypes) largs) @@ -563,7 +565,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname try check_constructors ienv true nmr rawc with IllFormedInd err -> - explain_ind_err id (ntypes-i) env lparams c nargs err) + explain_ind_err id (ntypes-i) env lparams c err) (Array.of_list lcnames) indlc in let irecargs = Array.map snd irecargs_nmr -- cgit v1.2.3 From 1b163c6230ecd78526bb404fb2b7cc04985df2d9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 22 Oct 2015 17:29:28 +0200 Subject: Typo. --- tactics/ftactic.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml index fea0432aea..a688b94879 100644 --- a/tactics/ftactic.ml +++ b/tactics/ftactic.ml @@ -16,7 +16,7 @@ type 'a focus = (** Type of tactics potentially goal-dependent. If it contains a [Depends], then the length of the inner list is guaranteed to be the number of - currently focussed goals. Otherwise it means the tactic does not depends + currently focussed goals. Otherwise it means the tactic does not depend on the current set of focussed goals. *) type 'a t = 'a focus Proofview.tactic -- cgit v1.2.3 From ab1d8792143a05370a1efe3d19469c25b82d7097 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 16:33:29 +0100 Subject: Dead code from the commit having introduced primitive projections (a4043608). --- kernel/indtypes.ml | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 5e899d07be..351de9ee88 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -112,18 +112,18 @@ let is_unit constrsinfos = | [] -> (* type without constructors *) true | _ -> false -let infos_and_sort env ctx t = - let rec aux env ctx t max = +let infos_and_sort env t = + let rec aux env t max = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = Environ.push_rel (name,None,varj.utj_val) env in let max = Universe.sup max (univ_of_sort varj.utj_type) in - aux env1 ctx c2 max + aux env1 c2 max | _ when is_constructor_head t -> max | _ -> (* don't fail if not positive, it is tested later *) max - in aux env ctx t Universe.type0m + in aux env t Universe.type0m (* Computing the levels of polymorphic inductive types @@ -148,14 +148,14 @@ let infos_and_sort env ctx t = (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) -let infer_constructor_packet env_ar_par ctx params lc = +let infer_constructor_packet env_ar_par params lc = (* type-check the constructors *) let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in (* compute the max of the sorts of the products of the constructors types *) - let levels = List.map (infos_and_sort env_ar_par ctx) lc in + let levels = List.map (infos_and_sort env_ar_par) lc in let isunit = is_unit levels in let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in let level = List.fold_left (fun max l -> Universe.sup max l) min levels in @@ -261,8 +261,7 @@ let typecheck_inductive env mie = List.fold_right2 (fun ind arity_data inds -> let (lc',cstrs_univ) = - infer_constructor_packet env_ar_par ContextSet.empty - params ind.mind_entry_lc in + infer_constructor_packet env_ar_par params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in let ind' = (arity_data,consnames,lc',cstrs_univ) in ind'::inds) -- cgit v1.2.3 From bd1c976531ad6154339fff7e48e85dbe7951de23 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 9 Sep 2015 11:20:04 +0200 Subject: Activating bracketing of last or-and introduction pattern by default for more regularity. --- CHANGES | 5 +++++ tactics/tactics.ml | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGES b/CHANGES index 5d6dd69c60..10ec10a5e4 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,8 @@ +Changes beyond V8.5 +=================== + +- Flag "Bracketing Last Introduction Pattern" is now on by default. + Changes from V8.5beta2 to V8.5beta3 =================================== diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 221c661b21..c26ea56784 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -146,7 +146,7 @@ let _ = Kept as false for compatibility. *) -let bracketing_last_or_and_intro_pattern = ref false +let bracketing_last_or_and_intro_pattern = ref true let use_bracketing_last_or_and_intro_pattern () = !bracketing_last_or_and_intro_pattern -- cgit v1.2.3 From 575fdab5df7c861692b19c62c2004c339c8621df Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 9 Sep 2015 11:21:55 +0200 Subject: Listing separately changes from 8.5betas to final 8.5 and further changes from final 8.5 to next version. --- CHANGES | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/CHANGES b/CHANGES index 10ec10a5e4..91d5f0baa6 100644 --- a/CHANGES +++ b/CHANGES @@ -1,7 +1,16 @@ Changes beyond V8.5 =================== +Tactics + - Flag "Bracketing Last Introduction Pattern" is now on by default. +- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract + tactical w.r.t. variables appearing in the body of the proof. + +Program + +- The "Shrink Obligations" flag now applies to all obligations, not only those + solved by the automatic tactic. Changes from V8.5beta2 to V8.5beta3 =================================== -- cgit v1.2.3 From 07620386b3c1b535ee7e43306a6345f015a318f0 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 31 Aug 2015 20:53:45 +0200 Subject: Fixing #1225: we now skip the canonically built binding contexts of the return clause and of the branches in a "match", computing them automatically when using the "at" clause of pattern, destruct, ... In principle, this is a source of incompatibilities in the numbering, since the internal binders of a "match" are now skipped. We shall deal with that later on. --- pretyping/find_subterm.ml | 81 ++++++++++++++++++++++++++++++++----------- pretyping/find_subterm.mli | 5 +-- pretyping/unification.ml | 13 +++---- test-suite/bugs/closed/1225.v | 12 +++++++ 4 files changed, 83 insertions(+), 28 deletions(-) create mode 100644 test-suite/bugs/closed/1225.v diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 95a6ba79db..c8d90fffea 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -14,6 +14,8 @@ open Locus open Term open Nameops open Termops +open Environ +open Inductiveops open Pretype_errors (** Processing occurrences *) @@ -73,6 +75,17 @@ let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) = let acc,typ = f acc typ in acc,(id,Some body,typ) +let rec process_under_binders f envk sign p = + let rec aux (env,k) sign p = + match (sign,kind_of_term p) with + | [], _ -> f (env,k) p + | (_,None,t as d)::sign, Lambda (na,_,p) -> + mkLambda (na,t,aux (push_rel d env,k+1) sign p) + | (_,(Some c),t as d)::sign, LetIn (na,_,_,p) -> + mkLetIn (na,c,t,aux (push_rel d env,k+1) sign p) + | _ -> assert false + in aux envk (List.rev sign) p + (** Finding a subterm up to some testing function *) exception SubtermUnificationError of subterm_unification_error @@ -82,6 +95,7 @@ exception NotUnifiable of (constr * constr * unification_error) option type 'a testing_function = { match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; + get_evars : 'a -> Evd.evar_map; mutable testing_state : 'a; mutable last_found : position_reporting option } @@ -91,7 +105,7 @@ type 'a testing_function = { (b,l), b=true means no occurrence except the ones in l and b=false, means all occurrences except the ones in l *) -let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = +let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t = let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref occ in @@ -103,9 +117,9 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = with NotUnifiable e when not like_first -> let lastpos = Option.get test.last_found in raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in - let rec substrec k t = + let rec substrec (env,k) t = if nowhere_except_in && !pos > maxocc then t else - if not (Vars.closed0 t) then subst_below k t else + if not (Vars.closed0 t) then subst_below (env,k) t else try let subst = test.match_fun test.testing_state t in if Locusops.is_selected !pos occs then @@ -118,31 +132,51 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = add_subst t subst; incr pos; (* Check nested matching subterms *) if occs != Locus.AllOccurrences && occs != Locus.NoOccurrences then - begin nested := true; ignore (subst_below k t); nested := false end; + begin nested := true; ignore (subst_below (env,k) t); nested := false end; (* Do the effective substitution *) Vars.lift k (bywhat ())) else - (incr pos; subst_below k t) + (incr pos; subst_below (env,k) t) with NotUnifiable _ -> - subst_below k t - and subst_below k t = - map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t - in - let t' = substrec 0 t in + subst_below (env,k) t + and subst_below (env,k) t = + match kind_of_term t with + | Case (ci,p,c,br) -> + let c = substrec (env,k) c in + let sigma = test.get_evars test.testing_state in + let t = Retyping.get_type_of env sigma c in + let IndType (indf,_) = find_rectype env sigma t in + let p = subst_cases_predicate (env,k) indf p in + let cstrs = get_constructors env indf in + let br = Array.map2 (subst_cases_branch (env,k) indf) br cstrs in + mkCase (ci,p,c,br) + | _ -> + map_constr_with_binders_left_to_right (fun d (env,k) -> (push_rel d env,k+1)) + substrec (env,k) t + and subst_cases_predicate (env,k) indf p = + let arsign,_ = get_arity env indf in + let nrealargs = List.length arsign in + let (ind,params) = dest_ind_family indf in + let mind = applist (mkIndU ind, + (List.map (Vars.lift nrealargs) params)@(extended_rel_list 0 arsign)) in + process_under_binders substrec (env,k) ((Anonymous,None,mind)::arsign) p + and subst_cases_branch (env,k) indf b cstr = + process_under_binders substrec (env,k) cstr.cs_args b in + let t' = substrec (env,0) t in (!pos, t') -let replace_term_occ_modulo occs test bywhat t = +let replace_term_occ_modulo occs test bywhat env t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in proceed_with_occurrences - (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t + (replace_term_occ_gen_modulo occs' like_first test bywhat env None) occs' t -let replace_term_occ_decl_modulo occs test bywhat d = +let replace_term_occ_decl_modulo occs test bywhat env d = let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in proceed_with_occurrences (map_named_declaration_with_hyploc - (replace_term_occ_gen_modulo plocs like_first test bywhat) + (replace_term_occ_gen_modulo plocs like_first test bywhat env) hyploc) plocs d @@ -156,23 +190,30 @@ let make_eq_univs_test env evd c = with Evd.UniversesDiffer -> raise (NotUnifiable None) else raise (NotUnifiable None)); merge_fun = (fun evd _ -> evd); + get_evars = (fun evd -> evd); testing_state = evd; last_found = None } -let subst_closed_term_occ env evd occs c t = - let test = make_eq_univs_test env evd c in +let subst_closed_term_occ env sigma occs c t = + let test = make_eq_univs_test env sigma c in let bywhat () = mkRel 1 in - let t' = replace_term_occ_modulo occs test bywhat t in + let typ = Retyping.get_type_of env sigma c in + assert (rel_context env == []); + let env = push_rel (Anonymous,Some c,typ) env in + let t' = replace_term_occ_modulo occs test bywhat env t in t', test.testing_state -let subst_closed_term_occ_decl env evd occs c d = - let test = make_eq_univs_test env evd c in +let subst_closed_term_occ_decl env sigma occs c d = + let test = make_eq_univs_test env sigma c in let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in let bywhat () = mkRel 1 in + let typ = Retyping.get_type_of env sigma c in + assert (rel_context env == []); + let env = push_rel (Anonymous,Some c,typ) env in proceed_with_occurrences (map_named_declaration_with_hyploc - (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat None) + (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat env None) hyploc) plocs d, test.testing_state diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 47d9654e57..23d7ed9498 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -29,6 +29,7 @@ exception SubtermUnificationError of subterm_unification_error type 'a testing_function = { match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; + get_evars : 'a -> evar_map; mutable testing_state : 'a; mutable last_found : position_reporting option } @@ -43,14 +44,14 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) val replace_term_occ_modulo : occurrences or_like_first -> - 'a testing_function -> (unit -> constr) -> constr -> constr + 'a testing_function -> (unit -> constr) -> env -> constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> - named_declaration -> named_declaration + env -> named_declaration -> named_declaration (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 269c723e30..002fd0c025 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1530,6 +1530,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = | None, Some _ -> c2 | None, None -> None in { match_fun = matching_fun; merge_fun = merge_fun; + get_evars = (function None -> sigma | Some (evd,_,_) -> evd); testing_state = None; last_found = None }, (fun test -> match test.testing_state with | None -> None @@ -1545,8 +1546,8 @@ let make_eq_test env evd c = (make_eq_univs_test env evd c, out) let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = + let t = match ty with Some t -> t | None -> get_type_of env sigma c in let id = - let t = match ty with Some t -> t | None -> get_type_of env sigma c in let x = id_of_name_using_hdchar (Global.env()) t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else @@ -1554,8 +1555,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = errorlabstrm "Unification.make_abstraction_core" (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else - x - in + x in + let env' = push_named (id, Some c, t) env in let likefirst = clause_with_generic_occurrences occs in let mkvarid () = mkVar id in let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) = @@ -1571,7 +1572,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val d sign,depdecls) | AllOccurrences, InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in + let newdecl = replace_term_occ_decl_modulo occ test mkvarid env' d in if Context.eq_named_declaration d newdecl && not (indirectly_dependent c d depdecls) then @@ -1582,7 +1583,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val newdecl sign, newdecl :: depdecls) | occ -> (* There are specific occurrences, hence not like first *) - let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid d in + let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid env' d in (push_named_context_val newdecl sign, newdecl :: depdecls) in try let sign,depdecls = @@ -1592,7 +1593,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo occ test mkvarid concl + replace_term_occ_modulo occ test mkvarid env' concl in let lastlhyp = if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in diff --git a/test-suite/bugs/closed/1225.v b/test-suite/bugs/closed/1225.v new file mode 100644 index 0000000000..a7799b35fe --- /dev/null +++ b/test-suite/bugs/closed/1225.v @@ -0,0 +1,12 @@ +(* Taking automatically into account internal dependencies of a |match] *) + +Let a n := @exist nat _ _ (refl_equal (n + 1)). +Goal let (n, _) := a 3 in n = 4. +pattern 3 at 1. +Abort. + +Goal match refl_equal 0 in _ = n return n = 0 with + | refl_equal => refl_equal 0 + end = refl_equal 0. +pattern 0 at 1 2 3 4 5 6. +Abort. -- cgit v1.2.3 From d57e30cfe8f68987ed216415079f4dab42065408 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 10 Nov 2015 17:26:36 +0100 Subject: Revert "Fixing #1225: we now skip the canonically built binding contexts of" This reverts commit 07620386b3c1b535ee7e43306a6345f015a318f0. Very sorry not ready. --- pretyping/find_subterm.ml | 81 +++++++++++-------------------------------- pretyping/find_subterm.mli | 5 ++- pretyping/unification.ml | 13 ++++--- test-suite/bugs/closed/1225.v | 12 ------- 4 files changed, 28 insertions(+), 83 deletions(-) delete mode 100644 test-suite/bugs/closed/1225.v diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index c8d90fffea..95a6ba79db 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -14,8 +14,6 @@ open Locus open Term open Nameops open Termops -open Environ -open Inductiveops open Pretype_errors (** Processing occurrences *) @@ -75,17 +73,6 @@ let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) = let acc,typ = f acc typ in acc,(id,Some body,typ) -let rec process_under_binders f envk sign p = - let rec aux (env,k) sign p = - match (sign,kind_of_term p) with - | [], _ -> f (env,k) p - | (_,None,t as d)::sign, Lambda (na,_,p) -> - mkLambda (na,t,aux (push_rel d env,k+1) sign p) - | (_,(Some c),t as d)::sign, LetIn (na,_,_,p) -> - mkLetIn (na,c,t,aux (push_rel d env,k+1) sign p) - | _ -> assert false - in aux envk (List.rev sign) p - (** Finding a subterm up to some testing function *) exception SubtermUnificationError of subterm_unification_error @@ -95,7 +82,6 @@ exception NotUnifiable of (constr * constr * unification_error) option type 'a testing_function = { match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; - get_evars : 'a -> Evd.evar_map; mutable testing_state : 'a; mutable last_found : position_reporting option } @@ -105,7 +91,7 @@ type 'a testing_function = { (b,l), b=true means no occurrence except the ones in l and b=false, means all occurrences except the ones in l *) -let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t = +let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref occ in @@ -117,9 +103,9 @@ let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t = with NotUnifiable e when not like_first -> let lastpos = Option.get test.last_found in raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in - let rec substrec (env,k) t = + let rec substrec k t = if nowhere_except_in && !pos > maxocc then t else - if not (Vars.closed0 t) then subst_below (env,k) t else + if not (Vars.closed0 t) then subst_below k t else try let subst = test.match_fun test.testing_state t in if Locusops.is_selected !pos occs then @@ -132,51 +118,31 @@ let replace_term_occ_gen_modulo occs like_first test bywhat env cl occ t = add_subst t subst; incr pos; (* Check nested matching subterms *) if occs != Locus.AllOccurrences && occs != Locus.NoOccurrences then - begin nested := true; ignore (subst_below (env,k) t); nested := false end; + begin nested := true; ignore (subst_below k t); nested := false end; (* Do the effective substitution *) Vars.lift k (bywhat ())) else - (incr pos; subst_below (env,k) t) + (incr pos; subst_below k t) with NotUnifiable _ -> - subst_below (env,k) t - and subst_below (env,k) t = - match kind_of_term t with - | Case (ci,p,c,br) -> - let c = substrec (env,k) c in - let sigma = test.get_evars test.testing_state in - let t = Retyping.get_type_of env sigma c in - let IndType (indf,_) = find_rectype env sigma t in - let p = subst_cases_predicate (env,k) indf p in - let cstrs = get_constructors env indf in - let br = Array.map2 (subst_cases_branch (env,k) indf) br cstrs in - mkCase (ci,p,c,br) - | _ -> - map_constr_with_binders_left_to_right (fun d (env,k) -> (push_rel d env,k+1)) - substrec (env,k) t - and subst_cases_predicate (env,k) indf p = - let arsign,_ = get_arity env indf in - let nrealargs = List.length arsign in - let (ind,params) = dest_ind_family indf in - let mind = applist (mkIndU ind, - (List.map (Vars.lift nrealargs) params)@(extended_rel_list 0 arsign)) in - process_under_binders substrec (env,k) ((Anonymous,None,mind)::arsign) p - and subst_cases_branch (env,k) indf b cstr = - process_under_binders substrec (env,k) cstr.cs_args b in - let t' = substrec (env,0) t in + subst_below k t + and subst_below k t = + map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t + in + let t' = substrec 0 t in (!pos, t') -let replace_term_occ_modulo occs test bywhat env t = +let replace_term_occ_modulo occs test bywhat t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in proceed_with_occurrences - (replace_term_occ_gen_modulo occs' like_first test bywhat env None) occs' t + (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t -let replace_term_occ_decl_modulo occs test bywhat env d = +let replace_term_occ_decl_modulo occs test bywhat d = let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in proceed_with_occurrences (map_named_declaration_with_hyploc - (replace_term_occ_gen_modulo plocs like_first test bywhat env) + (replace_term_occ_gen_modulo plocs like_first test bywhat) hyploc) plocs d @@ -190,30 +156,23 @@ let make_eq_univs_test env evd c = with Evd.UniversesDiffer -> raise (NotUnifiable None) else raise (NotUnifiable None)); merge_fun = (fun evd _ -> evd); - get_evars = (fun evd -> evd); testing_state = evd; last_found = None } -let subst_closed_term_occ env sigma occs c t = - let test = make_eq_univs_test env sigma c in +let subst_closed_term_occ env evd occs c t = + let test = make_eq_univs_test env evd c in let bywhat () = mkRel 1 in - let typ = Retyping.get_type_of env sigma c in - assert (rel_context env == []); - let env = push_rel (Anonymous,Some c,typ) env in - let t' = replace_term_occ_modulo occs test bywhat env t in + let t' = replace_term_occ_modulo occs test bywhat t in t', test.testing_state -let subst_closed_term_occ_decl env sigma occs c d = - let test = make_eq_univs_test env sigma c in +let subst_closed_term_occ_decl env evd occs c d = + let test = make_eq_univs_test env evd c in let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in let bywhat () = mkRel 1 in - let typ = Retyping.get_type_of env sigma c in - assert (rel_context env == []); - let env = push_rel (Anonymous,Some c,typ) env in proceed_with_occurrences (map_named_declaration_with_hyploc - (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat env None) + (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat None) hyploc) plocs d, test.testing_state diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 23d7ed9498..47d9654e57 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -29,7 +29,6 @@ exception SubtermUnificationError of subterm_unification_error type 'a testing_function = { match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; - get_evars : 'a -> evar_map; mutable testing_state : 'a; mutable last_found : position_reporting option } @@ -44,14 +43,14 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) val replace_term_occ_modulo : occurrences or_like_first -> - 'a testing_function -> (unit -> constr) -> env -> constr -> constr + 'a testing_function -> (unit -> constr) -> constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> - env -> named_declaration -> named_declaration + named_declaration -> named_declaration (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 002fd0c025..269c723e30 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1530,7 +1530,6 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = | None, Some _ -> c2 | None, None -> None in { match_fun = matching_fun; merge_fun = merge_fun; - get_evars = (function None -> sigma | Some (evd,_,_) -> evd); testing_state = None; last_found = None }, (fun test -> match test.testing_state with | None -> None @@ -1546,8 +1545,8 @@ let make_eq_test env evd c = (make_eq_univs_test env evd c, out) let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = - let t = match ty with Some t -> t | None -> get_type_of env sigma c in let id = + let t = match ty with Some t -> t | None -> get_type_of env sigma c in let x = id_of_name_using_hdchar (Global.env()) t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else @@ -1555,8 +1554,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = errorlabstrm "Unification.make_abstraction_core" (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else - x in - let env' = push_named (id, Some c, t) env in + x + in let likefirst = clause_with_generic_occurrences occs in let mkvarid () = mkVar id in let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) = @@ -1572,7 +1571,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val d sign,depdecls) | AllOccurrences, InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - let newdecl = replace_term_occ_decl_modulo occ test mkvarid env' d in + let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in if Context.eq_named_declaration d newdecl && not (indirectly_dependent c d depdecls) then @@ -1583,7 +1582,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val newdecl sign, newdecl :: depdecls) | occ -> (* There are specific occurrences, hence not like first *) - let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid env' d in + let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid d in (push_named_context_val newdecl sign, newdecl :: depdecls) in try let sign,depdecls = @@ -1593,7 +1592,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo occ test mkvarid env' concl + replace_term_occ_modulo occ test mkvarid concl in let lastlhyp = if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in diff --git a/test-suite/bugs/closed/1225.v b/test-suite/bugs/closed/1225.v deleted file mode 100644 index a7799b35fe..0000000000 --- a/test-suite/bugs/closed/1225.v +++ /dev/null @@ -1,12 +0,0 @@ -(* Taking automatically into account internal dependencies of a |match] *) - -Let a n := @exist nat _ _ (refl_equal (n + 1)). -Goal let (n, _) := a 3 in n = 4. -pattern 3 at 1. -Abort. - -Goal match refl_equal 0 in _ = n return n = 0 with - | refl_equal => refl_equal 0 - end = refl_equal 0. -pattern 0 at 1 2 3 4 5 6. -Abort. -- cgit v1.2.3 From e67760138af866b788db7b43a8e93c5f65a9a84e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 10 Nov 2015 18:17:37 +0100 Subject: Updating Compat85.v after bd1c97653 on bracketing last or-and introduction pattern by default. --- theories/Compat/Coq85.v | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v index 1622f2aeda..7ce04a662e 100644 --- a/theories/Compat/Coq85.v +++ b/theories/Compat/Coq85.v @@ -7,3 +7,10 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.5 *) + +(* In 8.5, "intros [|]", taken e.g. on a goal "A\/B->C", does not + behave as "intros [H|H]" but leave instead hypotheses quantified in + the goal, here producing subgoals A->C and B->C. *) + +Unset Bracketing Last Introduction Pattern. + -- cgit v1.2.3 From f0ff590f380fb3d9fac6ebfdd6cfd7bf6874658e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 10 Nov 2015 18:43:07 +0100 Subject: Updating test-suite after Bracketing Last Introduction Pattern set by default. Interestingly, there is an example where it makes the rest of the proof less natural. Goal forall x y:Z, ... intros [y|p1[|p2|p2]|p1[|p2|p2]]. where case analysis on y is not only in the 2nd and 3rd case, is not anymore easy to do. Still, I find the bracketing of intro-patterns a natural property, and its generalization in all situations a natural expectation for uniformity. So, what to do? The following is e.g. not as compact and "one-shot": intros [|p1|p1]; [intros y|intros [|p2|p2] ..]. --- test-suite/micromega/square.v | 3 +-- test-suite/output/Cases.v | 2 +- test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v | 20 ++++++++++---------- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v index 8767f6874e..abf8be72ef 100644 --- a/test-suite/micromega/square.v +++ b/test-suite/micromega/square.v @@ -53,8 +53,7 @@ Qed. Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. Proof. - unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Z.mul_1_r. - intros HQeq. + unfold Qeq; intros (x,HQeq); simpl (Qden (2#1)) in HQeq; rewrite Z.mul_1_r in HQeq. assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto). assert (Hnx : (Qnum x <> 0)%Z) diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4116a5ebc2..a95b085ac0 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -73,7 +73,7 @@ Definition f : B -> True. Proof. intros []. -destruct b as [|] ; intros _ ; exact Logic.I. +destruct b as [|] ; exact Logic.I. Defined. Print f. diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v index 0d75d52a31..06357cfc21 100644 --- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -1902,14 +1902,14 @@ Qed. Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor. + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; constructor. Qed. Lemma Zsgn_16 : forall x y : Z, Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right ]; repeat split. Qed. @@ -1917,13 +1917,13 @@ Lemma Zsgn_17 : forall x y : Z, Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right ]; repeat split. Qed. Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right | right ]; constructor. Qed. @@ -1932,40 +1932,40 @@ Qed. Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; discriminate H || (constructor || apply Zsgn_12; assumption). Qed. Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; discriminate H || (constructor || apply Zsgn_11; assumption). Qed. Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z. Proof. - intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros [|p1|p1] [|p2|p2]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z. Proof. - intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros [|p1|p1] [|p2|p2]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. -- cgit v1.2.3 From 701a69732ef2abfc7384296e090a3e9bd7604bbd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 11 Nov 2015 18:45:32 +0100 Subject: Fixing bug #3554: Anomaly: Anonymous implicit argument. We just handle unnamed implicits using a dummy name. Note that the implicit argument logic should still output warnings whenever the user writes implicit arguments that won't be taken into account, but I'll leave that for another time. --- interp/constrintern.ml | 2 +- test-suite/bugs/closed/3554.v | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/3554.v diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c754f1910c..8afe630ec5 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -317,7 +317,7 @@ let rec it_mkGLambda loc2 env body = let build_impls = function |Implicit -> (function |Name id -> Some (id, Impargs.Manual, (true,true)) - |Anonymous -> anomaly (Pp.str "Anonymous implicit argument")) + |Anonymous -> Some (Id.of_string "_", Impargs.Manual, (true,true))) |Explicit -> fun _ -> None let impls_type_list ?(args = []) = diff --git a/test-suite/bugs/closed/3554.v b/test-suite/bugs/closed/3554.v new file mode 100644 index 0000000000..13a79cc840 --- /dev/null +++ b/test-suite/bugs/closed/3554.v @@ -0,0 +1 @@ +Example foo (f : forall {_ : Type}, Type) : Type. -- cgit v1.2.3 From 2f56f0fcf21902bb1317f1d6f7ba4b593d712646 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 16:04:43 -0500 Subject: Fix bug #4293: ensure let-ins do not contain algebraic universes in their type annotation. --- pretyping/evarsolve.ml | 10 ++++++---- pretyping/evarsolve.mli | 3 ++- pretyping/pretyping.ml | 4 +++- test-suite/bugs/closed/4293.v | 7 +++++++ 4 files changed, 18 insertions(+), 6 deletions(-) create mode 100644 test-suite/bugs/closed/4293.v diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 35bc1de593..aeb2445d1c 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -47,7 +47,7 @@ let refresh_level evd s = | None -> true | Some l -> not (Evd.is_flexible_level evd l) -let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = +let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t = let evdref = ref evd in let modified = ref false in let rec refresh status dir t = @@ -98,7 +98,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = if isArity t then (match pbty with | None -> t - | Some dir -> refresh univ_rigid dir t) + | Some dir -> refresh status dir t) else (refresh_term_evars false true t; t) in if !modified then !evdref, t' else !evdref, t @@ -609,7 +609,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let id = next_name_away na avoid in let evd,t_in_sign = let s = Retyping.get_sort_of env evd t_in_env in - let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in let evd,b_in_sign = match b with @@ -627,7 +628,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = in let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in - let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in let evd,ev2_in_sign = diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 21d976091f..86a1e3e0ce 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -34,7 +34,8 @@ type conv_fun_bool = val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map -val refresh_universes : ?inferred:bool -> ?onlyalg:bool (* Only algebraic universes *) -> +val refresh_universes : ?status:Evd.rigid -> + ?onlyalg:bool (* Only algebraic universes *) -> bool option (* direction: true for levels lower than the existing levels *) -> env -> evar_map -> types -> evar_map * types diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index d354a6c3c4..dd4fcf1981 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -739,7 +739,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ pretype (mk_tycon tj.utj_val) env evdref lvar c | _ -> pretype empty_tycon env evdref lvar c1 in - let t = j.uj_type in + let t = evd_comb1 (Evarsolve.refresh_universes + ~onlyalg:true ~status:Evd.univ_flexible (Some false) env) + evdref j.uj_type in (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) diff --git a/test-suite/bugs/closed/4293.v b/test-suite/bugs/closed/4293.v new file mode 100644 index 0000000000..3671c931b7 --- /dev/null +++ b/test-suite/bugs/closed/4293.v @@ -0,0 +1,7 @@ +Module Type Foo. +Definition T := let X := Type in Type. +End Foo. + +Module M : Foo. +Definition T := let X := Type in Type. +End M. \ No newline at end of file -- cgit v1.2.3 From ca30a8be08beeae77d42b6cb5d9f219e3932a3f7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 17:12:39 -0500 Subject: Fix bug #3257, setoid_reflexivity should fail if not completing the goal. --- tactics/rewrite.ml | 6 ++++-- test-suite/bugs/closed/3257.v | 5 +++++ 2 files changed, 9 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/3257.v diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index e8a7c0f600..af6953bf85 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -2077,8 +2077,10 @@ let poly_proof getp gett env evm car rel = let setoid_reflexivity = setoid_proof "reflexive" (fun env evm car rel -> - tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof - env evm car rel) (fun c -> Proofview.V82.of_tactic (apply c))) + tac_open (poly_proof PropGlobal.get_reflexive_proof + TypeGlobal.get_reflexive_proof + env evm car rel) + (fun c -> tclCOMPLETE (Proofview.V82.of_tactic (apply c)))) (reflexivity_red true) let setoid_symmetry = diff --git a/test-suite/bugs/closed/3257.v b/test-suite/bugs/closed/3257.v new file mode 100644 index 0000000000..d8aa6a0479 --- /dev/null +++ b/test-suite/bugs/closed/3257.v @@ -0,0 +1,5 @@ +Require Import Setoid Morphisms Basics. +Lemma foo A B (P : B -> Prop) : + pointwise_relation _ impl (fun z => A -> P z) P. +Proof. + Fail reflexivity. -- cgit v1.2.3 From 67da4b45ef65db59b2d7ba1549351d792e1b27d9 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 17:15:37 -0500 Subject: Fix bug #3735: interpretation of "->" in Program follows the standard one. --- CHANGES | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES b/CHANGES index 7b50dfae56..f67c34b81b 100644 --- a/CHANGES +++ b/CHANGES @@ -397,6 +397,9 @@ Program - "Solve Obligations using" changed to "Solve Obligations with", consistent with "Proof with". - Program Lemma, Definition now respect automatic introduction. +- Program Lemma, Definition, etc.. now interpret "->" like Lemma and + Definition as a non-dependent arrow (potential source of + incompatibility). - Add/document "Set Hide Obligations" (to hide obligations in the final term inside an implicit argument) and "Set Shrink Obligations" (to minimize dependencies of obligations defined by tactics). -- cgit v1.2.3 From a3f0a0daf58964a54b1e6fb1f8252f68a8c9c8ea Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 17:47:39 -0500 Subject: Fix bug #3998: when using typeclass resolution for conversion, allow only one disjoint component of the typeclasses instances to resolve. --- pretyping/coercion.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e61e52c178..3163ac0e6e 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -343,7 +343,7 @@ let coerce_itf loc env evd v t c1 = let saturate_evd env evd = Typeclasses.resolve_typeclasses - ~filter:Typeclasses.no_goals ~split:false ~fail:false env evd + ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = -- cgit v1.2.3 From 834876a3e07fe8053aa99655f21883c3e8927a8c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 6 Nov 2015 17:52:53 -0500 Subject: Ensure that conversion is called on terms of the same type in unification (not necessarily preserved due to the fo approximation rule). --- pretyping/unification.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 24e06007e9..9758aa43c4 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -904,8 +904,18 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb match subst_defined_metas_evars subst cN with | None -> (* some undefined Metas in cN *) None | Some n1 -> - (* No subterm restriction there, too much incompatibilities *) - let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in + (* No subterm restriction there, too much incompatibilities *) + let sigma = + if opt.with_types then + try (* Ensure we call conversion on terms of the same type *) + let tyM = get_type_of curenv ~lax:true sigma m1 in + let tyN = get_type_of curenv ~lax:true sigma n1 in + check_compatibility curenv CUMUL flags substn tyM tyN + with RetypeError _ -> + (* Renounce, maybe metas/evars prevents typing *) sigma + else sigma + in + let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in if b then Some (sigma, metasubst, evarsubst) else if is_ground_term sigma m1 && is_ground_term sigma n1 then -- cgit v1.2.3 From 7de9c1a45a354676a073e216f42c34820e454691 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 11 Nov 2015 20:39:41 +0100 Subject: Now closed. --- test-suite/bugs/opened/3554.v | 1 - 1 file changed, 1 deletion(-) delete mode 100644 test-suite/bugs/opened/3554.v diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v deleted file mode 100644 index 422c5770ea..0000000000 --- a/test-suite/bugs/opened/3554.v +++ /dev/null @@ -1 +0,0 @@ -Fail Example foo (f : forall {_ : Type}, Type) : Type. -- cgit v1.2.3 From 5357b9849bd6eb0be4f8d60b4e1c091ad5167932 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Thu, 5 Nov 2015 19:43:44 +0100 Subject: Prehistory of Coq: asciidoc conversion. Formatting markup + typography. --- dev/doc/README-V1-V5 | 293 --------------------------------------- dev/doc/README-V1-V5.asciidoc | 312 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 312 insertions(+), 293 deletions(-) delete mode 100644 dev/doc/README-V1-V5 create mode 100644 dev/doc/README-V1-V5.asciidoc diff --git a/dev/doc/README-V1-V5 b/dev/doc/README-V1-V5 deleted file mode 100644 index 2ca62e3d74..0000000000 --- a/dev/doc/README-V1-V5 +++ /dev/null @@ -1,293 +0,0 @@ - - Notes on the prehistory of Coq - -This archive contains the sources of the CONSTR ancestor of the Coq proof -assistant. CONSTR, then Coq, was designed and implemented in the Formel team, -joint between the INRIA Rocquencourt laboratory and the Ecole Normale Supérieure -of Paris, from 1984 onwards. - -Version 1 - -This software is a prototype type-checker for a higher-order logical formalism -known as the Theory of Constructions, presented in his PhD thesis by -Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath. -The metamathematical analysis of the system is the -PhD work of Thierry Coquand. The software is mostly the work of Gérard Huet. -Most of the mathematical examples verified with the software are due -to Thierry Coquand. - -The programming language of the CONSTR software (as it was called at the time) -is a version of ML issued from the Edinburgh LCF system and running on -a LISP backend. The main improvements from the original LCF ML are that ML -is compiled rather than interpreted (Gérard Huet building on the original -translator by Lockwood Morris), and that it is enriched by recursively -defined types (work of Guy Cousineau). This ancestor of CAML was used -and improved by Larry Paulson for his implementation of Cambridge LCF. - -Software developments of this prototype occurred from late 1983 to early 1985. - -Version 1.10 was frozen on December 22nd 1984. It is the version used for the -examples in Thierry Coquand's thesis, defended on January 31st 1985. -There was a unique binding operator, used both for universal quantification -(dependent product) at the level of types and functional abstraction (lambda) -at the level of terms/proofs, in the manner of Automath. Substitution -(lambda reduction) was implemented using de Bruijn's indexes. - -Version 1.11 was frozen on February 19th, 1985. It is the version used for the -examples in the paper: -Th. Coquand, G. Huet. Constructions: A Higher Order Proof System for Mechanizing -Mathematics. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag -LNCS 203, pp. 151-184. - -Christine Paulin joined the team at this point, for her DEA research internship. -In her DEA memoir (August 1985) she presents developments for the lambo function -computing the minimal m such that f(m) is greater than n, for f an increasing -integer function, a challenge for constructive mathematics. She also encoded -the majority voting algorithm of Boyer and Moore. - -Version 2 - -The formal system, now renamed as the "Calculus of Constructions", was presented -with a proof of consistency and comparisons with proof systems of Per -Martin Löf, Girard, and the Automath family of N. de Bruijn, in the paper: -T. Coquand and G. Huet. The Calculus of Constructions. -Submitted on June 30th 1985, accepted on December 5th, 1985, -Information and Computation. Preprint as Rapport de Recherche Inria n°530, -Mai 1986. Final version in Information and Computation 76,2/3, Feb. 88. - -An abstraction of the software design, in the form of an abstract machine -for proof checking, and a fuller sequence of mathematical developments was -presented in: -Th. Coquand, G. Huet. Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions. Invited paper, European Logic Colloquium, Orsay, -July 1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. -Published in Logic Colloquium 1985, North-Holland, 1987. - -Version 2.8 was frozen on December 16th, 1985, and served for developing -the exemples in the above papers. - -This calculus was then enriched in version 2.9 with a cumulative hierarchy of -universes. Universe levels were initially explicit natural numbers. -Another improvement was the possibility of automatic synthesis of implicit -type arguments, relieving the user of tedious redundant declarations. - -Christine Paulin wrote an article "Algorithm development in the Calculus of -Constructions", preprint as Rapport de recherche INRIA n°497, March 86. -Final version in Proceedings Symposium on Logic in Computer Science, Cambridge, -MA, 1986 (IEEE Computer Society Press). Besides lambo and majority, -she presents quicksort and a text formatting algorithm. - -Version 2.13 of the calculus of constructions with universes was frozen -on June 25th, 1986. - -A synthetic presentation of type theory along constructive lines with ML -algorithms was given by Gérard Huet in his May 1986 CMU course notes -"Formal Structures for Computation and Deduction". Its chapter -"Induction and Recursion in the Theory of Constructions" was presented -as an invited paper at the Joint Conference on Theory and Practice of Software -Development TAPSOFT’87 at Pise in March 1987, and published as -"Induction Principles Formalized in the Calculus of Constructions" in -Programming of Future Generation Computers, Ed. K. Fuchi and M. Nivat, -North-Holland, 1988. - -Version 3 - -This version saw the beginning of proof automation, with a search algorithm -inspired from PROLOG and the applicative logic programming programs -of the course notes "Formal structures for computation and deduction". -The search algorithm was implemented in ML by Thierry Coquand. -The proof system could thus be used in two modes: proof verification and -proof synthesis, with tactics such as "AUTO". - -The implementation language was now called CAML, for "categorical abstract -machine language". It used as backend the LLM3 virtual machine of Le Lisp -by Jérôme Chailloux. The main developers of CAML were Michel Mauny, -Ascander Suarez and Pierre Weis. - -V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November -1986. V3.4 was developed in the first half of 1987. - -Thierry Coquand held a post-doctoral position in Cambrige University in 1986-87, -where he developed a variant implementation in SML, with which he wrote -some developments on fixpoints in Scott's domains. - -Version 4 - -This version saw the beginning of program extraction from proofs, with -two varieties of the type Prop of propositions, indicating constructive intent. -The proof extraction algorithms were implemented by Christine Paulin-Mohring. - -V4.1 was frozen on July 24th, 1987. It had a first identified library of -mathematical developments (directory exemples), with libraries Logic -(containing impredicative encodings of intuitionistic logic and algebraic -primitives for booleans, natural numbers and list), Peano developing second-order -Peano arithmetic, Arith defining addition, multiplication, euclidean division -and factorial. Typical developments were the Knaster-Tarski theorem -and Newman's lemma from rewriting theory. - -V4.2 was a joint development of a team consisting of Thierry Coquand, Gérard -Huet and Christine Paulin-Mohring. A file V4.2.log records the log of changes. -It was frozen on September 1987 as the last version implemented in CAML 2.3, -and V4.3 followed on CAML 2.5, a more stable development system. - -V4.3 saw the first top-level of the system. Instead of evaluating explicit -quotations, the user could develop his mathematics in a high-level language -called the mathematical vernacular (following Automath terminology). -The user could develop files in the vernacular notation (with .v extension) -which were now separate from the ml sources of the implementation. -Gilles Dowek joined the team to develop the vernacular language as his -DEA internship research. - -A notion of sticky constant was introduced, in order to keep names of lemmas -when local hypotheses of proofs were discharged. This gave a notion -of global mathematical environment with local sections. - -Another significant practical change was that the system, originally developped -on the VAX central computer of our lab, was transferred on SUN personal -workstations, allowing a level of distributed development. -The extraction algorithm was modified, with three annotations Pos, Null and -Typ decorating the sorts Prop and Type. - -Version 4.3 was frozen at the end of November 1987, and was distributed to an -early community of users (among those were Hugo Herbelin and Loic Colson). - -V4.4 saw the first version of (encoded) inductive types. -Now natural numbers could be defined as: -Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. -These inductive types were encoded impredicatively in the calculus, -using a subsystem "rec" due to Christine Paulin. -V4.4 was frozen on March 6th 1988. - -Version 4.5 was the first one to support inductive types and program extraction. -Its banner was "Calcul des Constructions avec Realisations et Synthese". -The vernacular language was enriched to accommodate extraction commands. - -The verification engine design was presented as: -G. Huet. The Constructive Engine. Version 4.5. Invited Conference, 2nd European -Symposium on Programming, Nancy, March 88. -The final paper, describing the V4.9 implementation, appeared in: -A perspective in Theoretical Computer Science, Commemorative Volume in memory -of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. - -Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical -Foundations of Functional Programming organized by Gérard Huet at Austin, Texas. - -Version 4.6 was started during summer 1988. Its main improvement was the -complete rehaul of the proof synthesis engine by Thierry Coquand, with -a tree structure of goals. - -Its source code was communicated to Randy Pollack on September 2nd 1988. -It evolved progressively into LEGO, proof system for Luo's formalism -of Extended Calculus of Constructions. - -The discharge tactic was modified by G. Huet to allow for inter-dependencies -in discharged lemmas. Christine Paulin improved the inductive definition scheme -in order to accommodate predicates of any arity. - -Version 4.7 was started on September 6th, 1988. - -This version starts exploiting the CAML notion of module in order to improve the -modularity of the implementation. Now the term verifier is identified as -a proper module Machine, which the structure of its internal data structures -being hidden and thus accessible only through the legitimate operations. -This machine (the constructive engine) was the trusted core of the -implementation. The proof synthesis mechanism was a separate proof term -generator. Once a complete proof term was synthesized with the help of tactics, -it was entirely re-checked by the engine. Thus there was no need to certify -the tactics, and the system took advantage of this fact by having tactics ignore -the universe levels, universe consistency check being relegated to the final -type-checking pass. This induced a certain puzzlement of early users who saw -their successful proof search ended with QED, followed by silence, followed by -a failure message of universe inconsistency rejection... - -The set of examples comprise set theory experiments by Hugo Herbelin, -and notably the Schroeder-Bernstein theorem. - -Version 4.8, started on October 8th, 1988, saw a major re-implementation of the -abstract syntax type constr, separating variables of the formalism and -metavariables denoting incomplete terms managed by the search mechanism. -A notion of level (with three values TYPE, OBJECT and PROOF) is made explicit -and a type judgement clarifies the constructions, whose implementation is now -fully explicit. Structural equality is speeded up by using pointer equality, -yielding spectacular improvements. Thierry Coquand adapts the proof synthesis -to the new representation, and simplifies pattern matching to 1st order -predicate calculus matching, with important performance gain. - -A new representation of the universe hierarchy is then defined by G. Huet. -Universe levels are now implemented implicitly, through a hidden graph -of abstract levels constrained with an order relation. -Checking acyclicity of the graph insures well-foundedness of the ordering, -and thus consistency. This was documented in a memo -"Adding Type:Type to the Calculus of Constructions" which was never published. - -The development version is released as a stable 4.8 at the end of 1988. - -Version 4.9 is released on March 1st 1989, with the new "elastic" -universe hierarchy. - -The spring 89 saw the first attempt at documenting the system usage, -with a number of papers describing the formalism: -- Metamathematical Investigations of a Calculus of Constructions, by -Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published in -Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, 1990) -- Inductive definitions in the Calculus of Constructions, by -Christine Paulin-Mohring, -- Extracting Fomega's programs from proofs in the Calculus of Constructions, by -Christine Paulin-Mohring (published in POPL'89) -- The Constructive Engine, by Gérard Huet -as well as a number of user guides: -- A short user's guide for the Constructions Version 4.10, by Gérard Huet -- A Vernacular Syllabus, by Gilles Dowek. -- The Tactics Theorem Prover, User's guide, Version 4.10, by Thierry Coquand. - -Stable V4.10, released on May 1st, 1989, was then a mature system, -distributed with CAML V2.6. - -In the mean time, Thierry Coquand and Christine Paulin-Mohring -had been investigating how to add native inductive types to the -Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic -Type Theory. The impredicative encoding had already been presented in: -F. Pfenning and C. Paulin-Mohring. Inductively defined types in the Calculus -of Constructions. Preprint technical report CMU-CS-89-209, final version in -Proceedings of Mathematical Foundations of Programming Semantics, -volume 442, Lecture Notes in Computer Science. Springer-Verlag, 1990. -An extension of the calculus with primitive inductive types appeared in: -Th. Coquand and C. Paulin-Mohring. Inductively defined types. -In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417, -Lecture Notes in Computer Science. Springer-Verlag, 1990. - -This lead to the Calculus of Inductive Constructions, logical formalism -implemented in Versions 5 upward of the system, and documented in: -C. Paulin-Mohring. Inductive Definitions in the System Coq - Rules and -Properties. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference -Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer -Science, 1993. - -The last version of CONSTR is Version 4.11, which was last distributed -in Spring 1990. It was demonstrated at the first workshop of the European -Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990. - -At the end of 1989, Version 5.1 was started, and renamed as the system Coq -for the Calculus of Inductive Constructions. It was then ported to the new -stand-alone implementation of ML called Caml-light. - -In 1990 many changes occurred. Thierry Coquand left for Chalmers University -in Göteborg. Christine Paulin-Mohring took a CNRS researcher position -at the LIP laboratory of Ecole Normale Supérieure de Lyon. Project Formel -was terminated, and gave rise to two teams: Cristal at INRIA-Roquencourt, -that continued developments in functional programming with Caml-light then -Ocaml, and Coq, continuing the type theory research, with a joint team -headed by Gérard Huet at INRIA-Rocquencourt and Christine Paulin-Mohring -at the LIP laboratory of CNRS-ENS Lyon. - -Chetan Murthy joined the team in 1991 and became the main software architect -of Version 5. He completely rehauled the implementation for efficiency. -Versions 5.6 and 5.8 were major distributed versions, with complete -documentation and a library of users' developements. The use of the RCS -revision control system, and systematic ChangeLog files, allow a more -precise tracking of the software developments. - -Developments from Version 6 upwards are documented in the credits section of -Coq's Reference Manual. - -September 2015 -Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc new file mode 100644 index 0000000000..f6ee27d486 --- /dev/null +++ b/dev/doc/README-V1-V5.asciidoc @@ -0,0 +1,312 @@ +Notes on the prehistory of Coq +============================== +:author: Thierry Coquand, Gérard Huet & Christine Paulin-Mohring +:revdate: September 2015 +:toc: +:toc-placement: preamble +:toclevels: 1 +:showtitle: + + +This archive contains the sources of the CONSTR ancestor of the Coq proof +assistant. CONSTR, then Coq, was designed and implemented in the Formel team, +joint between the INRIA Rocquencourt laboratory and the École Normale Supérieure +of Paris, from 1984 onwards. + +Version 1 +--------- + +This software is a prototype type-checker for a higher-order logical formalism +known as the Theory of Constructions, presented in his PhD thesis by +Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath. +The metamathematical analysis of the system is the +PhD work of Thierry Coquand. The software is mostly the work of Gérard Huet. +Most of the mathematical examples verified with the software are due +to Thierry Coquand. + +The programming language of the CONSTR software (as it was called at the time) +is a version of ML issued from the Edinburgh LCF system and running on +a LISP backend. The main improvements from the original LCF ML are that ML +is compiled rather than interpreted (Gérard Huet building on the original +translator by Lockwood Morris), and that it is enriched by recursively +defined types (work of Guy Cousineau). This ancestor of CAML was used +and improved by Larry Paulson for his implementation of Cambridge LCF. + +Software developments of this prototype occurred from late 1983 to early 1985. + +Version 1.10 was frozen on December 22nd 1984. It is the version used for the +examples in Thierry Coquand's thesis, defended on January 31st 1985. +There was a unique binding operator, used both for universal quantification +(dependent product) at the level of types and functional abstraction (λ) +at the level of terms/proofs, in the manner of Automath. Substitution +(λ-reduction) was implemented using de Bruijn's indexes. + +Version 1.11 was frozen on February 19th, 1985. It is the version used for the +examples in the paper: +Th. Coquand, G. Huet. _Constructions: A Higher Order Proof System for Mechanizing +Mathematics_. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag +LNCS 203, pp. 151-184. + +Christine Paulin joined the team at this point, for her DEA research internship. +In her DEA memoir (August 1985) she presents developments for the _lambo_ function +computing the minimal _m_ such that _f(m)_ is greater than _n_, for _f_ an increasing +integer function, a challenge for constructive mathematics. She also encoded +the majority voting algorithm of Boyer and Moore. + +Version 2 +--------- + +The formal system, now renamed as the _Calculus of Constructions_, was presented +with a proof of consistency and comparisons with proof systems of Per +Martin Löf, Girard, and the Automath family of N. de Bruijn, in the paper: +T. Coquand and G. Huet. _The Calculus of Constructions_. +Submitted on June 30th 1985, accepted on December 5th, 1985, +Information and Computation. Preprint as Rapport de Recherche Inria n°530, +Mai 1986. Final version in Information and Computation 76,2/3, Feb. 88. + +An abstraction of the software design, in the form of an abstract machine +for proof checking, and a fuller sequence of mathematical developments was +presented in: +Th. Coquand, G. Huet. _Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions_. Invited paper, European Logic Colloquium, Orsay, +July 1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. +Published in Logic Colloquium 1985, North-Holland, 1987. + +Version 2.8 was frozen on December 16th, 1985, and served for developing +the exemples in the above papers. + +This calculus was then enriched in version 2.9 with a cumulative hierarchy of +universes. Universe levels were initially explicit natural numbers. +Another improvement was the possibility of automatic synthesis of implicit +type arguments, relieving the user of tedious redundant declarations. + +Christine Paulin wrote an article _Algorithm development in the Calculus of +Constructions_, preprint as Rapport de recherche INRIA n°497, March 86. +Final version in Proceedings Symposium on Logic in Computer Science, Cambridge, +MA, 1986 (IEEE Computer Society Press). Besides _lambo_ and _majority_, +she presents quicksort and a text formatting algorithm. + +Version 2.13 of the Calculus of Constructions with universes was frozen +on June 25th, 1986. + +A synthetic presentation of type theory along constructive lines with ML +algorithms was given by Gérard Huet in his May 1986 CMU course notes +_Formal Structures for Computation and Deduction_. Its chapter +_Induction and Recursion in the Theory of Constructions_ was presented +as an invited paper at the Joint Conference on Theory and Practice of Software +Development TAPSOFT’87 at Pise in March 1987, and published as +_Induction Principles Formalized in the Calculus of Constructions_ in +Programming of Future Generation Computers, Ed. K. Fuchi and M. Nivat, +North-Holland, 1988. + +Version 3 +--------- + +This version saw the beginning of proof automation, with a search algorithm +inspired from PROLOG and the applicative logic programming programs +of the course notes _Formal structures for computation and deduction_. +The search algorithm was implemented in ML by Thierry Coquand. +The proof system could thus be used in two modes: proof verification and +proof synthesis, with tactics such as `AUTO`. + +The implementation language was now called CAML, for Categorical Abstract +Machine Language. It used as backend the LLM3 virtual machine of Le Lisp +by Jérôme Chailloux. The main developers of CAML were Michel Mauny, +Ascander Suarez and Pierre Weis. + +V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November +1986. V3.4 was developed in the first half of 1987. + +Thierry Coquand held a post-doctoral position in Cambrige University in 1986-87, +where he developed a variant implementation in SML, with which he wrote +some developments on fixpoints in Scott's domains. + +Version 4 +--------- + +This version saw the beginning of program extraction from proofs, with +two varieties of the type `Prop` of propositions, indicating constructive intent. +The proof extraction algorithms were implemented by Christine Paulin-Mohring. + +V4.1 was frozen on July 24th, 1987. It had a first identified library of +mathematical developments (directory exemples), with libraries Logic +(containing impredicative encodings of intuitionistic logic and algebraic +primitives for booleans, natural numbers and list), `Peano` developing second-order +Peano arithmetic, `Arith` defining addition, multiplication, euclidean division +and factorial. Typical developments were the Knaster-Tarski theorem +and Newman's lemma from rewriting theory. + +V4.2 was a joint development of a team consisting of Thierry Coquand, Gérard +Huet and Christine Paulin-Mohring. A file V4.2.log records the log of changes. +It was frozen on September 1987 as the last version implemented in CAML 2.3, +and V4.3 followed on CAML 2.5, a more stable development system. + +V4.3 saw the first top-level of the system. Instead of evaluating explicit +quotations, the user could develop his mathematics in a high-level language +called the mathematical vernacular (following Automath terminology). +The user could develop files in the vernacular notation (with .v extension) +which were now separate from the `ml` sources of the implementation. +Gilles Dowek joined the team to develop the vernacular language as his +DEA internship research. + +A notion of sticky constant was introduced, in order to keep names of lemmas +when local hypotheses of proofs were discharged. This gave a notion +of global mathematical environment with local sections. + +Another significant practical change was that the system, originally developped +on the VAX central computer of our lab, was transferred on SUN personal +workstations, allowing a level of distributed development. +The extraction algorithm was modified, with three annotations `Pos`, `Null` and +`Typ` decorating the sorts `Prop` and `Type`. + +Version 4.3 was frozen at the end of November 1987, and was distributed to an +early community of users (among those were Hugo Herbelin and Loic Colson). + +V4.4 saw the first version of (encoded) inductive types. +Now natural numbers could be defined as: + +[source, coq] +Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. + +These inductive types were encoded impredicatively in the calculus, +using a subsystem _rec_ due to Christine Paulin. +V4.4 was frozen on March 6th 1988. + +Version 4.5 was the first one to support inductive types and program extraction. +Its banner was _Calcul des Constructions avec Réalisations et Synthèse_. +The vernacular language was enriched to accommodate extraction commands. + +The verification engine design was presented as: +G. Huet. _The Constructive Engine_. Version 4.5. Invited Conference, 2nd European +Symposium on Programming, Nancy, March 88. +The final paper, describing the V4.9 implementation, appeared in: +A perspective in Theoretical Computer Science, Commemorative Volume in memory +of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. + +Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical +Foundations of Functional Programming organized by Gérard Huet at Austin, Texas. + +Version 4.6 was started during summer 1988. Its main improvement was the +complete rehaul of the proof synthesis engine by Thierry Coquand, with +a tree structure of goals. + +Its source code was communicated to Randy Pollack on September 2nd 1988. +It evolved progressively into LEGO, proof system for Luo's formalism +of Extended Calculus of Constructions. + +The discharge tactic was modified by G. Huet to allow for inter-dependencies +in discharged lemmas. Christine Paulin improved the inductive definition scheme +in order to accommodate predicates of any arity. + +Version 4.7 was started on September 6th, 1988. + +This version starts exploiting the CAML notion of module in order to improve the +modularity of the implementation. Now the term verifier is identified as +a proper module Machine, which the structure of its internal data structures +being hidden and thus accessible only through the legitimate operations. +This machine (the constructive engine) was the trusted core of the +implementation. The proof synthesis mechanism was a separate proof term +generator. Once a complete proof term was synthesized with the help of tactics, +it was entirely re-checked by the engine. Thus there was no need to certify +the tactics, and the system took advantage of this fact by having tactics ignore +the universe levels, universe consistency check being relegated to the final +type-checking pass. This induced a certain puzzlement of early users who saw +their successful proof search ended with `QED`, followed by silence, followed by +a failure message of universe inconsistency rejection… + +The set of examples comprise set theory experiments by Hugo Herbelin, +and notably the Schroeder-Bernstein theorem. + +Version 4.8, started on October 8th, 1988, saw a major re-implementation of the +abstract syntax type `constr`, separating variables of the formalism and +metavariables denoting incomplete terms managed by the search mechanism. +A notion of level (with three values `TYPE`, `OBJECT` and `PROOF`) is made explicit +and a type judgement clarifies the constructions, whose implementation is now +fully explicit. Structural equality is speeded up by using pointer equality, +yielding spectacular improvements. Thierry Coquand adapts the proof synthesis +to the new representation, and simplifies pattern matching to first-order +predicate calculus matching, with important performance gain. + +A new representation of the universe hierarchy is then defined by G. Huet. +Universe levels are now implemented implicitly, through a hidden graph +of abstract levels constrained with an order relation. +Checking acyclicity of the graph insures well-foundedness of the ordering, +and thus consistency. This was documented in a memo +_Adding Type:Type to the Calculus of Constructions_ which was never published. + +The development version is released as a stable 4.8 at the end of 1988. + +Version 4.9 is released on March 1st 1989, with the new ``elastic'' +universe hierarchy. + +The spring 89 saw the first attempt at documenting the system usage, +with a number of papers describing the formalism: + +- _Metamathematical Investigations of a Calculus of Constructions_, by +Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published in +Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, 1990) +- _Inductive definitions in the Calculus of Constructions_, by +Christine Paulin-Mohring, +- _Extracting Fω's programs from proofs in the Calculus of Constructions_, by +Christine Paulin-Mohring (published in POPL'89) +- _The Constructive Engine_, by Gérard Huet + +as well as a number of user guides: + +- _A short user's guide for the Constructions_ Version 4.10, by Gérard Huet +- _A Vernacular Syllabus_, by Gilles Dowek. +- _The Tactics Theorem Prover, User's guide_, Version 4.10, by Thierry Coquand. + +Stable V4.10, released on May 1st, 1989, was then a mature system, +distributed with CAML V2.6. + +In the mean time, Thierry Coquand and Christine Paulin-Mohring +had been investigating how to add native inductive types to the +Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic +Type Theory. The impredicative encoding had already been presented in: +F. Pfenning and C. Paulin-Mohring. _Inductively defined types in the Calculus +of Constructions_. Preprint technical report CMU-CS-89-209, final version in +Proceedings of Mathematical Foundations of Programming Semantics, +volume 442, Lecture Notes in Computer Science. Springer-Verlag, 1990. +An extension of the calculus with primitive inductive types appeared in: +Th. Coquand and C. Paulin-Mohring. _Inductively defined types_. +In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417, +Lecture Notes in Computer Science. Springer-Verlag, 1990. + +This lead to the Calculus of Inductive Constructions, logical formalism +implemented in Versions 5 upward of the system, and documented in: +C. Paulin-Mohring. _Inductive Definitions in the System Coq - Rules and +Properties_. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference +Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer +Science, 1993. + +The last version of CONSTR is Version 4.11, which was last distributed +in Spring 1990. It was demonstrated at the first workshop of the European +Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990. + +At the end of 1989, Version 5.1 was started, and renamed as the system Coq +for the Calculus of Inductive Constructions. It was then ported to the new +stand-alone implementation of ML called Caml-light. + +In 1990 many changes occurred. Thierry Coquand left for Chalmers University +in Göteborg. Christine Paulin-Mohring took a CNRS researcher position +at the LIP laboratory of École Normale Supérieure de Lyon. Project Formel +was terminated, and gave rise to two teams: Cristal at INRIA-Roquencourt, +that continued developments in functional programming with Caml-light then +Ocaml, and Coq, continuing the type theory research, with a joint team +headed by Gérard Huet at INRIA-Rocquencourt and Christine Paulin-Mohring +at the LIP laboratory of CNRS-ENS Lyon. + +Chetan Murthy joined the team in 1991 and became the main software architect +of Version 5. He completely rehauled the implementation for efficiency. +Versions 5.6 and 5.8 were major distributed versions, with complete +documentation and a library of users' developements. The use of the RCS +revision control system, and systematic ChangeLog files, allow a more +precise tracking of the software developments. + +Developments from Version 6 upwards are documented in the credits section of +Coq's Reference Manual. + +==== +September 2015 + +Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. +==== \ No newline at end of file -- cgit v1.2.3 From e82fc7cb4104d28619448bde374afde7e32f3dc2 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Fri, 6 Nov 2015 09:15:47 +0100 Subject: Prehistory of Coq: various corrections on English. --- dev/doc/README-V1-V5.asciidoc | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc index f6ee27d486..43971ba553 100644 --- a/dev/doc/README-V1-V5.asciidoc +++ b/dev/doc/README-V1-V5.asciidoc @@ -25,10 +25,10 @@ Most of the mathematical examples verified with the software are due to Thierry Coquand. The programming language of the CONSTR software (as it was called at the time) -is a version of ML issued from the Edinburgh LCF system and running on -a LISP backend. The main improvements from the original LCF ML are that ML -is compiled rather than interpreted (Gérard Huet building on the original -translator by Lockwood Morris), and that it is enriched by recursively +was a version of ML adapted from the Edinburgh LCF system and running on +a LISP backend. The main improvements from the original LCF ML were that ML +was compiled rather than interpreted (Gérard Huet building on the original +translator by Lockwood Morris), and that it was enriched by recursively defined types (work of Guy Cousineau). This ancestor of CAML was used and improved by Larry Paulson for his implementation of Cambridge LCF. @@ -47,10 +47,11 @@ Th. Coquand, G. Huet. _Constructions: A Higher Order Proof System for Mechanizin Mathematics_. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag LNCS 203, pp. 151-184. -Christine Paulin joined the team at this point, for her DEA research internship. -In her DEA memoir (August 1985) she presents developments for the _lambo_ function -computing the minimal _m_ such that _f(m)_ is greater than _n_, for _f_ an increasing -integer function, a challenge for constructive mathematics. She also encoded +Christine Paulin joined the team at this point, for her DEA research +internship. In her DEA memoir (August 1985) she presents developments +for the _lambo_ function – _lambo(f)(n)_ computes the minimal _m_ such +that _f(m)_ is greater than _n_, for _f_ an increasing integer +function, a challenge for constructive mathematics. She also encoded the majority voting algorithm of Boyer and Moore. Version 2 @@ -185,7 +186,7 @@ of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical Foundations of Functional Programming organized by Gérard Huet at Austin, Texas. -Version 4.6 was started during summer 1988. Its main improvement was the +Version 4.6 was started during the summer of 1988. Its main improvement was the complete rehaul of the proof synthesis engine by Thierry Coquand, with a tree structure of goals. @@ -209,9 +210,9 @@ generator. Once a complete proof term was synthesized with the help of tactics, it was entirely re-checked by the engine. Thus there was no need to certify the tactics, and the system took advantage of this fact by having tactics ignore the universe levels, universe consistency check being relegated to the final -type-checking pass. This induced a certain puzzlement of early users who saw -their successful proof search ended with `QED`, followed by silence, followed by -a failure message of universe inconsistency rejection… +type-checking pass. This induced a certain puzzlement in early users who saw, +after a successful proof search, their `QED` followed by silence, followed by +a failure message due to a universe inconsistency… The set of examples comprise set theory experiments by Hugo Herbelin, and notably the Schroeder-Bernstein theorem. @@ -238,7 +239,7 @@ The development version is released as a stable 4.8 at the end of 1988. Version 4.9 is released on March 1st 1989, with the new ``elastic'' universe hierarchy. -The spring 89 saw the first attempt at documenting the system usage, +The spring of 1989 saw the first attempt at documenting the system usage, with a number of papers describing the formalism: - _Metamathematical Investigations of a Calculus of Constructions_, by @@ -272,7 +273,7 @@ Th. Coquand and C. Paulin-Mohring. _Inductively defined types_. In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417, Lecture Notes in Computer Science. Springer-Verlag, 1990. -This lead to the Calculus of Inductive Constructions, logical formalism +This led to the Calculus of Inductive Constructions, logical formalism implemented in Versions 5 upward of the system, and documented in: C. Paulin-Mohring. _Inductive Definitions in the System Coq - Rules and Properties_. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference @@ -280,7 +281,7 @@ Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer Science, 1993. The last version of CONSTR is Version 4.11, which was last distributed -in Spring 1990. It was demonstrated at the first workshop of the European +in the spring of 1990. It was demonstrated at the first workshop of the European Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990. At the end of 1989, Version 5.1 was started, and renamed as the system Coq -- cgit v1.2.3 From bbfa17765599a04931efa68a5397f418e6ea5b39 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Fri, 6 Nov 2015 09:18:54 +0100 Subject: Prehistory of Coq: consistency. Don't use abbreviated first names in sentences. --- dev/doc/README-V1-V5.asciidoc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc index 43971ba553..a02f0831dc 100644 --- a/dev/doc/README-V1-V5.asciidoc +++ b/dev/doc/README-V1-V5.asciidoc @@ -194,7 +194,7 @@ Its source code was communicated to Randy Pollack on September 2nd 1988. It evolved progressively into LEGO, proof system for Luo's formalism of Extended Calculus of Constructions. -The discharge tactic was modified by G. Huet to allow for inter-dependencies +The discharge tactic was modified by Gérard Huet to allow for inter-dependencies in discharged lemmas. Christine Paulin improved the inductive definition scheme in order to accommodate predicates of any arity. @@ -227,7 +227,7 @@ yielding spectacular improvements. Thierry Coquand adapts the proof synthesis to the new representation, and simplifies pattern matching to first-order predicate calculus matching, with important performance gain. -A new representation of the universe hierarchy is then defined by G. Huet. +A new representation of the universe hierarchy is then defined by Gérard Huet. Universe levels are now implemented implicitly, through a hidden graph of abstract levels constrained with an order relation. Checking acyclicity of the graph insures well-foundedness of the ordering, -- cgit v1.2.3 From 856e746e2a0adf959faee0907555af81be11d027 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Fri, 6 Nov 2015 09:26:50 +0100 Subject: Prehistory of Coq: justification of the plain text. --- dev/doc/README-V1-V5.asciidoc | 483 ++++++++++++++++++++++-------------------- 1 file changed, 254 insertions(+), 229 deletions(-) diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc index a02f0831dc..4395fd0e5c 100644 --- a/dev/doc/README-V1-V5.asciidoc +++ b/dev/doc/README-V1-V5.asciidoc @@ -8,44 +8,47 @@ Notes on the prehistory of Coq :showtitle: -This archive contains the sources of the CONSTR ancestor of the Coq proof -assistant. CONSTR, then Coq, was designed and implemented in the Formel team, -joint between the INRIA Rocquencourt laboratory and the École Normale Supérieure -of Paris, from 1984 onwards. +This archive contains the sources of the CONSTR ancestor of the Coq +proof assistant. CONSTR, then Coq, was designed and implemented in the +Formel team, joint between the INRIA Rocquencourt laboratory and the +École Normale Supérieure of Paris, from 1984 onwards. Version 1 --------- -This software is a prototype type-checker for a higher-order logical formalism -known as the Theory of Constructions, presented in his PhD thesis by -Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath. -The metamathematical analysis of the system is the -PhD work of Thierry Coquand. The software is mostly the work of Gérard Huet. -Most of the mathematical examples verified with the software are due -to Thierry Coquand. - -The programming language of the CONSTR software (as it was called at the time) -was a version of ML adapted from the Edinburgh LCF system and running on -a LISP backend. The main improvements from the original LCF ML were that ML -was compiled rather than interpreted (Gérard Huet building on the original -translator by Lockwood Morris), and that it was enriched by recursively -defined types (work of Guy Cousineau). This ancestor of CAML was used -and improved by Larry Paulson for his implementation of Cambridge LCF. - -Software developments of this prototype occurred from late 1983 to early 1985. - -Version 1.10 was frozen on December 22nd 1984. It is the version used for the -examples in Thierry Coquand's thesis, defended on January 31st 1985. -There was a unique binding operator, used both for universal quantification -(dependent product) at the level of types and functional abstraction (λ) -at the level of terms/proofs, in the manner of Automath. Substitution -(λ-reduction) was implemented using de Bruijn's indexes. - -Version 1.11 was frozen on February 19th, 1985. It is the version used for the -examples in the paper: -Th. Coquand, G. Huet. _Constructions: A Higher Order Proof System for Mechanizing -Mathematics_. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag -LNCS 203, pp. 151-184. +This software is a prototype type-checker for a higher-order logical +formalism known as the Theory of Constructions, presented in his PhD +thesis by Thierry Coquand, with influences from Girard's system F and +de Bruijn's Automath. The metamathematical analysis of the system is +the PhD work of Thierry Coquand. The software is mostly the work of +Gérard Huet. Most of the mathematical examples verified with the +software are due to Thierry Coquand. + +The programming language of the CONSTR software (as it was called at +the time) was a version of ML adapted from the Edinburgh LCF system +and running on a LISP backend. The main improvements from the original +LCF ML were that ML was compiled rather than interpreted (Gérard Huet +building on the original translator by Lockwood Morris), and that it +was enriched by recursively defined types (work of Guy +Cousineau). This ancestor of CAML was used and improved by Larry +Paulson for his implementation of Cambridge LCF. + +Software developments of this prototype occurred from late 1983 to +early 1985. + +Version 1.10 was frozen on December 22nd 1984. It is the version used +for the examples in Thierry Coquand's thesis, defended on January 31st +1985. There was a unique binding operator, used both for universal +quantification (dependent product) at the level of types and +functional abstraction (λ) at the level of terms/proofs, in the manner +of Automath. Substitution (λ-reduction) was implemented using de +Bruijn's indexes. + +Version 1.11 was frozen on February 19th, 1985. It is the version used +for the examples in the paper: Th. Coquand, G. Huet. _Constructions: A +Higher Order Proof System for Mechanizing Mathematics_. Invited paper, +EUROCAL85, April 1985, Linz, Austria. Springer Verlag LNCS 203, +pp. 151-184. Christine Paulin joined the team at this point, for her DEA research internship. In her DEA memoir (August 1985) she presents developments @@ -57,255 +60,277 @@ the majority voting algorithm of Boyer and Moore. Version 2 --------- -The formal system, now renamed as the _Calculus of Constructions_, was presented -with a proof of consistency and comparisons with proof systems of Per -Martin Löf, Girard, and the Automath family of N. de Bruijn, in the paper: -T. Coquand and G. Huet. _The Calculus of Constructions_. -Submitted on June 30th 1985, accepted on December 5th, 1985, -Information and Computation. Preprint as Rapport de Recherche Inria n°530, -Mai 1986. Final version in Information and Computation 76,2/3, Feb. 88. - -An abstraction of the software design, in the form of an abstract machine -for proof checking, and a fuller sequence of mathematical developments was -presented in: -Th. Coquand, G. Huet. _Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions_. Invited paper, European Logic Colloquium, Orsay, -July 1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. +The formal system, now renamed as the _Calculus of Constructions_, was +presented with a proof of consistency and comparisons with proof +systems of Per Martin Löf, Girard, and the Automath family of N. de +Bruijn, in the paper: T. Coquand and G. Huet. _The Calculus of +Constructions_. Submitted on June 30th 1985, accepted on December +5th, 1985, Information and Computation. Preprint as Rapport de +Recherche Inria n°530, Mai 1986. Final version in Information and +Computation 76,2/3, Feb. 88. + +An abstraction of the software design, in the form of an abstract +machine for proof checking, and a fuller sequence of mathematical +developments was presented in: Th. Coquand, G. Huet. _Concepts +Mathématiques et Informatiques Formalisés dans le Calcul des +Constructions_. Invited paper, European Logic Colloquium, Orsay, July +1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. Published in Logic Colloquium 1985, North-Holland, 1987. -Version 2.8 was frozen on December 16th, 1985, and served for developing -the exemples in the above papers. +Version 2.8 was frozen on December 16th, 1985, and served for +developing the exemples in the above papers. -This calculus was then enriched in version 2.9 with a cumulative hierarchy of -universes. Universe levels were initially explicit natural numbers. -Another improvement was the possibility of automatic synthesis of implicit -type arguments, relieving the user of tedious redundant declarations. +This calculus was then enriched in version 2.9 with a cumulative +hierarchy of universes. Universe levels were initially explicit +natural numbers. Another improvement was the possibility of automatic +synthesis of implicit type arguments, relieving the user of tedious +redundant declarations. -Christine Paulin wrote an article _Algorithm development in the Calculus of -Constructions_, preprint as Rapport de recherche INRIA n°497, March 86. -Final version in Proceedings Symposium on Logic in Computer Science, Cambridge, -MA, 1986 (IEEE Computer Society Press). Besides _lambo_ and _majority_, -she presents quicksort and a text formatting algorithm. +Christine Paulin wrote an article _Algorithm development in the +Calculus of Constructions_, preprint as Rapport de recherche INRIA +n°497, March 86. Final version in Proceedings Symposium on Logic in +Computer Science, Cambridge, MA, 1986 (IEEE Computer Society +Press). Besides _lambo_ and _majority_, she presents quicksort and a +text formatting algorithm. -Version 2.13 of the Calculus of Constructions with universes was frozen -on June 25th, 1986. +Version 2.13 of the Calculus of Constructions with universes was +frozen on June 25th, 1986. -A synthetic presentation of type theory along constructive lines with ML -algorithms was given by Gérard Huet in his May 1986 CMU course notes -_Formal Structures for Computation and Deduction_. Its chapter +A synthetic presentation of type theory along constructive lines with +ML algorithms was given by Gérard Huet in his May 1986 CMU course +notes _Formal Structures for Computation and Deduction_. Its chapter _Induction and Recursion in the Theory of Constructions_ was presented -as an invited paper at the Joint Conference on Theory and Practice of Software -Development TAPSOFT’87 at Pise in March 1987, and published as -_Induction Principles Formalized in the Calculus of Constructions_ in -Programming of Future Generation Computers, Ed. K. Fuchi and M. Nivat, -North-Holland, 1988. +as an invited paper at the Joint Conference on Theory and Practice of +Software Development TAPSOFT’87 at Pise in March 1987, and published +as _Induction Principles Formalized in the Calculus of Constructions_ +in Programming of Future Generation Computers, Ed. K. Fuchi and +M. Nivat, North-Holland, 1988. Version 3 --------- -This version saw the beginning of proof automation, with a search algorithm -inspired from PROLOG and the applicative logic programming programs -of the course notes _Formal structures for computation and deduction_. -The search algorithm was implemented in ML by Thierry Coquand. -The proof system could thus be used in two modes: proof verification and -proof synthesis, with tactics such as `AUTO`. +This version saw the beginning of proof automation, with a search +algorithm inspired from PROLOG and the applicative logic programming +programs of the course notes _Formal structures for computation and +deduction_. The search algorithm was implemented in ML by Thierry +Coquand. The proof system could thus be used in two modes: proof +verification and proof synthesis, with tactics such as `AUTO`. -The implementation language was now called CAML, for Categorical Abstract -Machine Language. It used as backend the LLM3 virtual machine of Le Lisp -by Jérôme Chailloux. The main developers of CAML were Michel Mauny, -Ascander Suarez and Pierre Weis. +The implementation language was now called CAML, for Categorical +Abstract Machine Language. It used as backend the LLM3 virtual machine +of Le Lisp by Jérôme Chailloux. The main developers of CAML were +Michel Mauny, Ascander Suarez and Pierre Weis. -V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November -1986. V3.4 was developed in the first half of 1987. +V3.1 was started in the summer of 1986, V3.2 was frozen at the end of +November 1986. V3.4 was developed in the first half of 1987. -Thierry Coquand held a post-doctoral position in Cambrige University in 1986-87, -where he developed a variant implementation in SML, with which he wrote -some developments on fixpoints in Scott's domains. +Thierry Coquand held a post-doctoral position in Cambrige University +in 1986-87, where he developed a variant implementation in SML, with +which he wrote some developments on fixpoints in Scott's domains. Version 4 --------- This version saw the beginning of program extraction from proofs, with -two varieties of the type `Prop` of propositions, indicating constructive intent. -The proof extraction algorithms were implemented by Christine Paulin-Mohring. - -V4.1 was frozen on July 24th, 1987. It had a first identified library of -mathematical developments (directory exemples), with libraries Logic -(containing impredicative encodings of intuitionistic logic and algebraic -primitives for booleans, natural numbers and list), `Peano` developing second-order -Peano arithmetic, `Arith` defining addition, multiplication, euclidean division -and factorial. Typical developments were the Knaster-Tarski theorem -and Newman's lemma from rewriting theory. - -V4.2 was a joint development of a team consisting of Thierry Coquand, Gérard -Huet and Christine Paulin-Mohring. A file V4.2.log records the log of changes. -It was frozen on September 1987 as the last version implemented in CAML 2.3, -and V4.3 followed on CAML 2.5, a more stable development system. - -V4.3 saw the first top-level of the system. Instead of evaluating explicit -quotations, the user could develop his mathematics in a high-level language -called the mathematical vernacular (following Automath terminology). -The user could develop files in the vernacular notation (with .v extension) -which were now separate from the `ml` sources of the implementation. -Gilles Dowek joined the team to develop the vernacular language as his -DEA internship research. - -A notion of sticky constant was introduced, in order to keep names of lemmas -when local hypotheses of proofs were discharged. This gave a notion -of global mathematical environment with local sections. - -Another significant practical change was that the system, originally developped -on the VAX central computer of our lab, was transferred on SUN personal -workstations, allowing a level of distributed development. -The extraction algorithm was modified, with three annotations `Pos`, `Null` and -`Typ` decorating the sorts `Prop` and `Type`. - -Version 4.3 was frozen at the end of November 1987, and was distributed to an -early community of users (among those were Hugo Herbelin and Loic Colson). - -V4.4 saw the first version of (encoded) inductive types. -Now natural numbers could be defined as: +two varieties of the type `Prop` of propositions, indicating +constructive intent. The proof extraction algorithms were implemented +by Christine Paulin-Mohring. + +V4.1 was frozen on July 24th, 1987. It had a first identified library +of mathematical developments (directory exemples), with libraries +Logic (containing impredicative encodings of intuitionistic logic and +algebraic primitives for booleans, natural numbers and list), `Peano` +developing second-order Peano arithmetic, `Arith` defining addition, +multiplication, euclidean division and factorial. Typical developments +were the Knaster-Tarski theorem and Newman's lemma from rewriting +theory. + +V4.2 was a joint development of a team consisting of Thierry Coquand, +Gérard Huet and Christine Paulin-Mohring. A file V4.2.log records the +log of changes. It was frozen on September 1987 as the last version +implemented in CAML 2.3, and V4.3 followed on CAML 2.5, a more stable +development system. + +V4.3 saw the first top-level of the system. Instead of evaluating +explicit quotations, the user could develop his mathematics in a +high-level language called the mathematical vernacular (following +Automath terminology). The user could develop files in the vernacular +notation (with .v extension) which were now separate from the `ml` +sources of the implementation. Gilles Dowek joined the team to +develop the vernacular language as his DEA internship research. + +A notion of sticky constant was introduced, in order to keep names of +lemmas when local hypotheses of proofs were discharged. This gave a +notion of global mathematical environment with local sections. + +Another significant practical change was that the system, originally +developped on the VAX central computer of our lab, was transferred on +SUN personal workstations, allowing a level of distributed +development. The extraction algorithm was modified, with three +annotations `Pos`, `Null` and `Typ` decorating the sorts `Prop` and +`Type`. + +Version 4.3 was frozen at the end of November 1987, and was +distributed to an early community of users (among those were Hugo +Herbelin and Loic Colson). + +V4.4 saw the first version of (encoded) inductive types. Now natural +numbers could be defined as: [source, coq] Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. These inductive types were encoded impredicatively in the calculus, -using a subsystem _rec_ due to Christine Paulin. -V4.4 was frozen on March 6th 1988. - -Version 4.5 was the first one to support inductive types and program extraction. -Its banner was _Calcul des Constructions avec Réalisations et Synthèse_. -The vernacular language was enriched to accommodate extraction commands. - -The verification engine design was presented as: -G. Huet. _The Constructive Engine_. Version 4.5. Invited Conference, 2nd European -Symposium on Programming, Nancy, March 88. -The final paper, describing the V4.9 implementation, appeared in: -A perspective in Theoretical Computer Science, Commemorative Volume in memory -of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. - -Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical -Foundations of Functional Programming organized by Gérard Huet at Austin, Texas. - -Version 4.6 was started during the summer of 1988. Its main improvement was the -complete rehaul of the proof synthesis engine by Thierry Coquand, with -a tree structure of goals. - -Its source code was communicated to Randy Pollack on September 2nd 1988. -It evolved progressively into LEGO, proof system for Luo's formalism -of Extended Calculus of Constructions. - -The discharge tactic was modified by Gérard Huet to allow for inter-dependencies -in discharged lemmas. Christine Paulin improved the inductive definition scheme -in order to accommodate predicates of any arity. +using a subsystem _rec_ due to Christine Paulin. V4.4 was frozen on +March 6th 1988. + +Version 4.5 was the first one to support inductive types and program +extraction. Its banner was _Calcul des Constructions avec +Réalisations et Synthèse_. The vernacular language was enriched to +accommodate extraction commands. + +The verification engine design was presented as: G. Huet. _The +Constructive Engine_. Version 4.5. Invited Conference, 2nd European +Symposium on Programming, Nancy, March 88. The final paper, +describing the V4.9 implementation, appeared in: A perspective in +Theoretical Computer Science, Commemorative Volume in memory of Gift +Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. + +Version 4.5 was demonstrated in June 1988 at the YoP Institute on +Logical Foundations of Functional Programming organized by Gérard Huet +at Austin, Texas. + +Version 4.6 was started during the summer of 1988. Its main +improvement was the complete rehaul of the proof synthesis engine by +Thierry Coquand, with a tree structure of goals. + +Its source code was communicated to Randy Pollack on September 2nd +1988. It evolved progressively into LEGO, proof system for Luo's +formalism of Extended Calculus of Constructions. + +The discharge tactic was modified by Gérard Huet to allow for +inter-dependencies in discharged lemmas. Christine Paulin improved the +inductive definition scheme in order to accommodate predicates of any +arity. Version 4.7 was started on September 6th, 1988. -This version starts exploiting the CAML notion of module in order to improve the -modularity of the implementation. Now the term verifier is identified as -a proper module Machine, which the structure of its internal data structures -being hidden and thus accessible only through the legitimate operations. -This machine (the constructive engine) was the trusted core of the -implementation. The proof synthesis mechanism was a separate proof term -generator. Once a complete proof term was synthesized with the help of tactics, -it was entirely re-checked by the engine. Thus there was no need to certify -the tactics, and the system took advantage of this fact by having tactics ignore -the universe levels, universe consistency check being relegated to the final -type-checking pass. This induced a certain puzzlement in early users who saw, -after a successful proof search, their `QED` followed by silence, followed by -a failure message due to a universe inconsistency… +This version starts exploiting the CAML notion of module in order to +improve the modularity of the implementation. Now the term verifier is +identified as a proper module Machine, which the structure of its +internal data structures being hidden and thus accessible only through +the legitimate operations. This machine (the constructive engine) was +the trusted core of the implementation. The proof synthesis mechanism +was a separate proof term generator. Once a complete proof term was +synthesized with the help of tactics, it was entirely re-checked by +the engine. Thus there was no need to certify the tactics, and the +system took advantage of this fact by having tactics ignore the +universe levels, universe consistency check being relegated to the +final type-checking pass. This induced a certain puzzlement in early +users who saw, after a successful proof search, their `QED` followed +by silence, followed by a failure message due to a universe +inconsistency… The set of examples comprise set theory experiments by Hugo Herbelin, and notably the Schroeder-Bernstein theorem. -Version 4.8, started on October 8th, 1988, saw a major re-implementation of the -abstract syntax type `constr`, separating variables of the formalism and -metavariables denoting incomplete terms managed by the search mechanism. -A notion of level (with three values `TYPE`, `OBJECT` and `PROOF`) is made explicit -and a type judgement clarifies the constructions, whose implementation is now -fully explicit. Structural equality is speeded up by using pointer equality, -yielding spectacular improvements. Thierry Coquand adapts the proof synthesis -to the new representation, and simplifies pattern matching to first-order -predicate calculus matching, with important performance gain. - -A new representation of the universe hierarchy is then defined by Gérard Huet. -Universe levels are now implemented implicitly, through a hidden graph -of abstract levels constrained with an order relation. -Checking acyclicity of the graph insures well-foundedness of the ordering, -and thus consistency. This was documented in a memo -_Adding Type:Type to the Calculus of Constructions_ which was never published. - -The development version is released as a stable 4.8 at the end of 1988. +Version 4.8, started on October 8th, 1988, saw a major +re-implementation of the abstract syntax type `constr`, separating +variables of the formalism and metavariables denoting incomplete terms +managed by the search mechanism. A notion of level (with three values +`TYPE`, `OBJECT` and `PROOF`) is made explicit and a type judgement +clarifies the constructions, whose implementation is now fully +explicit. Structural equality is speeded up by using pointer equality, +yielding spectacular improvements. Thierry Coquand adapts the proof +synthesis to the new representation, and simplifies pattern matching +to first-order predicate calculus matching, with important performance +gain. + +A new representation of the universe hierarchy is then defined by +Gérard Huet. Universe levels are now implemented implicitly, through +a hidden graph of abstract levels constrained with an order relation. +Checking acyclicity of the graph insures well-foundedness of the +ordering, and thus consistency. This was documented in a memo _Adding +Type:Type to the Calculus of Constructions_ which was never published. + +The development version is released as a stable 4.8 at the end of +1988. Version 4.9 is released on March 1st 1989, with the new ``elastic'' universe hierarchy. -The spring of 1989 saw the first attempt at documenting the system usage, -with a number of papers describing the formalism: +The spring of 1989 saw the first attempt at documenting the system +usage, with a number of papers describing the formalism: - _Metamathematical Investigations of a Calculus of Constructions_, by -Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published in -Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, 1990) + Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published + in Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, + 1990) - _Inductive definitions in the Calculus of Constructions_, by -Christine Paulin-Mohring, -- _Extracting Fω's programs from proofs in the Calculus of Constructions_, by -Christine Paulin-Mohring (published in POPL'89) + Christine Paulin-Mohring, +- _Extracting Fω's programs from proofs in the Calculus of + Constructions_, by Christine Paulin-Mohring (published in POPL'89) - _The Constructive Engine_, by Gérard Huet as well as a number of user guides: - _A short user's guide for the Constructions_ Version 4.10, by Gérard Huet - _A Vernacular Syllabus_, by Gilles Dowek. -- _The Tactics Theorem Prover, User's guide_, Version 4.10, by Thierry Coquand. +- _The Tactics Theorem Prover, User's guide_, Version 4.10, by Thierry + Coquand. Stable V4.10, released on May 1st, 1989, was then a mature system, distributed with CAML V2.6. -In the mean time, Thierry Coquand and Christine Paulin-Mohring -had been investigating how to add native inductive types to the -Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic +In the mean time, Thierry Coquand and Christine Paulin-Mohring had +been investigating how to add native inductive types to the Calculus +of Constructions, in the manner of Per Martin-Löf's Intuitionistic Type Theory. The impredicative encoding had already been presented in: -F. Pfenning and C. Paulin-Mohring. _Inductively defined types in the Calculus -of Constructions_. Preprint technical report CMU-CS-89-209, final version in -Proceedings of Mathematical Foundations of Programming Semantics, -volume 442, Lecture Notes in Computer Science. Springer-Verlag, 1990. -An extension of the calculus with primitive inductive types appeared in: -Th. Coquand and C. Paulin-Mohring. _Inductively defined types_. -In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417, -Lecture Notes in Computer Science. Springer-Verlag, 1990. +F. Pfenning and C. Paulin-Mohring. _Inductively defined types in the +Calculus of Constructions_. Preprint technical report CMU-CS-89-209, +final version in Proceedings of Mathematical Foundations of +Programming Semantics, volume 442, Lecture Notes in Computer +Science. Springer-Verlag, 1990. An extension of the calculus with +primitive inductive types appeared in: Th. Coquand and +C. Paulin-Mohring. _Inductively defined types_. In P. Martin-Löf and +G. Mints, editors, Proceedings of Colog'88, volume 417, Lecture Notes +in Computer Science. Springer-Verlag, 1990. This led to the Calculus of Inductive Constructions, logical formalism implemented in Versions 5 upward of the system, and documented in: -C. Paulin-Mohring. _Inductive Definitions in the System Coq - Rules and -Properties_. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference -Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer -Science, 1993. +C. Paulin-Mohring. _Inductive Definitions in the System Coq - Rules +and Properties_. In M. Bezem and J.-F. Groote, editors, Proceedings of +the conference Typed Lambda Calculi and Applications, volume 664, +Lecture Notes in Computer Science, 1993. The last version of CONSTR is Version 4.11, which was last distributed -in the spring of 1990. It was demonstrated at the first workshop of the European -Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990. - -At the end of 1989, Version 5.1 was started, and renamed as the system Coq -for the Calculus of Inductive Constructions. It was then ported to the new -stand-alone implementation of ML called Caml-light. - -In 1990 many changes occurred. Thierry Coquand left for Chalmers University -in Göteborg. Christine Paulin-Mohring took a CNRS researcher position -at the LIP laboratory of École Normale Supérieure de Lyon. Project Formel -was terminated, and gave rise to two teams: Cristal at INRIA-Roquencourt, -that continued developments in functional programming with Caml-light then -Ocaml, and Coq, continuing the type theory research, with a joint team -headed by Gérard Huet at INRIA-Rocquencourt and Christine Paulin-Mohring -at the LIP laboratory of CNRS-ENS Lyon. - -Chetan Murthy joined the team in 1991 and became the main software architect -of Version 5. He completely rehauled the implementation for efficiency. -Versions 5.6 and 5.8 were major distributed versions, with complete -documentation and a library of users' developements. The use of the RCS -revision control system, and systematic ChangeLog files, allow a more -precise tracking of the software developments. - -Developments from Version 6 upwards are documented in the credits section of -Coq's Reference Manual. +in the spring of 1990. It was demonstrated at the first workshop of +the European Basic Research Action Logical Frameworks In Sophia +Antipolis in May 1990. + +At the end of 1989, Version 5.1 was started, and renamed as the system +Coq for the Calculus of Inductive Constructions. It was then ported to +the new stand-alone implementation of ML called Caml-light. + +In 1990 many changes occurred. Thierry Coquand left for Chalmers +University in Göteborg. Christine Paulin-Mohring took a CNRS +researcher position at the LIP laboratory of École Normale Supérieure +de Lyon. Project Formel was terminated, and gave rise to two teams: +Cristal at INRIA-Roquencourt, that continued developments in +functional programming with Caml-light then Ocaml, and Coq, continuing +the type theory research, with a joint team headed by Gérard Huet at +INRIA-Rocquencourt and Christine Paulin-Mohring at the LIP laboratory +of CNRS-ENS Lyon. + +Chetan Murthy joined the team in 1991 and became the main software +architect of Version 5. He completely rehauled the implementation for +efficiency. Versions 5.6 and 5.8 were major distributed versions, +with complete documentation and a library of users' developements. The +use of the RCS revision control system, and systematic ChangeLog +files, allow a more precise tracking of the software developments. + +Developments from Version 6 upwards are documented in the credits +section of Coq's Reference Manual. ==== September 2015 + -- cgit v1.2.3 From fd7eb1dd0f2cf5fab3a6a2a5f567acaca2defed5 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Wed, 11 Nov 2015 00:02:21 +0100 Subject: Prehistory of Coq: move the bibliographic references to a dedicated section. So as not to clutter the text. Also took the opportunity to add a few missing references. --- dev/doc/README-V1-V5.asciidoc | 121 +++++++++++++++++++++++++++--------------- 1 file changed, 79 insertions(+), 42 deletions(-) diff --git a/dev/doc/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc index 4395fd0e5c..9a4261b3a7 100644 --- a/dev/doc/README-V1-V5.asciidoc +++ b/dev/doc/README-V1-V5.asciidoc @@ -45,10 +45,8 @@ of Automath. Substitution (λ-reduction) was implemented using de Bruijn's indexes. Version 1.11 was frozen on February 19th, 1985. It is the version used -for the examples in the paper: Th. Coquand, G. Huet. _Constructions: A -Higher Order Proof System for Mechanizing Mathematics_. Invited paper, -EUROCAL85, April 1985, Linz, Austria. Springer Verlag LNCS 203, -pp. 151-184. +for the examples in the paper: Th. Coquand, G. Huet. __Constructions: A +Higher Order Proof System for Mechanizing Mathematics__ <>. Christine Paulin joined the team at this point, for her DEA research internship. In her DEA memoir (August 1985) she presents developments @@ -63,19 +61,14 @@ Version 2 The formal system, now renamed as the _Calculus of Constructions_, was presented with a proof of consistency and comparisons with proof systems of Per Martin Löf, Girard, and the Automath family of N. de -Bruijn, in the paper: T. Coquand and G. Huet. _The Calculus of -Constructions_. Submitted on June 30th 1985, accepted on December -5th, 1985, Information and Computation. Preprint as Rapport de -Recherche Inria n°530, Mai 1986. Final version in Information and -Computation 76,2/3, Feb. 88. +Bruijn, in the paper: T. Coquand and G. Huet. __The Calculus of +Constructions__ <>. An abstraction of the software design, in the form of an abstract machine for proof checking, and a fuller sequence of mathematical -developments was presented in: Th. Coquand, G. Huet. _Concepts +developments was presented in: Th. Coquand, G. Huet. __Concepts Mathématiques et Informatiques Formalisés dans le Calcul des -Constructions_. Invited paper, European Logic Colloquium, Orsay, July -1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. -Published in Logic Colloquium 1985, North-Holland, 1987. +Constructions__<>. Version 2.8 was frozen on December 16th, 1985, and served for developing the exemples in the above papers. @@ -86,12 +79,9 @@ natural numbers. Another improvement was the possibility of automatic synthesis of implicit type arguments, relieving the user of tedious redundant declarations. -Christine Paulin wrote an article _Algorithm development in the -Calculus of Constructions_, preprint as Rapport de recherche INRIA -n°497, March 86. Final version in Proceedings Symposium on Logic in -Computer Science, Cambridge, MA, 1986 (IEEE Computer Society -Press). Besides _lambo_ and _majority_, she presents quicksort and a -text formatting algorithm. +Christine Paulin wrote an article __Algorithm development in the +Calculus of Constructions__ <>. Besides _lambo_ and _majority_, +she presents quicksort and a text formatting algorithm. Version 2.13 of the Calculus of Constructions with universes was frozen on June 25th, 1986. @@ -102,9 +92,8 @@ notes _Formal Structures for Computation and Deduction_. Its chapter _Induction and Recursion in the Theory of Constructions_ was presented as an invited paper at the Joint Conference on Theory and Practice of Software Development TAPSOFT’87 at Pise in March 1987, and published -as _Induction Principles Formalized in the Calculus of Constructions_ -in Programming of Future Generation Computers, Ed. K. Fuchi and -M. Nivat, North-Holland, 1988. +as __Induction Principles Formalized in the Calculus of +Constructions__ <>. Version 3 --------- @@ -263,14 +252,12 @@ The spring of 1989 saw the first attempt at documenting the system usage, with a number of papers describing the formalism: - _Metamathematical Investigations of a Calculus of Constructions_, by - Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published - in Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, - 1990) + Thierry Coquand <>, - _Inductive definitions in the Calculus of Constructions_, by - Christine Paulin-Mohring, + Christine Paulin-Mohrin, - _Extracting Fω's programs from proofs in the Calculus of - Constructions_, by Christine Paulin-Mohring (published in POPL'89) -- _The Constructive Engine_, by Gérard Huet + Constructions_, by Christine Paulin-Mohring <>, +- _The Constructive Engine_, by Gérard Huet <>, as well as a number of user guides: @@ -286,22 +273,15 @@ In the mean time, Thierry Coquand and Christine Paulin-Mohring had been investigating how to add native inductive types to the Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic Type Theory. The impredicative encoding had already been presented in: -F. Pfenning and C. Paulin-Mohring. _Inductively defined types in the -Calculus of Constructions_. Preprint technical report CMU-CS-89-209, -final version in Proceedings of Mathematical Foundations of -Programming Semantics, volume 442, Lecture Notes in Computer -Science. Springer-Verlag, 1990. An extension of the calculus with -primitive inductive types appeared in: Th. Coquand and -C. Paulin-Mohring. _Inductively defined types_. In P. Martin-Löf and -G. Mints, editors, Proceedings of Colog'88, volume 417, Lecture Notes -in Computer Science. Springer-Verlag, 1990. +F. Pfenning and C. Paulin-Mohring. __Inductively defined types in the +Calculus of Constructions__ <>. An extension of the calculus +with primitive inductive types appeared in: Th. Coquand and +C. Paulin-Mohring. __Inductively defined types__ <>. This led to the Calculus of Inductive Constructions, logical formalism implemented in Versions 5 upward of the system, and documented in: -C. Paulin-Mohring. _Inductive Definitions in the System Coq - Rules -and Properties_. In M. Bezem and J.-F. Groote, editors, Proceedings of -the conference Typed Lambda Calculi and Applications, volume 664, -Lecture Notes in Computer Science, 1993. +C. Paulin-Mohring. __Inductive Definitions in the System Coq - Rules +and Properties__ <>. The last version of CONSTR is Version 4.11, which was last distributed in the spring of 1990. It was demonstrated at the first workshop of @@ -335,4 +315,61 @@ section of Coq's Reference Manual. ==== September 2015 + Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. -==== \ No newline at end of file +==== + +[bibliography] +.Bibliographic references + +- [[[CH85]]] Th. Coquand, G. Huet. _Constructions: A Higher Order + Proof System for Mechanizing Mathematics_. Invited paper, EUROCAL85, + April 1985, Linz, Austria. Springer Verlag LNCS 203, pp. 151-184. + +- [[[CH88]]] T. Coquand and G. Huet. _The Calculus of Constructions_. + Submitted on June 30th 1985, accepted on December 5th, 1985, + Information and Computation. Preprint as Rapport de Recherche Inria + n°530, Mai 1986. Final version in Information and Computation + 76,2/3, Feb. 88. + +- [[[CH87]]] Th. Coquand, G. Huet. _Concepts Mathématiques et + Informatiques Formalisés dans le Calcul des Constructions_. Invited + paper, European Logic Colloquium, Orsay, July 1985. Preprint as + Rapport de recherche INRIA n°463, Dec. 85. Published in Logic + Colloquium 1985, North-Holland, 1987. + +- [[[P86]]] C. Paulin. _Algorithm development in the Calculus of + Constructions_, preprint as Rapport de recherche INRIA n°497, + March 86. Final version in Proceedings Symposium on Logic in Computer + Science, Cambridge, MA, 1986 (IEEE Computer Society Press). + +- [[[H88]]] G. Huet. _Induction Principles Formalized in the Calculus + of Constructions_ in Programming of Future Generation Computers, + Ed. K. Fuchi and M. Nivat, North-Holland, 1988. + +- [[[C90]]] Th. Coquand. _Metamathematical Investigations of a + Calculus of Constructions_, by INRIA Research Report N°1088, + Sept. 1989, published in Logic and Computer Science, + ed. P.G. Odifreddi, Academic Press, 1990. + +- [[[P89]]] C. Paulin. _Extracting F ω's programs from proofs in the + calculus of constructions_. 16th Annual ACM Symposium on Principles + of Programming Languages, Austin. 1989. + +- [[[H89]]] G. Huet. _The constructive engine_. A perspective in + Theoretical Computer Science. Commemorative Volume for Gift + Siromoney. World Scientific Publishing (1989). + +- [[[PP90]]] F. Pfenning and C. Paulin-Mohring. _Inductively defined + types in the Calculus of Constructions_. Preprint technical report + CMU-CS-89-209, final version in Proceedings of Mathematical + Foundations of Programming Semantics, volume 442, Lecture Notes in + Computer Science. Springer-Verlag, 1990 + +- [[[CP90]]] Th. Coquand and C. Paulin-Mohring. _Inductively defined + types_. In P. Martin-Löf and G. Mints, editors, Proceedings of + Colog'88, volume 417, Lecture Notes in Computer Science. + Springer-Verlag, 1990. + +- [[[P93]]] C. Paulin-Mohring. _Inductive Definitions in the System + Coq - Rules and Properties_. In M. Bezem and J.-F. Groote, editors, + Proceedings of the conference Typed Lambda Calculi and Applications, + volume 664, Lecture Notes in Computer Science, 1993. -- cgit v1.2.3 From 7978e1dbd6dcd409b0b98a4b407a66b104dff3ba Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 12 Nov 2015 11:59:33 +0100 Subject: Script building MacOS package. --- dev/make-macos-dmg.sh | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100755 dev/make-macos-dmg.sh diff --git a/dev/make-macos-dmg.sh b/dev/make-macos-dmg.sh new file mode 100755 index 0000000000..8f6a7f9e1b --- /dev/null +++ b/dev/make-macos-dmg.sh @@ -0,0 +1,31 @@ +#!/bin/bash + +# Fail on first error +set -e + +# Configuration setup +eval `opam config env` +make distclean +OUTDIR=$PWD/_install +DMGDIR=$PWD/_dmg +./configure -debug -prefix $OUTDIR +VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) +APP=bin/CoqIDE_${VERSION}.app + +# Create a .app file with CoqIDE +~/.local/bin/jhbuild run make -j -l2 $APP + +# Build Coq and run test-suite +make && make check + +# Add Coq to the .app file +make OLDROOT=$OUTDIR COQINSTALLPREFIX=$APP/Contents/Resources/ install-coq install-ide-toploop + +# Sign the .app file +codesign -f -s - $APP + +# Create the dmg bundle +mkdir $DMGDIR +ln -s /Applications $DMGDIR +cp -r $APP $DMGDIR +hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg -- cgit v1.2.3 From 69ed7f0ac9d651eaab85153ea55f5c7d9bf6ae20 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 11 Nov 2015 18:14:40 -0500 Subject: Update CHANGES Mention compatibility file. --- CHANGES | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGES b/CHANGES index f67c34b81b..719be44929 100644 --- a/CHANGES +++ b/CHANGES @@ -68,6 +68,13 @@ Tools path of a given library rather than a physical path, thus they behave like Require [Import] path. +Standard Library + + - There is now a Coq.Compat.Coq84 library, which sets the various compatibility + options and does a few redefinitions to make Coq behave more like Coq v8.4. + The standard way of putting Coq in v8.4 compatibility mode is to pass the command + line flags "-require Coq.Compat.Coq84 -compat 8.4". + Changes from V8.5beta1 to V8.5beta2 =================================== -- cgit v1.2.3 From db002583b18c8742c0cd8e1a12305166b6b791ce Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 12 Nov 2015 12:05:00 +0100 Subject: Fixed test-suite file for bug #3998. --- test-suite/bugs/closed/3998.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 test-suite/bugs/closed/3998.v diff --git a/test-suite/bugs/closed/3998.v b/test-suite/bugs/closed/3998.v new file mode 100644 index 0000000000..ced13839dd --- /dev/null +++ b/test-suite/bugs/closed/3998.v @@ -0,0 +1,24 @@ +Class FieldType (F : Set) := mkFieldType { fldTy: F -> Set }. +Hint Mode FieldType + : typeclass_instances. (* The F parameter is an input *) + +Inductive I1 := C. +Inductive I2 := . + +Instance I1FieldType : FieldType I1 := { fldTy := I1_rect _ bool }. +Instance I2FieldType : FieldType I2 := { fldTy := I2_rect _ }. + +Definition RecordOf F (FT: FieldType F) := forall f:F, fldTy f. + +Class MapOps (M K : Set) := { + tgtTy: K -> Set; + update: M -> forall k:K, tgtTy k -> M +}. + +Instance RecordMapOps F (FT: FieldType F) : MapOps (RecordOf F FT) F := +{ tgtTy := fldTy; update := fun r (f: F) (x: fldTy f) z => r z }. + +Axiom ex : RecordOf _ I1FieldType. + +Definition works := (fun ex' => update ex' C true) (update ex C false). +Set Typeclasses Debug. +Definition doesnt := update (update ex C false) C true. \ No newline at end of file -- cgit v1.2.3 From 0c11bc39927c7756a0e3c3a6c445f20d0daaad7f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 12 Nov 2015 14:14:38 +0100 Subject: Fix bug #4412: [rewrite] (setoid_rewrite?) creates ill-typed terms. We retypecheck the hypotheses introduced by the refine primitive instead of blindly trusting them when the unsafe flag is set to false. --- proofs/proofview.ml | 26 +++++++++++++++++++++++++- test-suite/bugs/closed/4412.v | 4 ++++ 2 files changed, 29 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4412.v diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 4fc0c164e3..59a64658dc 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1010,10 +1010,34 @@ end module Refine = struct + let extract_prefix env info = + let ctx1 = List.rev (Environ.named_context env) in + let ctx2 = List.rev (Evd.evar_context info) in + let rec share l1 l2 accu = match l1, l2 with + | d1 :: l1, d2 :: l2 -> + if d1 == d2 then share l1 l2 (d1 :: accu) + else (accu, d2 :: l2) + | _ -> (accu, l2) + in + share ctx1 ctx2 [] + let typecheck_evar ev env sigma = let info = Evd.find sigma ev in + (** Typecheck the hypotheses. *) + let type_hyp (sigma, env) (na, body, t as decl) = + let evdref = ref sigma in + let _ = Typing.sort_of env evdref t in + let () = match body with + | None -> () + | Some body -> Typing.check env evdref body t + in + (!evdref, Environ.push_named decl env) + in + let (common, changed) = extract_prefix env info in + let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in + let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in + (** Typecheck the conclusion *) let evdref = ref sigma in - let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in let _ = Typing.sort_of env evdref (Evd.evar_concl info) in !evdref diff --git a/test-suite/bugs/closed/4412.v b/test-suite/bugs/closed/4412.v new file mode 100644 index 0000000000..4b2aae0c7b --- /dev/null +++ b/test-suite/bugs/closed/4412.v @@ -0,0 +1,4 @@ +Require Import Coq.Bool.Bool Coq.Setoids.Setoid. +Goal forall (P : forall b : bool, b = true -> Type) (x y : bool) (H : andb x y = true) (H' : P _ H), True. + intros. + Fail rewrite Bool.andb_true_iff in H. -- cgit v1.2.3 From 2fd497d380de998c4b22b9f7167eb4023e4cd576 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 13 Nov 2015 14:21:01 +0100 Subject: MacOS package script: do not fail if directory _dmg already exists. --- dev/make-macos-dmg.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/make-macos-dmg.sh b/dev/make-macos-dmg.sh index 8f6a7f9e1b..a8b5d10dad 100755 --- a/dev/make-macos-dmg.sh +++ b/dev/make-macos-dmg.sh @@ -25,7 +25,7 @@ make OLDROOT=$OUTDIR COQINSTALLPREFIX=$APP/Contents/Resources/ install-coq insta codesign -f -s - $APP # Create the dmg bundle -mkdir $DMGDIR +mkdir -p $DMGDIR ln -s /Applications $DMGDIR cp -r $APP $DMGDIR hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg -- cgit v1.2.3 From 3aeb18bf1412a27309c39713e05eca2c27706ca8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 13 Nov 2015 16:33:26 +0100 Subject: Continue fix of PMP, handling setoid_rewrite in let-bound hyps correctly. --- tactics/rewrite.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index af6953bf85..182c232ae9 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1505,7 +1505,7 @@ let assert_replacing id newt tac = let after, before = List.split_when (fun (n, b, t) -> Id.equal n id) ctx in let nc = match before with | [] -> assert false - | (id, b, _) :: rem -> insert_dependent env (id, b, newt) [] after @ rem + | (id, b, _) :: rem -> insert_dependent env (id, None, newt) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Proofview.Refine.refine ~unsafe:false begin fun sigma -> -- cgit v1.2.3 From 3b2c4cb7f53ff664b72e21ca9a653f244624833e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 15 Nov 2015 15:19:05 +0100 Subject: Displaying the object identifier in votour. --- checker/votour.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/checker/votour.ml b/checker/votour.ml index 4aecb28f20..f8264ca684 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -22,6 +22,7 @@ sig val input : in_channel -> obj val repr : obj -> obj repr val size : obj -> int + val oid : obj -> int option end module ReprObj : S = @@ -45,6 +46,7 @@ struct else INT (Obj.magic obj) let size (_, p) = CObj.shared_size_of_pos p + let oid _ = None end module ReprMem : S = @@ -97,6 +99,9 @@ struct let _ = init_size seen obj in obj + let oid = function + | Int _ | Atm _ | Fun _ -> None + | Ptr p -> Some p end module Visit (Repr : S) : @@ -149,9 +154,13 @@ let rec get_details v o = match v, Repr.repr o with |Annot (s,v), _ -> get_details v o |_ -> "" +let get_oid obj = match Repr.oid obj with +| None -> "" +| Some id -> Printf.sprintf " [0x%08x]" id + let node_info (v,o,p) = get_name ~extra:true v ^ get_details v o ^ - " (size "^ string_of_int (Repr.size o)^"w)" + " (size "^ string_of_int (Repr.size o)^"w)" ^ get_oid o (** Children of a block : type, object, position. For lists, we collect all elements of the list at once *) -- cgit v1.2.3 From 73c9ad1ff19915fbaf053119c5498ff1314e92e3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 15 Nov 2015 17:47:24 +0100 Subject: Fixing output test Cases.v. Not sure if this is really what is expected though. --- test-suite/output/Cases.out | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 09f032d478..f846f4ee10 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -47,10 +47,10 @@ foo' = if A 0 then true else false f = fun H : B => match H with -| AC x => - (let b0 := b in - if b0 as b return (P b -> True) +| AC H0 => + let b0 := b in + (if b0 as b return (P b -> True) then fun _ : P true => Logic.I - else fun _ : P false => Logic.I) x + else fun _ : P false => Logic.I) H0 end : B -> True -- cgit v1.2.3 From 6cd0ac247b7b6fa757a8e0b5369b6d27a0e0ebd9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 13 Nov 2015 14:41:14 +0100 Subject: Hashconsing modules. Modules inserted into the environment were not hashconsed, leading to an important redundancy, especially in module signatures that are always fully expanded. This patch divides by two the size and memory consumption of module-heavy files by hashconsing modules before putting them in the environment. Note that this is not a real hashconsing, in the sense that we only hashcons the inner terms contained in the modules, that are only mapped over. Compilation time should globally decrease, even though some files definining a lot of modules may see their compilation time increase. Some remaining overhead may persist, as for instance module inclusion is not hashconsed. --- kernel/declareops.ml | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++ kernel/declareops.mli | 1 + kernel/names.mli | 2 ++ kernel/safe_typing.ml | 2 ++ 4 files changed, 90 insertions(+) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 248504c1b1..73cfd01221 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -308,3 +308,88 @@ let string_of_side_effect { Entries.eff } = match eff with | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.string_of_con c ^ ")" | Entries.SEscheme (cl,_) -> "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) ^ ")" + +(** Hashconsing of modules *) + +let hcons_functorize hty he hself f = match f with +| NoFunctor e -> + let e' = he e in + if e == e' then f else NoFunctor e' +| MoreFunctor (mid, ty, nf) -> + (** FIXME *) + let mid' = mid in + let ty' = hty ty in + let nf' = hself nf in + if mid == mid' && ty == ty' && nf == nf' then f + else MoreFunctor (mid, ty', nf') + +let hcons_module_alg_expr me = me + +let rec hcons_structure_field_body sb = match sb with +| SFBconst cb -> + let cb' = hcons_const_body cb in + if cb == cb' then sb else SFBconst cb' +| SFBmind mib -> + let mib' = hcons_mind mib in + if mib == mib' then sb else SFBmind mib' +| SFBmodule mb -> + let mb' = hcons_module_body mb in + if mb == mb' then sb else SFBmodule mb' +| SFBmodtype mb -> + let mb' = hcons_module_body mb in + if mb == mb' then sb else SFBmodtype mb' + +and hcons_structure_body sb = + (** FIXME *) + let map (l, sfb as fb) = + let l' = Names.Label.hcons l in + let sfb' = hcons_structure_field_body sfb in + if l == l' && sfb == sfb' then fb else (l', sfb') + in + List.smartmap map sb + +and hcons_module_signature ms = + hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms + +and hcons_module_expression me = + hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me + +and hcons_module_implementation mip = match mip with +| Abstract -> Abstract +| Algebraic me -> + let me' = hcons_module_expression me in + if me == me' then mip else Algebraic me' +| Struct ms -> + let ms' = hcons_module_signature ms in + if ms == ms' then mip else Struct ms +| FullStruct -> FullStruct + +and hcons_module_body mb = + let mp' = mb.mod_mp in + let expr' = hcons_module_implementation mb.mod_expr in + let type' = hcons_module_signature mb.mod_type in + let type_alg' = mb.mod_type_alg in + let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in + let delta' = mb.mod_delta in + let retroknowledge' = mb.mod_retroknowledge in + + if + mb.mod_mp == mp' && + mb.mod_expr == expr' && + mb.mod_type == type' && + mb.mod_type_alg == type_alg' && + mb.mod_constraints == constraints' && + mb.mod_delta == delta' && + mb.mod_retroknowledge == retroknowledge' + then mb + else { + mod_mp = mp'; + mod_expr = expr'; + mod_type = type'; + mod_type_alg = type_alg'; + mod_constraints = constraints'; + mod_delta = delta'; + mod_retroknowledge = retroknowledge'; + } + +and hcons_module_type_body mtb = hcons_module_body mtb diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 1b87009589..1d08118826 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -77,3 +77,4 @@ val inductive_context : mutual_inductive_body -> universe_context val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body +val hcons_module_body : module_body -> module_body diff --git a/kernel/names.mli b/kernel/names.mli index 77139f1c31..c5a7d8f3cc 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -160,6 +160,8 @@ sig module Set : Set.S with type elt = t module Map : Map.ExtS with type key = t and module Set := Set + val hcons : t -> t + end (** {6 Unique names for bound modules} *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index e0a07dcc3a..f86fdfa971 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -561,6 +561,7 @@ let add_mind dir l mie senv = let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in + let mtb = Declareops.hcons_module_body mtb in let senv' = add_field (l,SFBmodtype mtb) MT senv in mp, senv' @@ -581,6 +582,7 @@ let full_add_module_type mp mt senv = let add_module l me inl senv = let mp = MPdot(senv.modpath, l) in let mb = Mod_typing.translate_module senv.env mp inl me in + let mb = Declareops.hcons_module_body mb in let senv' = add_field (l,SFBmodule mb) M senv in let senv'' = if Modops.is_functor mb.mod_type then senv' -- cgit v1.2.3 From 8e482fc932fa2b1893025d914d42dd17881c2fac Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 15 Nov 2015 18:51:33 +0100 Subject: Being more precise and faithful about the origin of the file reporting about the prehistory of Coq. --- dev/doc/README-V1-V5 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/dev/doc/README-V1-V5 b/dev/doc/README-V1-V5 index 2ca62e3d74..ebbc057734 100644 --- a/dev/doc/README-V1-V5 +++ b/dev/doc/README-V1-V5 @@ -1,10 +1,13 @@ Notes on the prehistory of Coq -This archive contains the sources of the CONSTR ancestor of the Coq proof -assistant. CONSTR, then Coq, was designed and implemented in the Formel team, -joint between the INRIA Rocquencourt laboratory and the Ecole Normale Supérieure -of Paris, from 1984 onwards. +This document is a copy within the Coq archive of a document written +in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin +to accompany their public release of the archive of versions 1.10 to 6.2 +of Coq and of its CONSTR ancestor. CONSTR, then Coq, was designed and +implemented in the Formel team, joint between the INRIA Rocquencourt +laboratory and the Ecole Normale Supérieure of Paris, from 1984 +onwards. Version 1 -- cgit v1.2.3 From af399d81b0505d1f0be8e73cf45044266d5749e5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 17 Nov 2015 12:39:35 +0100 Subject: Performance fix for destruct. The clenv_fchain function was needlessly merging universes coming from two evarmaps even though one was an extension of the other. A flag was added so that the tactic just retrieves the newer universes. --- pretyping/evd.ml | 7 +++++-- pretyping/evd.mli | 2 +- proofs/clenv.ml | 4 ++-- proofs/clenv.mli | 2 +- tactics/tactics.ml | 4 +++- 5 files changed, 12 insertions(+), 7 deletions(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 4a9466f4f3..c9b9f34414 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1550,9 +1550,12 @@ let meta_with_name evd id = let clear_metas evd = {evd with metas = Metamap.empty} -let meta_merge evd1 evd2 = +let meta_merge ?(with_univs = true) evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in - let universes = union_evar_universe_context evd2.universes evd1.universes in + let universes = + if with_univs then union_evar_universe_context evd2.universes evd1.universes + else evd2.universes + in {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 5c508419a4..117e52958b 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -451,7 +451,7 @@ val meta_reassign : metavariable -> constr * instance_status -> evar_map -> eva val clear_metas : evar_map -> evar_map (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) -val meta_merge : evar_map -> evar_map -> evar_map +val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map val undefined_metas : evar_map -> metavariable list val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map diff --git a/proofs/clenv.ml b/proofs/clenv.ml index a2cccc0e0b..5de8338ab6 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -379,12 +379,12 @@ let fchain_flags () = { (default_unify_flags ()) with allow_K_in_toplevel_higher_order_unification = true } -let clenv_fchain ?(flags=fchain_flags ()) mv clenv nextclenv = +let clenv_fchain ?with_univs ?(flags=fchain_flags ()) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) let clenv' = { templval = clenv.templval; templtyp = clenv.templtyp; - evd = meta_merge nextclenv.evd clenv.evd; + evd = meta_merge ?with_univs nextclenv.evd clenv.evd; env = nextclenv.env } in (* unify the type of the template of [nextclenv] with the type of [mv] *) let clenv'' = diff --git a/proofs/clenv.mli b/proofs/clenv.mli index eb10817069..26e803354e 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -51,7 +51,7 @@ val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : - ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv + ?with_univs:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv (** {6 Unification with clenvs } *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0a013e95f7..0551787e3a 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1319,7 +1319,9 @@ let simplest_elim c = default_elim false None (c,NoBindings) *) let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - try clenv_fchain ~flags mv elimclause hypclause + (** The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) + try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) -- cgit v1.2.3 From c4fef5b9d2be739cad030131fd6fc4c07d5e2e08 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 17 Nov 2015 19:24:41 +0100 Subject: More optimizations of [Clenv.clenv_fchain]. Everywhere we know that the universes of the left argument are an extension of the right argument, we do not have to merge universes. --- tactics/equality.ml | 2 +- tactics/tacticals.ml | 2 +- tactics/tactics.ml | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index 674c85af79..fe0ca61c66 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -914,7 +914,7 @@ let apply_on_clause (f,t) clause = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in - clenv_fchain argmv f_clause clause + clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e = next_ident_away eq_baseid (ids_of_context env) in diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bc82e9ef46..4cce891a2a 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -620,7 +620,7 @@ module New = struct errorlabstrm "Tacticals.general_elim_then_using" (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in - let elimclause' = clenv_fchain indmv elimclause indclause in + let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in let branchsigns = compute_construtor_signatures isrec ind in let brnames = compute_induction_names (Array.length branchsigns) allnames in let flags = Unification.elim_flags () in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0551787e3a..8daa7c4b86 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1605,7 +1605,7 @@ let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in if List.is_empty ordered_metas then error "Statement without assumptions."; let f mv = - try Some (find_matching_clause (clenv_fchain mv ~flags clause) innerclause) + try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas @@ -3756,7 +3756,7 @@ let recolle_clenv i params args elimclause gl = trying to unify (which would lead to trying to apply it to evars if y is a product). *) let indclause = mk_clenv_from_n gl (Some 0) (x,y) in - let elimclause' = clenv_fchain i acc indclause in + let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') (List.rev clauses) elimclause -- cgit v1.2.3 From 5ccadc40d54090df5e6b61b4ecbb6083d01e5a88 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 18 Nov 2015 00:56:29 +0100 Subject: Inlining the only use of Clenv.connect_clenv. --- proofs/clenv.ml | 9 --------- proofs/clenv.mli | 1 - tactics/class_tactics.ml | 4 ++-- 3 files changed, 2 insertions(+), 12 deletions(-) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index ae790d9b82..bc6e75c38d 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -345,15 +345,6 @@ let clenv_pose_metas_as_evars clenv dep_mvs = (******************************************************************) -let connect_clenv gls clenv = - let evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd in - { clenv with - evd = evd ; - env = Goal.V82.env evd (sig_it gls) } - -(* let connect_clenv_key = Profile.declare_profile "connect_clenv";; *) -(* let connect_clenv = Profile.profile2 connect_clenv_key connect_clenv *) - (* [clenv_fchain mv clenv clenv'] * * Resolves the value of "mv" (which must be undefined) in clenv to be diff --git a/proofs/clenv.mli b/proofs/clenv.mli index eb10817069..ca62c985ec 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -49,7 +49,6 @@ val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst (** {6 linking of clenvs } *) -val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 8ee3ec9281..4f0ffa024e 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -158,9 +158,9 @@ let e_give_exact flags poly (c,clenv) gl = let c, gl = if poly then let clenv', subst = Clenv.refresh_undefined_univs clenv in - let clenv' = connect_clenv gl clenv' in + let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in let c = Vars.subst_univs_level_constr subst c in - c, {gl with sigma = clenv'.evd} + c, {gl with sigma = evd} else c, gl in let t1 = pf_unsafe_type_of gl c in -- cgit v1.2.3 From c71aa6bd368b801bb17d4da69d1ab1e2bd7cbf39 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 07:20:34 +0100 Subject: Fixing logical bugs in the presence of let-ins in computiong primitive projections. - lift accounting for the record missing in computing the subst from fields to projections of the record - substitution for parameters should not lift the local definitions - typo in building the latter (subst -> letsubst) --- kernel/indtypes.ml | 17 +++++++++-------- test-suite/success/primitiveproj.v | 15 ++++++++++++++- 2 files changed, 23 insertions(+), 9 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 351de9ee88..f08f0b7bbb 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -654,13 +654,12 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params matching with a parameter context. *) let indty, paramsletsubst = let subst, inst = - List.fold_right - (fun (na, b, t) (subst, inst) -> + List.fold_right_i + (fun i (na, b, t) (subst, inst) -> match b with - | None -> (mkRel 1 :: List.map (lift 1) subst, - mkRel 1 :: List.map (lift 1) inst) - | Some b -> (substl subst b) :: subst, List.map (lift 1) inst) - paramslet ([], []) + | None -> (mkRel i :: subst, mkRel i :: inst) + | Some b -> (substl subst b) :: subst, inst) + 1 paramslet ([], []) in let subst = (* For the record parameter: *) mkRel 1 :: List.map (lift 1) subst @@ -690,8 +689,10 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params in let projections (na, b, t) (i, j, kns, pbs, subst, letsubst) = match b with - | Some c -> (i, j+1, kns, pbs, substl subst c :: subst, - substl letsubst c :: subst) + | Some c -> + let c = liftn 1 j c in + (i, j+1, kns, pbs, substl subst c :: subst, + substl letsubst c :: letsubst) | None -> match na with | Name id -> diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 125615c535..281d707cb3 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -194,4 +194,17 @@ Record wrap (A : Type) := { unwrap : A; unwrap2 : A }. Definition term (x : wrap nat) := x.(unwrap). Definition term' (x : wrap nat) := let f := (@unwrap2 nat) in f x. Recursive Extraction term term'. -(*Unset Printing Primitive Projection Parameters.*) \ No newline at end of file +(*Unset Printing Primitive Projection Parameters.*) + +(* Primitive projections in the presence of let-ins (was not failing in beta3)*) + +Set Primitive Projections. +Record s (x:nat) (y:=S x) := {c:=x; d:x=c}. +Lemma f : 0=1. +Proof. +Fail apply d. +(* +split. +reflexivity. +Qed. +*) -- cgit v1.2.3 From df04191b48350b76a7650cccc68c9dfc60447787 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 07:33:55 +0100 Subject: Slightly documenting code for building primitive projections. --- kernel/indtypes.ml | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index f08f0b7bbb..6c32626ad9 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -690,15 +690,36 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params let projections (na, b, t) (i, j, kns, pbs, subst, letsubst) = match b with | Some c -> + (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) let c = liftn 1 j c in - (i, j+1, kns, pbs, substl subst c :: subst, - substl letsubst c :: letsubst) + (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I |- c(params,proj1 x,..,projj x)] *) + let c1 = substl subst c in + (* From [params, x:I |- subst:field1,..,fieldj] + to [params, x:I |- subst:field1,..,fieldj+1] where [subst] + is represented with instance of field1 last *) + let subst = c1 :: subst in + (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params-wo-let, x:I |- c(params,proj1 x,..,projj x)] *) + let c2 = substl letsubst c in + (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] + to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) + let letsubst = c2 :: letsubst in + (i, j+1, kns, pbs, subst, letsubst) | None -> match na with | Name id -> let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in - let projty = substl letsubst (liftn 1 j t) in - let ty = substl subst (liftn 1 j t) in + (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) + let t = liftn 1 j t in + (* from [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params-wo-let, x:I |- t(params,proj1 x,..,projj x)] *) + let projty = substl letsubst t in + (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] + to [params, x:I |- t(proj1 x,..,projj x)] *) + let ty = substl subst t in let term = mkProj (Projection.make kn true, mkRel 1) in let fterm = mkProj (Projection.make kn false, mkRel 1) in let compat = compat_body ty (j - 1) in -- cgit v1.2.3 From 23e6963a8168756f225ea2ae75fcf2af6952c6c3 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 18 Nov 2015 14:50:35 +0100 Subject: MacOS package script: do not fail if link to /Applications already exists. --- dev/make-macos-dmg.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/make-macos-dmg.sh b/dev/make-macos-dmg.sh index a8b5d10dad..70889badc1 100755 --- a/dev/make-macos-dmg.sh +++ b/dev/make-macos-dmg.sh @@ -26,6 +26,6 @@ codesign -f -s - $APP # Create the dmg bundle mkdir -p $DMGDIR -ln -s /Applications $DMGDIR +ln -sf /Applications $DMGDIR/Applications cp -r $APP $DMGDIR hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg -- cgit v1.2.3 From 6f88442be8275361a7b68fd56d40976fdee9f4d5 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 18 Nov 2015 15:58:17 +0100 Subject: Improve error message. --- tactics/tacinterp.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 355745d970..d244129425 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -989,7 +989,7 @@ let interp_induction_arg ist gl arg = try sigma, (constr_of_id env id', NoBindings) with Not_found -> user_err_loc (loc, "interp_induction_arg", - pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis.")) + pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.")) in try (** FIXME: should be moved to taccoerce *) -- cgit v1.2.3 From 0346ee4472711fc30b7cf197c1bad5c32140f831 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 18 Nov 2015 17:10:44 +0100 Subject: Fix a bug preventing the generation of graphs when doing multiple pattern-matching on function calls. --- plugins/funind/glob_term_to_relation.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 1b12cd42ce..5d92fca5ea 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -681,7 +681,7 @@ and build_entry_lc_from_case env funname make_discr let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env funname avoid case_arg in + let arg_res = build_entry_lc env funname ctxt_argsl.to_avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el -- cgit v1.2.3 From 6ababf42b3f03926c30cfbd209436ec83a21769e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 18 Nov 2015 17:04:12 +0100 Subject: Fixing fix c71aa6b to primitive projections. - Introduced an error: fold was counting in the wrong direction and I did not test it. Sorry. - Substitution from params-with-let to params-without-let was still not correct. Hopefully everything ok now. Eventually, we should use canonical combinators for that: extended_rel_context to built the instance and and a combinator apparently yet to define for building a substitution contracting the let-ins. --- kernel/indtypes.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 6c32626ad9..a46c33bf03 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -653,13 +653,13 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params that typechecking projections requires just a substitution and not matching with a parameter context. *) let indty, paramsletsubst = - let subst, inst = - List.fold_right_i - (fun i (na, b, t) (subst, inst) -> + let _, _, subst, inst = + List.fold_right + (fun (na, b, t) (i, j, subst, inst) -> match b with - | None -> (mkRel i :: subst, mkRel i :: inst) - | Some b -> (substl subst b) :: subst, inst) - 1 paramslet ([], []) + | None -> (i-1, j-1, mkRel i :: subst, mkRel j :: inst) + | Some b -> (i, j-1, substl subst b :: subst, inst)) + paramslet (nparamargs, List.length paramslet, [], []) in let subst = (* For the record parameter: *) mkRel 1 :: List.map (lift 1) subst -- cgit v1.2.3 From 9d47cc0af706ed1cd4ab87c2d402a0457a9b6a5c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 19 Nov 2015 17:48:32 +0100 Subject: Fix bug #4433, removing hack on evars appearing in a pattern from a constr, and the associated signature, not needed anymore. Update CHANGES, no evar_map is produced by pattern_of_constr anymore. --- CHANGES | 2 -- plugins/quote/quote.ml | 4 ++-- pretyping/patternops.ml | 29 +++++++---------------------- pretyping/patternops.mli | 3 +-- tactics/hints.ml | 6 +++--- tactics/tacinterp.ml | 10 +++++----- 6 files changed, 18 insertions(+), 36 deletions(-) diff --git a/CHANGES b/CHANGES index 719be44929..07d6281717 100644 --- a/CHANGES +++ b/CHANGES @@ -107,8 +107,6 @@ API - The interface of [change] has changed to take a [change_arg], which can be built from a [constr] using [make_change_arg]. -- [pattern_of_constr] now returns a triplet including the cleaned-up - [evar_map], removing the evars that were turned into metas. Changes from V8.4 to V8.5beta1 ============================== diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 2a2ef30fb1..b72ebbc927 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -211,9 +211,9 @@ let compute_rhs bodyi index_of_f = let i = destRel (Array.last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> - PApp (pi3 (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args) + PApp (pattern_of_constr (Global.env()) Evd.empty f, Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> pi3 (pattern_of_constr (Global.env())(*FIXME*) Evd.empty c) + | _ -> pattern_of_constr (Global.env())(*FIXME*) Evd.empty c in aux bodyi diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index fb629d049f..83bf355cc2 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -122,9 +122,6 @@ let head_of_constr_reference c = match kind_of_term c with | _ -> anomaly (Pp.str "Not a rigid reference") let pattern_of_constr env sigma t = - let ctx = ref [] in - let keep = ref Evar.Set.empty in - let remove = ref Evar.Set.empty in let rec pattern_of_constr env t = match kind_of_term t with | Rel n -> PRel n @@ -143,14 +140,9 @@ let pattern_of_constr env sigma t = | App (f,a) -> (match match kind_of_term f with - | Evar (evk,args as ev) -> + | Evar (evk,args) -> (match snd (Evd.evar_source evk sigma) with - Evar_kinds.MatchingVar (true,id) -> - let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in - ctx := (id,None,ty)::!ctx; - keep := Evar.Set.union (evars_of_term ty) !keep; - remove := Evar.Set.add evk !remove; - Some id + Evar_kinds.MatchingVar (true,id) -> Some id | _ -> None) | _ -> None with @@ -162,13 +154,11 @@ let pattern_of_constr env sigma t = | Proj (p, c) -> pattern_of_constr env (Retyping.expand_projection env sigma p c []) | Evar (evk,ctxt as ev) -> - remove := Evar.Set.add evk !remove; (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in - ctx := (id,None,ty)::!ctx; - let () = ignore (pattern_of_constr env ty) in - assert (not b); PMeta (Some id) + let () = ignore (pattern_of_constr env ty) in + assert (not b); PMeta (Some id) | Evar_kinds.GoalEvar -> PEvar (evk,Array.map (pattern_of_constr env) ctxt) | _ -> @@ -189,12 +179,7 @@ let pattern_of_constr env sigma t = Array.to_list (Array.mapi branch_of_constr br)) | Fix f -> PFix f | CoFix f -> PCoFix f in - let p = pattern_of_constr env t in - let remove = Evar.Set.diff !remove !keep in - let sigma = Evar.Set.fold (fun ev acc -> Evd.remove acc ev) remove sigma in - (* side-effect *) - (* Warning: the order of dependencies in ctx is not ensured *) - (sigma,!ctx,p) + pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -234,7 +219,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - pi3 (pattern_of_constr env sigma c) + pattern_of_constr env sigma c with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in @@ -259,7 +244,7 @@ let rec subst_pattern subst pat = | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else - pi3 (pattern_of_constr (Global.env()) Evd.empty t) + pattern_of_constr (Global.env()) Evd.empty t | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 9e72280fe2..0148280287 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -39,8 +39,7 @@ val head_of_constr_reference : Term.constr -> global_reference a pattern; currently, no destructor (Cases, Fix, Cofix) and no existential variable are allowed in [c] *) -val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> - Evd.evar_map * named_context * constr_pattern +val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> constr_pattern (** [pattern_of_glob_constr l c] translates a term [c] with metavariables into a pattern; variables bound in [l] are replaced by the pattern to which they diff --git a/tactics/hints.ml b/tactics/hints.ml index 5630d20b5d..6250886821 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -677,7 +677,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = pi3 (Patternops.pattern_of_constr env sigma cty) in + let pat = Patternops.pattern_of_constr env sigma cty in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" @@ -696,7 +696,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = pi3 (Patternops.pattern_of_constr env ce.evd c') in + let pat = Patternops.pattern_of_constr env ce.evd c' in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in @@ -794,7 +794,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; - pat = Some (pi3 (Patternops.pattern_of_constr env ce.evd (clenv_type ce))); + pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index d244129425..ee21a51598 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -688,12 +688,12 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = try Inl (coerce_to_evaluable_ref env x) with CannotCoerceTo _ -> let c = coerce_to_closed_constr env x in - Inr (pi3 (pattern_of_constr env sigma c)) in + Inr (pattern_of_constr env sigma c) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) - | Inr c -> Inr (pi3 (interp_typed_pattern ist env sigma c)) in + | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p let interp_constr_with_occurrences_and_name_as_list = @@ -1043,7 +1043,7 @@ let use_types = false let eval_pattern lfun ist env sigma ((glob,_),pat as c) = let bound_names = bound_glob_vars glob in if use_types then - (bound_names,pi3 (interp_typed_pattern ist env sigma c)) + (bound_names,interp_typed_pattern ist env sigma c) else (bound_names,instantiate_pattern env sigma lfun pat) @@ -2154,7 +2154,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in Proofview.V82.tactic begin fun gl -> - let (sigma,sign,op) = interp_typed_pattern ist env sigma op in + let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in let c_interp patvars sigma = let lfun' = Id.Map.fold (fun id c lfun -> @@ -2167,7 +2167,7 @@ and interp_atomic ist tac : unit Proofview.tactic = errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") in (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) - { gl with sigma = sigma } + gl end end end -- cgit v1.2.3 From cfc0fc0075784e75783c9b4482fd3f4b858a44bf Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 19 Nov 2015 17:49:32 +0100 Subject: Allow program hooks to see the refined universe_context at the end of a definition, if they manipulate structures depending on the initial state of the context. --- toplevel/classes.ml | 2 +- toplevel/command.ml | 5 +++-- toplevel/obligations.ml | 13 +++++++------ toplevel/obligations.mli | 4 ++-- 4 files changed, 13 insertions(+), 11 deletions(-) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index c354c7d32f..6de0a9f55c 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -288,7 +288,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro else if !refine_instance || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then - let hook vis gr = + let hook vis gr _ = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; Typeclasses.declare_instance pri (not global) (ConstRef cst) diff --git a/toplevel/command.ml b/toplevel/command.ml index 3d338ee0a3..0b709a3fc4 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -192,6 +192,7 @@ let do_definition ident k pl bl red_option c ctypopt hook = Obligations.eterm_obligations env ident evd 0 c typ in let ctx = Evd.evar_universe_context evd in + let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in ignore(Obligations.add_definition ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in @@ -1010,7 +1011,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let hook, recname, typ = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in - let hook l gr = + let hook l gr _ = let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let pl, univs = Evd.universe_context !evdref in @@ -1026,7 +1027,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = hook, name, typ else let typ = it_mkProd_or_LetIn top_arity binders_rel in - let hook l gr = + let hook l gr _ = if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false gr [impls] in hook, recname, typ diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 9019f486be..311c61f894 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -318,7 +318,7 @@ type program_info_aux = { prg_notations : notations ; prg_kind : definition_kind; prg_reduce : constr -> constr; - prg_hook : unit Lemmas.declaration_hook; + prg_hook : (Evd.evar_universe_context -> unit) Lemmas.declaration_hook; prg_opaque : bool; } @@ -517,7 +517,7 @@ let declare_definition prg = progmap_remove prg; !declare_definition_ref prg.prg_name prg.prg_kind ce prg.prg_implicits - (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r; r)) + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) open Pp @@ -582,6 +582,7 @@ let declare_mutual_definition l = in (* Declare the recursive definitions *) let ctx = Evd.evar_context_universe_context first.prg_ctx in + let fix_exn = Stm.get_fix_exn () in let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) @@ -589,8 +590,8 @@ let declare_mutual_definition l = Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in - Lemmas.call_hook (fun exn -> exn) first.prg_hook local gr; - List.iter progmap_remove l; kn + Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx; + List.iter progmap_remove l; kn let shrink_body c = let ctx, b = decompose_lam c in @@ -987,7 +988,7 @@ let show_term n = ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic - ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) obls = + ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let info = str (Id.to_string n) ++ str " has type-checked" in let prg = init_prog_info ~opaque n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in @@ -1005,7 +1006,7 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) | _ -> res) let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) - ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) notations fixkind = + ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 61a8ee520f..2e3aa60054 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -68,7 +68,7 @@ val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress + ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -84,7 +84,7 @@ val add_mutual_definitions : ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> + ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> notations -> fixpoint_kind -> unit -- cgit v1.2.3 From 574e510ba069f1747ecb1e5a17cf86c902d79d44 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 19 Nov 2015 18:40:32 +0100 Subject: Fix bug #4429: eauto with arith: 70x performance regression in Coq 8.5. The issue was due to the fact that unfold hints are given a priority of 4 by default. As eauto was now using hint priority rather than the number of goals produced to order the application of hints, unfold were almost always used too late. We fixed this by manually giving them a priority of 1 in the eauto tactic. Also fixed the relative order of proof depth w.r.t. hint priority. It should not be observable except for breadth-first search, which is seldom used. --- tactics/eauto.ml4 | 8 ++++++-- test-suite/bugs/closed/4429.v | 31 +++++++++++++++++++++++++++++++ 2 files changed, 37 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/4429.v diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index ee7b94b0d1..20a7448dcb 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -166,6 +166,10 @@ and e_my_find_search db_list local_db hdc concl = in let tac_of_hint = fun (st, {pri = b; pat = p; code = t; poly = poly}) -> + let b = match Hints.repr_hint t with + | Unfold_nth _ -> 1 + | _ -> b + in (b, let tac = function | Res_pf (term,cl) -> unify_resolve poly st (term,cl) @@ -245,8 +249,8 @@ module SearchProblem = struct let d = s'.depth - s.depth in let d' = Int.compare s.priority s'.priority in let nbgoals s = List.length (sig_it s.tacres) in - if not (Int.equal d' 0) then d' - else if not (Int.equal d 0) then d + if not (Int.equal d 0) then d + else if not (Int.equal d' 0) then d' else Int.compare (nbgoals s) (nbgoals s') let branching s = diff --git a/test-suite/bugs/closed/4429.v b/test-suite/bugs/closed/4429.v new file mode 100644 index 0000000000..bf0e570ab8 --- /dev/null +++ b/test-suite/bugs/closed/4429.v @@ -0,0 +1,31 @@ +Require Import Arith.Compare_dec. +Require Import Unicode.Utf8. + +Fixpoint my_nat_iter (n : nat) {A} (f : A → A) (x : A) : A := + match n with + | O => x + | S n' => f (my_nat_iter n' f x) + end. + +Definition gcd_IT_F (f : nat * nat → nat) (mn : nat * nat) : nat := + match mn with + | (0, 0) => 0 + | (0, S n') => S n' + | (S m', 0) => S m' + | (S m', S n') => + match le_gt_dec (S m') (S n') with + | left _ => f (S m', S n' - S m') + | right _ => f (S m' - S n', S n') + end + end. + +Axiom max_correct_l : ∀ m n : nat, m <= max m n. +Axiom max_correct_r : ∀ m n : nat, n <= max m n. + +Hint Resolve max_correct_l max_correct_r : arith. + +Theorem foo : ∀ p p' p'' : nat, p'' < S (max p (max p' p'')). +Proof. + intros. + Timeout 3 eauto with arith. +Qed. -- cgit v1.2.3 From 2b47c0d1b492424c39477f9d4ec262e4d093be92 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 20 Nov 2015 20:17:35 +0100 Subject: Univs: fix type_of_global_in_context not returning instantiated universe contexts. --- library/global.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/global.ml b/library/global.ml index 6002382c1f..4cffd6b7e3 100644 --- a/library/global.ml +++ b/library/global.ml @@ -198,13 +198,13 @@ let type_of_global_in_context env r = | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in let univs = - if mib.mind_polymorphic then mib.mind_universes + if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in let univs = - if mib.mind_polymorphic then mib.mind_universes + if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in let inst = Univ.UContext.instance univs in -- cgit v1.2.3 From 8d93301045c45ec48c85ecae2dfb3609e5e4695f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 20 Nov 2015 20:18:11 +0100 Subject: Univs: generation of induction schemes should not generated useless instances for each of the inductive in the same block but reuse the original universe context shared by all of them. Also do not force schemes to become universe polymorphic. --- toplevel/indschemes.ml | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index f16e6e3f3f..00197bd668 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -128,7 +128,7 @@ let define id internal ctx c t = { const_entry_body = c; const_entry_secctx = None; const_entry_type = t; - const_entry_polymorphic = true; + const_entry_polymorphic = Flags.is_universe_polymorphism (); const_entry_universes = snd (Evd.universe_context ctx); const_entry_opaque = false; const_entry_inline_code = false; @@ -360,12 +360,21 @@ requested let do_mutual_induction_scheme lnamedepindsort = let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort and env0 = Global.env() in - let sigma, lrecspec = + let sigma, lrecspec, _ = List.fold_right - (fun (_,dep,ind,sort) (evd, l) -> - let evd, indu = Evd.fresh_inductive_instance env0 evd ind in - (evd, (indu,dep,interp_elimination_sort sort) :: l)) - lnamedepindsort (Evd.from_env env0,[]) + (fun (_,dep,ind,sort) (evd, l, inst) -> + let evd, indu, inst = + match inst with + | None -> + let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in + let ctxs = Univ.ContextSet.of_context ctx in + let evd = Evd.from_ctx (Evd.evar_universe_context_of ctxs) in + let u = Univ.UContext.instance ctx in + evd, (ind,u), Some u + | Some ui -> evd, (ind, ui), inst + in + (evd, (indu,dep,interp_elimination_sort sort) :: l, inst)) + lnamedepindsort (Evd.from_env env0,[],None) in let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in let declare decl fi lrecref = -- cgit v1.2.3 From e583a79b5a0298fd08f34305cc876d5117913e95 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 21 Nov 2015 00:23:12 +0100 Subject: Fixing kernel bug in typing match with let-ins in the arity. Was exploitable in 8.3, 8.4 and 8.5beta1. A priori not exploitable in 8.5beta2 and 8.5beta3 from a Coq file because typing done while compiling "match" would serve as a protection. However exploitable by calling the kernel directly, e.g. from a plugin (but a plugin can anyway do what it wants by bypassing kernel type abstraction). Fixing similar error in pretyping. --- kernel/reduction.ml | 2 +- pretyping/reductionops.ml | 2 +- test-suite/success/Case22.v | 24 ++++++++++++++++++++++++ 3 files changed, 26 insertions(+), 2 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 892557ac6c..939eeef5d5 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -136,7 +136,7 @@ let betazeta_appvect n c v = if Int.equal n 0 then applist (substl env t, stack) else match kind_of_term t, stack with Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack | _ -> anomaly (Pp.str "Not enough lambda/let's") in stacklam n [] c (Array.to_list v) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 156c9a2772..bdd9ed81cf 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1651,7 +1651,7 @@ let betazetaevar_applist sigma n c l = if Int.equal n 0 then applist (substl env t, stack) else match kind_of_term t, stack with | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack | Evar ev, _ -> (match safe_evar_value sigma ev with | Some body -> stacklam n env body stack diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index ce9050d421..8c8f02eccf 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -17,3 +17,27 @@ Definition foo (x : I') : bool := match x with C' => true end. + +(* Bug found in november 2015: was wrongly failing in 8.5beta2 and 8.5beta3 *) + +Inductive I2 (A:Type) : let B:=A in forall C, let D:=(C*B)%type in Type := + E2 : I2 A nat. + +Check fun x:I2 nat nat => match x in I2 _ X Y Z return X*Y*Z with + E2 _ => (0,0,(0,0)) + end. + +(* This used to succeed in 8.3, 8.4 and 8.5beta1 *) + +Inductive IND : forall X:Type, let Y:=X in Type := + C : IND True. + +Definition F (x:IND True) (A:Type) := + (* This failed in 8.5beta2 though it should have been accepted *) + match x in IND Y Z return Z with + C => I + end. + +Theorem paradox : False. + (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) +Fail Proof (F C False). -- cgit v1.2.3 From af954522789043202d9c300a0bb37cbaf4958d60 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 22 Nov 2015 17:17:49 +0100 Subject: Fixing a bug of adjust_subst_to_rel_context. --- pretyping/termops.ml | 2 +- test-suite/success/Case22.v | 18 +++++++++++++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 5a55d47fd1..ebd9d939aa 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -930,7 +930,7 @@ let adjust_subst_to_rel_context sign l = match sign, l with | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' | (_,Some c,_)::sign', args' -> - aux (substl (List.rev subst) c :: subst) sign' args' + aux (substl subst c :: subst) sign' args' | [], [] -> List.rev subst | _ -> anomaly (Pp.str "Instance and signature do not match") in aux [] (List.rev sign) l diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index 8c8f02eccf..f88051f8f5 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -30,14 +30,26 @@ Check fun x:I2 nat nat => match x in I2 _ X Y Z return X*Y*Z with (* This used to succeed in 8.3, 8.4 and 8.5beta1 *) Inductive IND : forall X:Type, let Y:=X in Type := - C : IND True. + CONSTR : IND True. Definition F (x:IND True) (A:Type) := (* This failed in 8.5beta2 though it should have been accepted *) - match x in IND Y Z return Z with - C => I + match x in IND X Y return Y with + CONSTR => Logic.I end. Theorem paradox : False. (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) Fail Proof (F C False). + +(* Another bug found in November 2015 (a substitution was wrongly + reversed at pretyping level) *) + +Inductive Ind (A:Type) : + let X:=A in forall Y:Type, let Z:=(X*Y)%type in Type := + Constr : Ind A nat. + +Check fun x:Ind bool nat => + match x in Ind _ X Y Z return Z with + | Constr _ => (true,0) + end. -- cgit v1.2.3 From c4e2cf027b3fade4f9c2806e6061e1294a99e540 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 22 Nov 2015 21:17:59 +0100 Subject: Fixing a vm_compute bug in the presence of let-ins among the parameters of an inductive type. --- pretyping/vnorm.ml | 9 +++++---- test-suite/success/Case22.v | 8 ++++++++ 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c4c85a62ed..be772a6677 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -59,11 +59,12 @@ let type_constructor mind mib u typ params = let s = ind_subst mind mib u in let ctyp = substl s typ in let ctyp = subst_instance_constr u ctyp in - let nparams = Array.length params in - if Int.equal nparams 0 then ctyp + let ndecls = Context.rel_context_length mib.mind_params_ctxt in + if Int.equal ndecls 0 then ctyp else - let _,ctyp = decompose_prod_n nparams ctyp in - substl (Array.rev_to_list params) ctyp + let _,ctyp = decompose_prod_n_assum ndecls ctyp in + substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) + ctyp diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index f88051f8f5..3c696502cd 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -53,3 +53,11 @@ Check fun x:Ind bool nat => match x in Ind _ X Y Z return Z with | Constr _ => (true,0) end. + +(* A vm_compute bug (the type of constructors was not supposed to + contain local definitions before proper parameters) *) + +Inductive Ind2 (b:=1) (c:nat) : Type := + Constr2 : Ind2 c. + +Eval vm_compute in Constr2 2. -- cgit v1.2.3 From 6b3112d3b6e401a4c177447dd3651820897f711f Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 23 Nov 2015 08:14:27 +0100 Subject: Fix output of universe arcs. (Fix bug #4422) --- kernel/univ.ml | 4 ++-- toplevel/vernacentries.ml | 13 +++++-------- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/kernel/univ.ml b/kernel/univ.ml index 6c2316988e..dc0a4b43c0 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -2030,8 +2030,8 @@ let dump_universes output g = let dump_arc u = function | Canonical {univ=u; lt=lt; le=le} -> let u_str = Level.to_string u in - List.iter (fun v -> output Lt (Level.to_string v) u_str) lt; - List.iter (fun v -> output Le (Level.to_string v) u_str) le + List.iter (fun v -> output Lt u_str (Level.to_string v)) lt; + List.iter (fun v -> output Le u_str (Level.to_string v)) le | Equiv v -> output Eq (Level.to_string u) (Level.to_string v) in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index b6a1a53fa8..177c3fb0ab 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -355,11 +355,6 @@ let dump_universes_gen g s = close (); iraise reraise -let dump_universes sorted s = - let g = Global.universes () in - let g = if sorted then Univ.sort_universes g else g in - dump_universes_gen g s - (*********************) (* "Locate" commands *) @@ -1623,15 +1618,17 @@ let vernac_print = function | PrintCoercionPaths (cls,clt) -> msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ()) - | PrintUniverses (b, None) -> + | PrintUniverses (b, dst) -> let univ = Global.universes () in let univ = if b then Univ.sort_universes univ else univ in let pr_remaining = if Global.is_joined_environment () then mt () else str"There may remain asynchronous universe constraints" in - msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) - | PrintUniverses (b, Some s) -> dump_universes b s + begin match dst with + | None -> msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) + | Some s -> dump_universes_gen univ s + end | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s) -- cgit v1.2.3 From 6474fa6c4976c28cd050071df22dd9d87f3cc7b8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 23 Nov 2015 10:10:31 +0100 Subject: Removing a use of old refine in Tactics. --- tactics/tactics.ml | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5cd17fad4c..f99ab4bbf9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3249,19 +3249,19 @@ let decompose_indapp f args = | _ -> f, args let mk_term_eq env sigma ty t ty' t' = + let sigma = Sigma.to_evar_map sigma in if Reductionops.is_conv env sigma ty ty' then mkEq ty t t', mkRefl ty' t' else mkHEq ty t ty' t', mkHRefl ty' t' -let make_abstract_generalize gl id concl dep ctx body c eqs args refls = - let meta = Evarutil.new_meta() in +let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = + Proofview.Refine.refine { run = begin fun sigma -> let eqslen = List.length eqs in - let term, typ = mkVar id, Tacmach.pf_get_hyp_typ gl id in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let abshypeq, abshypt = if dep then - let eq, refl = mk_term_eq (push_rel_context ctx (Tacmach.pf_env gl)) (Tacmach.project gl) (lift 1 c) (mkRel 1) typ term in + let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in @@ -3273,7 +3273,7 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) - let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in + let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instanciated hyp. *) @@ -3281,7 +3281,8 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) - mkApp (appeqs, abshypt) + Sigma (mkApp (appeqs, abshypt), sigma, p) + end } let hyps_of_vars env sign nogen hyps = if Id.Set.is_empty hyps then [] @@ -3398,8 +3399,10 @@ let abstract_args gl generalize_vars dep id defined f args = if defined then Some c', Retyping.get_type_of ctxenv !sigma c' else None, c' in - let term = make_abstract_generalize {gl with sigma = !sigma} id concl dep ctx body c' eqs args refls in - Some (term, !sigma, dep, succ (List.length ctx), vars) + let typ = Tacmach.pf_get_hyp_typ gl id in + let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in + let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in + Some (tac, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = @@ -3421,17 +3424,15 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in match newc with | None -> Proofview.tclUNIT () - | Some (newc, sigma, dep, n, vars) -> + | Some (tac, dep, n, vars) -> let tac = if dep then - Tacticals.New.tclTHENLIST - [Proofview.Unsafe.tclEVARS sigma; - Proofview.V82.tactic (refine newc); + Tacticals.New.tclTHENLIST [ + tac; rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))] - else Tacticals.New.tclTHENLIST - [Proofview.Unsafe.tclEVARS sigma; - Proofview.V82.tactic (refine newc); + else Tacticals.New.tclTHENLIST [ + tac; Proofview.V82.tactic (clear [id]); Tacticals.New.tclDO n intro] in -- cgit v1.2.3 From 3e4a4fbb1e0f00aff08664321d916167166dbab3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 23 Nov 2015 15:57:54 +0100 Subject: Fix generation of equality schemes on polymorphic equality types. --- tactics/eqschemes.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index b2603315d5..d08c7615a9 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -176,7 +176,7 @@ let build_sym_scheme env ind = name_context env ((Name varH,None,applied_ind)::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in let c = - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name @@ -395,7 +395,7 @@ let build_l2r_rew_scheme dep env ind kind = applied_sym_C 3, [|mkVar varHC|]) in let c = - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varP (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s) @@ -485,7 +485,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in let c = - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varH applied_ind (mkCase (ci, @@ -782,5 +782,6 @@ let build_congr env (eq,refl,ctx) ind = let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun _ ind -> - (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Safe_typing.empty_private_constants) + (* May fail if equality is not defined *) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, + Safe_typing.empty_private_constants) -- cgit v1.2.3 From 1467c22548453cd07ceba0029e37c8bbdfd039ea Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 23 Nov 2015 17:51:16 +0100 Subject: Fixing an old typo in Retyping, found by Matej. --- pretyping/retyping.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index fb55265526..a169a4577e 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -158,8 +158,7 @@ let retype ?(polyprop=true) sigma = and sort_family_of env t = match kind_of_term t with | Cast (c,_, s) when isSort s -> family_of_sort (destSort s) - | Sort (Prop c) -> InType - | Sort (Type u) -> InType + | Sort s -> family_of_sort s | Prod (name,t,c2) -> let s2 = sort_family_of (push_rel (name,None,t) env) c2 in if not (is_impredicative_set env) && -- cgit v1.2.3 From 2d32a2c5606286c85fd35c7ace167b4d4e108ced Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 24 Nov 2015 15:48:28 +0100 Subject: Univs: carry on universe substitution when defining obligations of non-polymorphic definitions, original universes might be substituted later on due to constraints. --- toplevel/obligations.ml | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 311c61f894..e091d825cd 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -823,7 +823,9 @@ let obligation_hook prg obl num auto ctx' _ gr = if not (pi2 prg.prg_kind) (* Not polymorphic *) then (* The universe context was declared globally, we continue from the new global environment. *) - Evd.evar_universe_context (Evd.from_env (Global.env ())) + let evd = Evd.from_env (Global.env ()) in + let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in + Evd.evar_universe_context ctx' else ctx' in let prg = { prg with prg_ctx = ctx' } in @@ -899,8 +901,10 @@ and solve_obligation_by_tac prg obls i tac = let def, obl' = declare_obligation !prg obl t ty uctx in obls.(i) <- obl'; if def && not (pi2 !prg.prg_kind) then ( - (* Declare the term constraints with the first obligation only *) - let ctx' = Evd.evar_universe_context (Evd.from_env (Global.env ())) in + (* Declare the term constraints with the first obligation only *) + let evd = Evd.from_env (Global.env ()) in + let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in + let ctx' = Evd.evar_universe_context evd in prg := {!prg with prg_ctx = ctx'}); true else false -- cgit v1.2.3 From 901a9b29adf507370732aeafbfea6718c1842f1b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 25 Nov 2015 12:09:27 +0100 Subject: Checking lablgtk version in configure. Fix bug #4423. --- configure.ml | 41 ++++++++++++++++++++++++++++++++--------- 1 file changed, 32 insertions(+), 9 deletions(-) diff --git a/configure.ml b/configure.ml index 51033c3d01..500796f5d1 100644 --- a/configure.ml +++ b/configure.ml @@ -719,10 +719,18 @@ let operating_system, osdeplibs = (** * lablgtk2 and CoqIDE *) +type source = Manual | OCamlFind | Stdlib + +let get_source = function +| Manual -> "manually provided" +| OCamlFind -> "via ocamlfind" +| Stdlib -> "in OCaml library" + (** Is some location a suitable LablGtk2 installation ? *) -let check_lablgtkdir ?(fatal=false) msg dir = +let check_lablgtkdir ?(fatal=false) src dir = let yell msg = if fatal then die msg else (printf "%s\n" msg; false) in + let msg = get_source src in if not (dir_exists dir) then yell (sprintf "No such directory '%s' (%s)." dir msg) else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then @@ -736,11 +744,11 @@ let check_lablgtkdir ?(fatal=false) msg dir = let get_lablgtkdir () = match !Prefs.lablgtkdir with | Some dir -> - let msg = "manually provided" in + let msg = Manual in if check_lablgtkdir ~fatal:true msg dir then dir, msg - else "", "" + else "", msg | None -> - let msg = "via ocamlfind" in + let msg = OCamlFind in let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in if d1 <> "" && check_lablgtkdir msg d1 then d1, msg else @@ -748,10 +756,25 @@ let get_lablgtkdir () = let d2,_ = tryrun "ocamlfind" ["query";"lablgtk2"] in if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg else - let msg = "in OCaml library" in + let msg = Stdlib in let d3 = camllib^"/lablgtk2" in if check_lablgtkdir msg d3 then d3, msg - else "", "" + else "", msg + +(** Detect and/or verify the Lablgtk2 version *) + +let check_lablgtk_version src dir = match src with +| Manual | Stdlib -> + let test = sprintf "grep -q -w convert_with_fallback %S/glib.mli" dir in + let ans = Sys.command test = 0 in + printf "Warning: could not check the version of lablgtk2.\n"; + (ans, "an unknown version") +| OCamlFind -> + let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in + try + let vi = List.map s2i (numeric_prefix_list v) in + ([2; 16] <= vi, v) + with _ -> (false, v) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -775,9 +798,9 @@ let check_coqide () = if !Prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in if dir = "" then set_ide No "LablGtk2 not found"; - let found = sprintf "LablGtk2 found (%s)" via in - let test = sprintf "grep -q -w convert_with_fallback %S/glib.mli" dir in - if Sys.command test <> 0 then set_ide No (found^" but too old"); + let found = sprintf "LablGtk2 found (%s)" (get_source via) in + let (ok, version) = check_lablgtk_version via dir in + if not ok then set_ide No (found^", but too old (required >= 2.16, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; if !Prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); -- cgit v1.2.3 From 6f9cc3aca5bb0e5684268a7283796a9272ed5f9d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 25 Nov 2015 15:58:03 +0100 Subject: Advertising that CoqIDE requires lablgtk >= 2.16 --- INSTALL.ide | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/INSTALL.ide b/INSTALL.ide index 6e41b2d051..b651e77db4 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -39,7 +39,7 @@ COMPILATION REQUIREMENTS install GTK+ 2.x, should you need to force it for one reason or another.) - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2. - You need at least version 2.14.2. + You need at least version 2.16. Your distribution may contain precompiled packages. For example, for Debian, run -- cgit v1.2.3 From e92aeed3abcf7d42045deb9fb3a450d3527eadc9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 25 Nov 2015 17:33:24 +0100 Subject: Reverting 1467c225 (Fixing an old typo in Retyping, found by Matej). This was not a typo (was correctly taking the family type of the type). --- pretyping/retyping.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index a169a4577e..fb55265526 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -158,7 +158,8 @@ let retype ?(polyprop=true) sigma = and sort_family_of env t = match kind_of_term t with | Cast (c,_, s) when isSort s -> family_of_sort (destSort s) - | Sort s -> family_of_sort s + | Sort (Prop c) -> InType + | Sort (Type u) -> InType | Prod (name,t,c2) -> let s2 = sort_family_of (push_rel (name,None,t) env) c2 in if not (is_impredicative_set env) && -- cgit v1.2.3 From ef8718a7fd3bcd960d954093d8c636525e6cc492 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 25 Nov 2015 17:56:41 +0100 Subject: Heuristic to check the version of lablgtk2 in configure.ml. When not using ocamlfind, we use a grep-based heuristic to check that lablgtk2 is recent enough. This is an extension of an already-used heuristic. --- configure.ml | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/configure.ml b/configure.ml index 500796f5d1..3a55fb5707 100644 --- a/configure.ml +++ b/configure.ml @@ -765,9 +765,18 @@ let get_lablgtkdir () = let check_lablgtk_version src dir = match src with | Manual | Stdlib -> - let test = sprintf "grep -q -w convert_with_fallback %S/glib.mli" dir in - let ans = Sys.command test = 0 in - printf "Warning: could not check the version of lablgtk2.\n"; + let test accu f = + if accu then + let test = sprintf "grep -q -w %s %S/glib.mli" f dir in + Sys.command test = 0 + else false + in + let heuristics = [ + "convert_with_fallback"; + "wrap_poll_func"; (** Introduced in lablgtk 2.16 *) + ] in + let ans = List.fold_left test true heuristics in + if ans then printf "Warning: could not check the version of lablgtk2.\n"; (ans, "an unknown version") | OCamlFind -> let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in @@ -798,8 +807,8 @@ let check_coqide () = if !Prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in if dir = "" then set_ide No "LablGtk2 not found"; - let found = sprintf "LablGtk2 found (%s)" (get_source via) in let (ok, version) = check_lablgtk_version via dir in + let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in if not ok then set_ide No (found^", but too old (required >= 2.16, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; -- cgit v1.2.3 From 3940441dffdfc3a8f968760c249f6a2e8a1e0912 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 22 Sep 2015 09:05:44 +0200 Subject: Generalizing the patch to bug #2554 on fixing path looking with correct case on MacOS X whose file system is case-insensitive but case-preserving (HFS+ configured in case-insensitive mode). Generalized it to any case-preserving case-insensitive file system, which makes it applicable to Windows with NTFS used in case-insensitive mode but also to Linux when mounting a case-insensitive file system. Removed the blow-up of the patch, improved the core of the patch by checking whether the case is correct only for the suffix part of the file to be found (not for the part which corresponds to the path in which where to look), and finally used a cache so that the effect of the patch is not observable. Note that the cache is implemented in a way not synchronous with backtracking what implies e.g. that a file compiled in the middle of an interactive session would not be found until Coq is restarted, even by backtracking before the corresponding Require. For history see commits b712864e9cf499f1298c1aca1ad8a8b17e145079, 4b5af0d6e9ec1343a2c3ff9f856a019fa93c3606 69941d4e195650bf59285b897c14d6287defea0f e7043eec55085f4101bfb126d8829de6f6086c5a. as well as https://coq.inria.fr/bugs/show_bug.cgi?id=2554 discussion on coq-club "8.5 and MathClasses" (May 2015) discussion on coqdev "Coq awfully slow on MacOS X" (Sep 2015) --- lib/envars.ml | 5 ++++- lib/system.ml | 50 +++++++++++++++++++++++++++++++++++++++++++++++++- lib/system.mli | 2 ++ 3 files changed, 55 insertions(+), 2 deletions(-) diff --git a/lib/envars.ml b/lib/envars.ml index b0eed8386b..2b8af917fa 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -39,6 +39,8 @@ let path_to_list p = let user_path () = path_to_list (Sys.getenv "PATH") (* may raise Not_found *) +(* Finding a name in path using the equality provided by the file system *) +(* whether it is case-sensitive or case-insensitive *) let rec which l f = match l with | [] -> @@ -99,7 +101,8 @@ let _ = (** [check_file_else ~dir ~file oth] checks if [file] exists in the installation directory [dir] given relatively to [coqroot]. If this Coq is only locally built, then [file] must be in [coqroot]. - If the check fails, then [oth ()] is evaluated. *) + If the check fails, then [oth ()] is evaluated. + Using file system equality seems well enough for this heuristic *) let check_file_else ~dir ~file oth = let path = if Coq_config.local then coqroot else coqroot / dir in if Sys.file_exists (path / file) then path else oth () diff --git a/lib/system.ml b/lib/system.ml index ddc56956c5..02d5e963ff 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -53,6 +53,49 @@ let all_subdirs ~unix_path:root = if exists_dir root then traverse root []; List.rev !l +(* Caching directory contents for efficient syntactic equality of file + names even on case-preserving but case-insensitive file systems *) + +module StrMod = struct + type t = string + let compare = compare +end + +module StrMap = Map.Make(StrMod) +module StrSet = Set.Make(StrMod) + +let dirmap = ref StrMap.empty + +let make_dir_table dir = + let b = ref StrSet.empty in + let a = Unix.opendir dir in + (try + while true do + let s = Unix.readdir a in + if s.[0] != '.' then b := StrSet.add s !b + done + with + | End_of_file -> ()); + Unix.closedir a; !b + +let exists_in_dir_respecting_case dir bf = + let contents = + try StrMap.find dir !dirmap with Not_found -> + let contents = make_dir_table dir in + dirmap := StrMap.add dir contents !dirmap; + contents in + StrSet.mem bf contents + +let file_exists_respecting_case path f = + (* This function ensures that a file with expected lowercase/uppercase + is the correct one, even on case-insensitive file systems *) + let rec aux f = + let bf = Filename.basename f in + let df = Filename.dirname f in + (String.equal df "." || aux df) + && exists_in_dir_respecting_case (Filename.concat path df) bf + in Sys.file_exists (Filename.concat path f) && aux f + let rec search paths test = match paths with | [] -> [] @@ -77,7 +120,7 @@ let where_in_path ?(warn=true) path filename = in check_and_warn (search path (fun lpe -> let f = Filename.concat lpe filename in - if Sys.file_exists f then [lpe,f] else [])) + if file_exists_respecting_case lpe filename then [lpe,f] else [])) let where_in_path_rex path rex = search path (fun lpe -> @@ -93,6 +136,8 @@ let where_in_path_rex path rex = let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then + (* the name is considered to be a physical name and we use the file + system rules (e.g. possible case-insensitivity) to find it *) if Sys.file_exists filename then let root = Filename.dirname filename in root, filename @@ -100,6 +145,9 @@ let find_file_in_path ?(warn=true) paths filename = errorlabstrm "System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else + (* the name is considered to be the transcription as a relative + physical name of a logical name, so we deal with it as a name + to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> errorlabstrm "System.find_file_in_path" diff --git a/lib/system.mli b/lib/system.mli index 247d528b97..c2d64fe0d0 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -29,6 +29,8 @@ val exists_dir : string -> bool val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string +val file_exists_respecting_case : string -> string -> bool + (** {6 I/O functions } *) (** Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] -- cgit v1.2.3 From b1a5fe3686ecd5b03e5c7c2efd95716a8e5270ea Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 4 Nov 2015 22:22:17 +0100 Subject: Fix for case-insensitive path looking continued (#2554): Adding a second chance to dynamically regenerate the file system cache when a file is not found (suggested by Guillaume M.). --- lib/system.ml | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index 02d5e963ff..2e35a98f7f 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -79,12 +79,20 @@ let make_dir_table dir = Unix.closedir a; !b let exists_in_dir_respecting_case dir bf = - let contents = - try StrMap.find dir !dirmap with Not_found -> + let contents, cached = + try StrMap.find dir !dirmap, true with Not_found -> let contents = make_dir_table dir in dirmap := StrMap.add dir contents !dirmap; - contents in - StrSet.mem bf contents + contents, false in + StrSet.mem bf contents || + if cached then begin + (* rescan, there is a new file we don't know about *) + let contents = make_dir_table dir in + dirmap := StrMap.add dir contents !dirmap; + StrSet.mem bf contents + end + else + false let file_exists_respecting_case path f = (* This function ensures that a file with expected lowercase/uppercase -- cgit v1.2.3 From b58e8aa6525d45473f88fbea71bab88a2b46c825 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 25 Nov 2015 20:44:08 +0100 Subject: More invariants in UState. --- engine/uState.ml | 22 ++++++++-------------- library/universes.ml | 4 ++-- 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/engine/uState.ml b/engine/uState.ml index a00d9ccd14..c1aa75c091 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -115,12 +115,14 @@ let of_binders b = in { ctx with uctx_names = names } let instantiate_variable l b v = - v := Univ.LMap.add l (Some b) !v + try v := Univ.LMap.update l (Some b) !v + with Not_found -> assert false exception UniversesDiffer -let process_universe_constraints univs vars alg cstrs = - let vars = ref vars in +let process_universe_constraints ctx cstrs = + let univs = ctx.uctx_universes in + let vars = ref ctx.uctx_univ_variables in let normalize = Universes.normalize_universe_opt_subst vars in let rec unify_universes fo l d r local = let l = normalize l and r = normalize r in @@ -129,7 +131,7 @@ let process_universe_constraints univs vars alg cstrs = let varinfo x = match Univ.Universe.level x with | None -> Inl x - | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) + | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l ctx.uctx_univ_algebraic) in if d == Universes.ULe then if UGraph.check_leq univs l r then @@ -210,11 +212,7 @@ let add_constraints ctx cstrs = in Universes.Constraints.add cstr' acc) cstrs Universes.Constraints.empty in - let vars, local' = - process_universe_constraints ctx.uctx_universes - ctx.uctx_univ_variables ctx.uctx_univ_algebraic - cstrs' - in + let vars, local' = process_universe_constraints ctx cstrs' in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } @@ -224,11 +222,7 @@ let add_constraints ctx cstrs = let add_universe_constraints ctx cstrs = let univs, local = ctx.uctx_local in - let vars, local' = - process_universe_constraints ctx.uctx_universes - ctx.uctx_univ_variables ctx.uctx_univ_algebraic - cstrs - in + let vars, local' = process_universe_constraints ctx cstrs in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } diff --git a/library/universes.ml b/library/universes.ml index 504a682fc2..225e658425 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -650,14 +650,14 @@ let normalize_univ_variable_opt_subst ectx = in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - ectx := Univ.LMap.add l (Some b) !ectx; b + try ectx := Univ.LMap.add l (Some b) !ectx; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_univ_variable_subst subst = let find l = Univ.LMap.find l !subst in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - subst := Univ.LMap.add l b !subst; b in + try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_universe_opt_subst subst = -- cgit v1.2.3 From 103ec7205d9038f1f3821f9287e3bb0907a1e3ec Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 19 Nov 2015 13:36:31 +0100 Subject: More efficient implementation of equality-up-to-universes in Universes. Instead of accumulating constraints which are not present in the original graph, we parametrize the equality function by a function actually merging those constraints in the current graph. This prevents doing the work twice. --- engine/evd.ml | 12 ++++++----- library/universes.ml | 53 +++++++++++++++++++++-------------------------- library/universes.mli | 9 +++++--- pretyping/evarutil.ml | 13 ++++++------ pretyping/reductionops.ml | 19 ++++++++++------- 5 files changed, 55 insertions(+), 51 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index 069fcbfa6e..00a869fda8 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -962,11 +962,13 @@ let test_conversion env d pb t u = exception UniversesDiffer = UState.UniversesDiffer let eq_constr_univs evd t u = - let b, c = Universes.eq_constr_univs_infer (UState.ugraph evd.universes) t u in - if b then - try let evd' = add_universe_constraints evd c in evd', b - with Univ.UniverseInconsistency _ | UniversesDiffer -> evd, false - else evd, b + let fold cstr sigma = + try Some (add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | UniversesDiffer -> None + in + match Universes.eq_constr_univs_infer (UState.ugraph evd.universes) fold t u evd with + | None -> evd, false + | Some evd -> evd, true let e_eq_constr_univs evdref t u = let evd, b = eq_constr_univs !evdref t u in diff --git a/library/universes.ml b/library/universes.ml index 225e658425..a157a747ca 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -102,6 +102,7 @@ module Constraints = struct end type universe_constraints = Constraints.t +type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option type 'a universe_constrained = 'a * universe_constraints type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints @@ -141,76 +142,70 @@ let to_constraints g s = "to_constraints: non-trivial algebraic constraint between universes") in Constraints.fold tr s Constraint.empty -let eq_constr_univs_infer univs m n = - if m == n then true, Constraints.empty +let eq_constr_univs_infer univs fold m n accu = + if m == n then Some accu else - let cstrs = ref Constraints.empty in + let cstrs = ref accu in let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if UGraph.check_eq univs u1 u2 then true - else - (cstrs := Constraints.add (u1, UEq, u2) !cstrs; - true) + match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in - res, !cstrs + if res then Some !cstrs else None (** Variant of [eq_constr_univs_infer] taking kind-of-term functions, to expose subterms of [m] and [n], arguments. *) -let eq_constr_univs_infer_with kind1 kind2 univs m n = +let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = (* spiwack: duplicates the code of [eq_constr_univs_infer] because I haven't find a way to factor the code without destroying pointer-equality optimisations in [eq_constr_univs_infer]. Pointer equality is not sufficient to ensure equality up to [kind1,kind2], because [kind1] and [kind2] may be different, typically evaluating [m] and [n] in different evar maps. *) - let cstrs = ref Constraints.empty in + let cstrs = ref accu in let eq_universes strict = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if UGraph.check_eq univs u1 u2 then true - else - (cstrs := Constraints.add (u1, UEq, u2) !cstrs; - true) + match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true in let rec eq_constr' m n = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in - res, !cstrs + if res then Some !cstrs else None -let leq_constr_univs_infer univs m n = - if m == n then true, Constraints.empty +let leq_constr_univs_infer univs fold m n accu = + if m == n then Some accu else - let cstrs = ref Constraints.empty in + let cstrs = ref accu in let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if UGraph.check_eq univs u1 u2 then true - else (cstrs := Constraints.add (u1, UEq, u2) !cstrs; - true) + match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true in let leq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if UGraph.check_leq univs u1 u2 then - ((if Univ.is_small_univ u1 then - cstrs := Constraints.add (u1, ULe, u2) !cstrs); - true) - else - (cstrs := Constraints.add (u1, ULe, u2) !cstrs; - true) + match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n @@ -220,7 +215,7 @@ let leq_constr_univs_infer univs m n = eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in - res, !cstrs + if res then Some !cstrs else None let eq_constr_universes m n = if m == n then true, Constraints.empty diff --git a/library/universes.mli b/library/universes.mli index 285580be2d..7b17b88987 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -63,6 +63,7 @@ module Constraints : sig end type universe_constraints = Constraints.t +type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option type 'a universe_constrained = 'a * universe_constraints type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints @@ -75,7 +76,8 @@ val to_constraints : UGraph.t -> universe_constraints -> constraints (** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) -val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained +val eq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> + constr -> constr -> 'a -> 'a option (** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of {!eq_constr_univs_infer} taking kind-of-term functions, to expose @@ -83,12 +85,13 @@ val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constr val eq_constr_univs_infer_with : (constr -> (constr,types) kind_of_term) -> (constr -> (constr,types) kind_of_term) -> - UGraph.t -> constr -> constr -> bool universe_constrained + UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option (** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) -val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained +val leq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> + constr -> constr -> 'a -> 'a option (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 508b9e8027..3c3afac54e 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -860,13 +860,14 @@ let kind_of_term_upto sigma t = let eq_constr_univs_test sigma1 sigma2 t u = (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) let open Evd in - let b, c = + let fold cstr sigma = + try Some (add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | UniversesDiffer -> None + in + let ans = Universes.eq_constr_univs_infer_with (fun t -> kind_of_term_upto sigma1 t) (fun u -> kind_of_term_upto sigma2 u) - (universes sigma2) t u + (universes sigma2) fold t u sigma2 in - if b then - try let _ = add_universe_constraints sigma2 c in true - with Univ.UniverseInconsistency _ | UniversesDiffer -> false - else false + match ans with None -> false | Some _ -> true diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index bdd9ed81cf..d5a93230f3 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1299,18 +1299,21 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = - try + try + let fold cstr sigma = + try Some (Evd.add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None + in let b, sigma = - let b, cstrs = + let ans = if pb == Reduction.CUMUL then - Universes.leq_constr_univs_infer (Evd.universes sigma) x y + Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma else - Universes.eq_constr_univs_infer (Evd.universes sigma) x y + Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma in - if b then - try true, Evd.add_universe_constraints sigma cstrs - with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> false, sigma - else false, sigma + match ans with + | None -> false, sigma + | Some sigma -> true, sigma in if b then sigma, true else -- cgit v1.2.3 From 566a24e28924ad4a7dda99891dce3882e6db112c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 26 Nov 2015 16:01:33 +0100 Subject: Adding the Printing Projections options to the index. --- doc/refman/RefMan-ext.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index d21c91201d..b77118e1f9 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -253,6 +253,7 @@ Reset Initial. \Rem An experimental syntax for projections based on a dot notation is available. The command to activate it is +\optindex{Printing Projections} \begin{quote} {\tt Set Printing Projections.} \end{quote} -- cgit v1.2.3 From 11ccb7333c2a82d59736027838acaea2237e2402 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 26 Nov 2015 18:09:53 +0100 Subject: Make the pretty printer resilient to incomplete nametab (progress on #4363). The nametab in which the error message is printed is not the one in which the error message happens. This reveals a weakness in the fix_exn code: the fix_exn function should be pure, while in some cases (like this one) uses the global state (the nametab) to print a term in a pretty way (the shortest non-ambiguous name for constants). This patch makes the externalization phase (used by term printing) resilient to an incomplete nametab, so that printing a term in the wrong nametab does not mask the original error. --- interp/constrextern.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index f57772ecb0..5160f07af0 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -147,8 +147,17 @@ let extern_evar loc n l = CEvar (loc,n,l) For instance, in the debugger the tables of global references may be inaccurate *) +let safe_shortest_qualid_of_global vars r = + try shortest_qualid_of_global vars r + with Not_found -> + match r with + | VarRef v -> make_qualid DirPath.empty v + | ConstRef c -> make_qualid DirPath.empty Names.(Label.to_id (con_label c)) + | IndRef (i,_) | ConstructRef ((i,_),_) -> + make_qualid DirPath.empty Names.(Label.to_id (mind_label i)) + let default_extern_reference loc vars r = - Qualid (loc,shortest_qualid_of_global vars r) + Qualid (loc,safe_shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference -- cgit v1.2.3 From 982460743a54ecfab1d601ba930d61c04972d17a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 26 Nov 2015 19:05:25 +0100 Subject: Fixing the "parsing rules with idents later declared as keywords" problem. The fix was actually elementary. The lexer comes with a function to compare parsed tokens against tokens of the parsing rules. It is enough to have this function considering an ident in a parsing rule to be equal to the corresponding string parsed as a keyword. --- parsing/tok.ml | 1 + test-suite/success/Notations.v | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/parsing/tok.ml b/parsing/tok.ml index efd57968d2..12140f4036 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -21,6 +21,7 @@ type t = | EOI let equal t1 t2 = match t1, t2 with +| IDENT s1, KEYWORD s2 -> CString.equal s1 s2 | KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 | METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2 | PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 2371d32cda..b72a067407 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -101,3 +101,9 @@ Fail Check fun x => match x with S (FORALL x, _) => 0 end. Parameter traverse : (nat -> unit) -> (nat -> unit). Notation traverse_var f l := (traverse (fun l => f l) l). + +(* Check that when an ident become a keyword, it does not break + previous rules relying on the string to be classified as an ident *) + +Notation "'intros' x" := (S x) (at level 0). +Goal True -> True. intros H. exact H. Qed. -- cgit v1.2.3 From 8297baa98147f78263126b1bd6cf41b0456f177d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 27 Nov 2015 17:21:10 +0100 Subject: Fix [Polymorphic Hint Rewrite]. --- tactics/extratactics.ml4 | 2 +- toplevel/vernacentries.ml | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index cab74968d2..9ffcd2dcff 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -264,7 +264,7 @@ TACTIC EXTEND rewrite_star let add_rewrite_hint bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in - let poly = Flags.is_universe_polymorphism () in + let poly = Flags.use_polymorphic_flag () in let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in let ctx = diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 177c3fb0ab..2b23323248 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -2048,7 +2048,7 @@ let check_vernac_supports_polymorphism c p = let enforce_polymorphism = function | None -> Flags.is_universe_polymorphism () - | Some b -> b + | Some b -> Flags.make_polymorphic_flag b; b (** A global default timeout, controled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2149,7 +2149,8 @@ let interp ?(verbosely=true) ?proof (loc,c) = then Flags.verbosely (interp ?proof ~loc locality poly) c else Flags.silently (interp ?proof ~loc locality poly) c; if orig_program_mode || not !Flags.program_mode || isprogcmd then - Flags.program_mode := orig_program_mode + Flags.program_mode := orig_program_mode; + ignore (Flags.use_polymorphic_flag ()) end with | reraise when @@ -2161,6 +2162,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = let e = locate_if_not_already loc e in let () = restore_timeout () in Flags.program_mode := orig_program_mode; + ignore (Flags.use_polymorphic_flag ()); iraise e and aux_list ?locality ?polymorphism isprogcmd l = List.iter (aux false) (List.map snd l) -- cgit v1.2.3 From a0e72610a71e086da392c8563c2eec2e35211afa Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 27 Nov 2015 17:21:35 +0100 Subject: Avoid recording spurious Set <= Top.i constraints which are always valid (when Top.i is global and hence > Set). --- library/universes.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/universes.ml b/library/universes.ml index 6cccb10efb..1b6f7a9d57 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -854,7 +854,7 @@ let normalize_context_set ctx us algs = Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> if d == Le then if Univ.Level.is_small l then - if is_set_minimization () then + if is_set_minimization () && LSet.mem r ctx then (Constraint.add cstr smallles, noneqs) else (smallles, noneqs) else if Level.is_small r then -- cgit v1.2.3 From 4a11dc25938f3f009e23f1e7c5fe01b2558928c3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 27 Nov 2015 20:34:51 +0100 Subject: Univs: entirely disallow instantiation of polymorphic constants with Prop levels. As they are typed assuming all variables are >= Set now, and this was breaking an invariant in typing. Only one instance in the standard library was used in Hurkens, which can be avoided easily. This also avoids displaying unnecessary >= Set constraints everywhere. --- kernel/univ.ml | 6 +- library/declare.ml | 2 +- library/universes.ml | 2 +- pretyping/pretyping.ml | 30 ++++++---- test-suite/bugs/closed/4287.v | 6 +- theories/Classes/CMorphisms.v | 14 +---- theories/Logic/ClassicalFacts.v | 1 - theories/Logic/Hurkens.v | 121 ++++++++++++++++++++++++---------------- 8 files changed, 102 insertions(+), 80 deletions(-) diff --git a/kernel/univ.ml b/kernel/univ.ml index dc0a4b43c0..2b3a2bdb11 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1707,7 +1707,9 @@ struct else if Array.length y = 0 then x else Array.append x y - let of_array a = a + let of_array a = + assert(Array.for_all (fun x -> not (Level.is_prop x)) a); + a let to_array a = a @@ -1715,7 +1717,7 @@ struct let subst_fn fn t = let t' = CArray.smartmap fn t in - if t' == t then t else t' + if t' == t then t else of_array t' let levels x = LSet.of_array x diff --git a/library/declare.ml b/library/declare.ml index 5968fbf38b..994a6557ad 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -431,7 +431,7 @@ let cache_universes (p, l) = Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in - Global.push_context_set false ctx; + Global.push_context_set p ctx; if p then Lib.add_section_context ctx; Universes.set_global_universe_names glob' diff --git a/library/universes.ml b/library/universes.ml index 1b6f7a9d57..a8e9478e13 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -820,7 +820,7 @@ let minimize_univ_variables ctx us algs left right cstrs = let cstrs' = List.fold_left (fun cstrs (d, r) -> if d == Univ.Le then enforce_leq inst (Universe.make r) cstrs - else + else try let lev = Option.get (Universe.level inst) in Constraint.add (lev, d, r) cstrs with Option.IsNone -> failwith "") diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index dd4fcf1981..faba5c7563 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -394,18 +394,22 @@ let pretype_global loc rigid env evd gr us = match us with | None -> evd, None | Some l -> - let _, ctx = Universes.unsafe_constr_of_global gr in - let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in - let len = Array.length arr in - if len != List.length l then - user_err_loc (loc, "pretype", - str "Universe instance should have length " ++ int len) - else - let evd, l' = List.fold_left (fun (evd, univs) l -> + let _, ctx = Universes.unsafe_constr_of_global gr in + let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in + let len = Array.length arr in + if len != List.length l then + user_err_loc (loc, "pretype", + str "Universe instance should have length " ++ int len) + else + let evd, l' = List.fold_left (fun (evd, univs) l -> let evd, l = interp_universe_level_name evd l in (evd, l :: univs)) (evd, []) l - in - evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) + in + if List.exists (fun l -> Univ.Level.is_prop l) l' then + user_err_loc (loc, "pretype", + str "Universe instances cannot contain Prop, polymorphic" ++ + str " universe instances must be greater or equal to Set."); + evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in Evd.fresh_global ~rigid ?names:instance env evd gr @@ -440,13 +444,15 @@ let pretype_sort evdref = function let new_type_evar env evdref loc = let e, s = - evd_comb0 (fun evd -> Evarutil.new_type_evar env evd univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref + evd_comb0 (fun evd -> Evarutil.new_type_evar env evd + univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref in e let get_projection env cst = let cb = lookup_constant cst env in match cb.Declarations.const_proj with - | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> + | Some {Declarations.proj_ind = mind; proj_npars = n; + proj_arg = m; proj_type = ty} -> (cst,mind,n,m,ty) | None -> raise Not_found diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 0623cf5b84..43c9b51295 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -118,8 +118,6 @@ Definition setle (B : Type@{i}) := let foo (A : Type@{j}) := A in foo B. Fail Check @setlt@{j Prop}. -Check @setlt@{Prop j}. -Check @setle@{Prop j}. - Fail Definition foo := @setle@{j Prop}. -Definition foo := @setle@{Prop j}. +Check setlt@{Set i}. +Check setlt@{Set j}. \ No newline at end of file diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index fdedbf672a..b13671cec0 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -269,16 +269,6 @@ Section GenericInstances. Unset Strict Universe Declaration. (** The complement of a crelation conserves its proper elements. *) - Program Definition complement_proper (A : Type@{k}) (RA : crelation A) - `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement@{i j Prop} R) := _. - - Next Obligation. - Proof. - unfold complement. - pose (mR x y X x0 y0 X0). - intuition. - Qed. (** The [flip] too, actually the [flip] instance is a bit more general. *) Program Definition flip_proper @@ -521,8 +511,8 @@ Ltac proper_reflexive := Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. -Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper - : typeclass_instances. +(* Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper *) +(* : typeclass_instances. *) Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index 6f736e45fd..cdc3e04610 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -658,4 +658,3 @@ Proof. exists x; intro; exact Hx. exists x0; exact Hnot. Qed. - diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index ede51f57f9..4e582934af 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -344,53 +344,6 @@ End Paradox. End NoRetractToImpredicativeUniverse. -(** * Prop is not a retract *) - -(** The existence in the pure Calculus of Constructions of a retract - from [Prop] into a small type of [Prop] is inconsistent. This is a - special case of the previous result. *) - -Module NoRetractFromSmallPropositionToProp. - -Section Paradox. - -(** ** Retract of [Prop] in a small type *) - -(** The retract is axiomatized using logical equivalence as the - equality on propositions. *) - -Variable bool : Prop. -Variable p2b : Prop -> bool. -Variable b2p : bool -> Prop. -Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. -Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). - -(** ** Paradox *) - -Theorem paradox : forall B:Prop, B. -Proof. - intros B. - pose proof - (NoRetractToImpredicativeUniverse.paradox@{Type Prop}) as P. - refine (P _ _ _ _ _ _ _ _ _ _);clear P. - + exact bool. - + exact (fun x => forall P:Prop, (x->P)->P). - + cbn. exact (fun _ x P k => k x). - + cbn. intros F P x. - apply P. - intros f. - exact (f x). - + cbn. easy. - + exact b2p. - + exact p2b. - + exact p2p2. - + exact p2p1. -Qed. - -End Paradox. - -End NoRetractFromSmallPropositionToProp. - (** * Modal fragments of [Prop] are not retracts *) (** In presence of a a monadic modality on [Prop], we can define a @@ -534,6 +487,80 @@ End Paradox. End NoRetractToNegativeProp. +(** * Prop is not a retract *) + +(** The existence in the pure Calculus of Constructions of a retract + from [Prop] into a small type of [Prop] is inconsistent. This is a + special case of the previous result. *) + +Module NoRetractFromSmallPropositionToProp. + +(** ** The universe of propositions. *) + +Definition NProp := { P:Prop | P -> P}. +Definition El : NProp -> Prop := @proj1_sig _ _. + +Section MParadox. + +(** ** Retract of [Prop] in a small type, using the identity modality. *) + +Variable bool : NProp. +Variable p2b : NProp -> El bool. +Variable b2p : El bool -> NProp. +Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. +Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). + +(** ** Paradox *) + +Theorem mparadox : forall B:NProp, El B. +Proof. + intros B. + refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _));cycle 1. + + exact (fun P => P). + + cbn. auto. + + cbn. auto. + + cbn. auto. + + exact bool. + + exact p2b. + + exact b2p. + + auto. + + auto. + + exact B. + + exact h. +Qed. + +End MParadox. + +Section Paradox. + +(** ** Retract of [Prop] in a small type *) + +(** The retract is axiomatized using logical equivalence as the + equality on propositions. *) +Variable bool : Prop. +Variable p2b : Prop -> bool. +Variable b2p : bool -> Prop. +Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. +Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). + +(** ** Paradox *) + +Theorem paradox : forall B:Prop, B. +Proof. + intros B. + refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ + (exist _ B (fun x => x))). + + intros p. red. red. exact (p2b (El p)). + + cbn. intros b. red. exists (b2p b). exact (fun x => x). + + cbn. intros [A H]. cbn. apply p2p1. + + cbn. intros [A H]. cbn. apply p2p2. +Qed. + +End Paradox. + +End NoRetractFromSmallPropositionToProp. + + (** * Large universes are no retracts of [Prop]. *) (** The existence in the Calculus of Constructions with universes of a -- cgit v1.2.3 From 90fef3ffd236f2ed5575b0d11a47185185abc75b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 28 Nov 2015 19:41:17 +0100 Subject: Univs: correctly register universe binders for lemmas. --- proofs/pfedit.ml | 10 +++++--- proofs/pfedit.mli | 7 +++++- proofs/proof_global.ml | 28 +++++++++++++++------- proofs/proof_global.mli | 17 +++++++------ stm/lemmas.ml | 63 ++++++++++++++++++++++++++----------------------- stm/lemmas.mli | 15 +++++++----- toplevel/command.ml | 6 +++-- 7 files changed, 88 insertions(+), 58 deletions(-) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 02dbd1fdcb..cbccf00e72 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -20,14 +20,15 @@ let get_current_proof_name = Proof_global.get_current_proof_name let get_all_proof_names = Proof_global.get_all_proof_names type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Proof_global.universe_binders let delete_proof = Proof_global.discard let delete_current_proof = Proof_global.discard_current let delete_all_proofs = Proof_global.discard_all -let start_proof (id : Id.t) str sigma hyps c ?init_tac terminator = +let start_proof (id : Id.t) ?pl str sigma hyps c ?init_tac terminator = let goals = [ (Global.env_of_context hyps , c) ] in - Proof_global.start_proof sigma id str goals terminator; + Proof_global.start_proof sigma id ?pl str goals terminator; let env = Global.env () in ignore (Proof_global.with_current_proof (fun _ p -> match init_tac with @@ -54,6 +55,9 @@ let set_used_variables l = let get_used_variables () = Proof_global.get_used_variables () +let get_universe_binders () = + Proof_global.get_universe_binders () + exception NoSuchGoal let _ = Errors.register_handler begin function | NoSuchGoal -> Errors.error "No such goal." @@ -139,7 +143,7 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let status = by tac in let _,(const,univs,_) = cook_proof () in delete_current_proof (); - const, status, univs + const, status, fst univs with reraise -> let reraise = Errors.push reraise in delete_current_proof (); diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index fc521ea432..d0528c9fdf 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -55,8 +55,10 @@ val delete_all_proofs : unit -> unit type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Id.t Loc.located list + val start_proof : - Id.t -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> + Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -121,6 +123,9 @@ val set_used_variables : Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option +(** {6 Universe binders } *) +val get_universe_binders : unit -> universe_binders option + (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a [UserError] if no diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index c303f486c5..3d60ff217a 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -63,14 +63,14 @@ let _ = (* Extra info on proofs. *) type lemma_possible_guards = int list list -type proof_universes = Evd.evar_universe_context +type proof_universes = Evd.evar_universe_context * Universes.universe_binders option +type universe_binders = Id.t Loc.located list type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; - (* constraints : Univ.constraints; *) } type proof_ending = @@ -89,6 +89,7 @@ type pstate = { proof : Proof.proof; strength : Decl_kinds.goal_kind; mode : proof_mode Ephemeron.key; + universe_binders: universe_binders option; } (* The head of [!pstates] is the actual current proof, the other ones are @@ -226,7 +227,7 @@ let disactivate_proof_mode mode = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints). *) -let start_proof sigma id str goals terminator = +let start_proof sigma id ?pl str goals terminator = let initial_state = { pid = id; terminator = Ephemeron.create terminator; @@ -234,10 +235,11 @@ let start_proof sigma id str goals terminator = endline_tactic = None; section_vars = None; strength = str; - mode = find_proof_mode "No" } in + mode = find_proof_mode "No"; + universe_binders = pl } in push initial_state pstates -let start_dependent_proof id str goals terminator = +let start_dependent_proof id ?pl str goals terminator = let initial_state = { pid = id; terminator = Ephemeron.create terminator; @@ -245,10 +247,12 @@ let start_dependent_proof id str goals terminator = endline_tactic = None; section_vars = None; strength = str; - mode = find_proof_mode "No" } in + mode = find_proof_mode "No"; + universe_binders = pl } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars +let get_universe_binders () = (cur_pstate ()).universe_binders let proof_using_auto_clear = ref true let _ = Goptions.declare_bool_option @@ -296,7 +300,8 @@ let get_open_goals () = List.length shelf let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = - let { pid; section_vars; strength; proof; terminator } = cur_pstate () in + let { pid; section_vars; strength; proof; terminator; universe_binders } = + cur_pstate () in let poly = pi2 strength (* Polymorphic *) in let initial_goals = Proof.initial_goals proof in let initial_euctx = Proof.initial_euctx proof in @@ -362,8 +367,13 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = const_entry_opaque = true; const_entry_universes = univs; const_entry_polymorphic = poly}) - fpl initial_goals in - { id = pid; entries = entries; persistence = strength; universes = universes }, + fpl initial_goals in + let binders = + Option.map (fun names -> fst (Evd.universe_context ~names (Evd.from_ctx universes))) + universe_binders + in + { id = pid; entries = entries; persistence = strength; + universes = (universes, binders) }, fun pr_ending -> Ephemeron.get terminator pr_ending type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index a22545080b..ea7fc7cfa8 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -55,18 +55,18 @@ val compact_the_proof : unit -> unit (i.e. an proof ending command) and registers the appropriate values. *) type lemma_possible_guards = int list list -type proof_universes = Evd.evar_universe_context +type proof_universes = Evd.evar_universe_context * Universes.universe_binders option +type universe_binders = Names.Id.t Loc.located list type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; - (* constraints : Univ.constraints; *) - (** guards : lemma_possible_guards; *) } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * + proof_universes | Proved of Vernacexpr.opacity_flag * (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * proof_object @@ -80,14 +80,15 @@ type closed_proof = proof_object * proof_terminator closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. *) val start_proof : - Evd.evar_map -> Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> + Evd.evar_map -> Names.Id.t -> ?pl:universe_binders -> + Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : - Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope -> - proof_terminator -> unit + Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> + Proofview.telescope -> proof_terminator -> unit (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes @@ -140,6 +141,8 @@ val set_used_variables : Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option +val get_universe_binders : unit -> universe_binders option + (**********************************************************) (* *) (* Proof modes *) diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 6c18326882..5f4e4deb47 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -186,7 +186,7 @@ let look_for_possibly_mutual_statements = function (* Saving a goal *) -let save ?export_seff id const cstrs do_guard (locality,poly,kind) hook = +let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in try let const = adjust_guardness_conditions const do_guard in @@ -205,6 +205,7 @@ let save ?export_seff id const cstrs do_guard (locality,poly,kind) hook = declare_constant ?export_seff id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in definition_message id; + Option.iter (Universes.register_universe_binders r) pl; call_hook (fun exn -> exn) hook l r with e when Errors.noncritical e -> let e = Errors.push e in @@ -219,11 +220,11 @@ let compute_proof_name locality = function locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then user_err_loc (loc,"",pr_id id ++ str " already exists."); - id + id, pl | None -> - next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) + next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None -let save_remaining_recthms (locality,p,kind) norm ctx body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,(_,imps))) = let t_i = norm t_i in match body with | None -> @@ -276,28 +277,28 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named ?export_seff proof = - let id,const,cstrs,do_guard,persistence,hook = proof in - save ?export_seff id const cstrs do_guard persistence hook + let id,const,(cstrs,pl),do_guard,persistence,hook = proof in + save ?export_seff id const cstrs pl do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then error "This command can only be used for unnamed theorem." - let save_anonymous ?export_seff proof save_ident = - let id,const,cstrs,do_guard,persistence,hook = proof in + let id,const,(cstrs,pl),do_guard,persistence,hook = proof in check_anonymity id save_ident; - save ?export_seff save_ident const cstrs do_guard persistence hook + save ?export_seff save_ident const cstrs pl do_guard persistence hook let save_anonymous_with_strength ?export_seff proof kind save_ident = - let id,const,cstrs,do_guard,_,hook = proof in + let id,const,(cstrs,pl),do_guard,_,hook = proof in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) - save ?export_seff save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook + save ?export_seff save_ident const cstrs pl do_guard + (Global, const.const_entry_polymorphic, Proof kind) hook (* Admitted *) -let admit (id,k,e) hook () = +let admit (id,k,e) pl hook () = let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in let () = match k with | Global, _, _ -> () @@ -306,6 +307,7 @@ let admit (id,k,e) hook () = str "declared as an axiom.") in let () = assumption_message id in + Option.iter (Universes.register_universe_binders (ConstRef kn)) pl; call_hook (fun exn -> exn) hook Global (ConstRef kn) (* Starting a goal *) @@ -315,11 +317,10 @@ let set_start_hook = (:=) start_hook let get_proof proof do_guard hook opacity = - let (id,(const,cstrs,persistence)) = + let (id,(const,univs,persistence)) = Pfedit.cook_this_proof proof in - (** FIXME *) - id,{const with const_entry_opaque = opacity},cstrs,do_guard,persistence,hook + id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook let check_exist = List.iter (fun (loc,id) -> @@ -329,16 +330,16 @@ let check_exist = let universe_proof_terminator compute_guard hook = let open Proof_global in function - | Admitted (id,k,pe,ctx) -> - admit (id,k,pe) (hook (Some ctx)) (); + | Admitted (id,k,pe,(ctx,pl)) -> + admit (id,k,pe) pl (hook (Some ctx)) (); Pp.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> let is_opaque, export_seff, exports = match opaque with | Vernacexpr.Transparent -> false, true, [] | Vernacexpr.Opaque None -> true, false, [] | Vernacexpr.Opaque (Some l) -> true, true, l in - let proof = get_proof proof compute_guard - (hook (Some proof.Proof_global.universes)) is_opaque in + let proof = get_proof proof compute_guard + (hook (Some (fst proof.Proof_global.universes))) is_opaque in begin match idopt with | None -> save_named ~export_seff proof | Some ((_,id),None) -> save_anonymous ~export_seff proof id @@ -350,7 +351,7 @@ let universe_proof_terminator compute_guard hook = let standard_proof_terminator compute_guard hook = universe_proof_terminator compute_guard (fun _ -> hook) -let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = standard_proof_terminator compute_guard hook in let sign = match sign with @@ -358,9 +359,9 @@ let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = | None -> initialize_named_context_for_proof () in !start_hook c; - Pfedit.start_proof id kind sigma sign c ?init_tac terminator + Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator -let start_proof_univs id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof_univs id ?pl kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = universe_proof_terminator compute_guard hook in let sign = match sign with @@ -368,11 +369,11 @@ let start_proof_univs id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = | None -> initialize_named_context_for_proof () in !start_hook c; - Pfedit.start_proof id kind sigma sign c ?init_tac terminator + Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun (id,(t,_)) -> (id,t)) thms with + match List.map (fun ((id,_),(t,_)) -> (id,t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -380,7 +381,7 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with + in match List.map2 (fun ((id,_),(t,_)) n -> (id,n,t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false @@ -409,7 +410,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in match thms with | [] -> anomaly (Pp.str "No proof to start") - | (id,(t,(_,imps)))::other_thms -> + | ((id,pl),(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with | None -> Evd.empty_evar_universe_context @@ -428,7 +429,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard let start_proof_com kind thms hook = let env0 = Global.env () in @@ -472,14 +473,13 @@ let save_proof ?proof = function if const_entry_type = None then error "Admitted requires an explicit statement"; let typ = Option.get const_entry_type in - let ctx = Evd.evar_context_universe_context universes in + let ctx = Evd.evar_context_universe_context (fst universes) in Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None), universes) | None -> let id, k, typ = Pfedit.current_proof_statement () in (* This will warn if the proof is complete *) let pproofs, universes = Proof_global.return_proof ~allow_partial:true () in - let ctx = Evd.evar_context_universe_context universes in let sec_vars = match Pfedit.get_used_variables(), pproofs with | Some _ as x, _ -> x @@ -489,7 +489,10 @@ let save_proof ?proof = function let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) | _ -> None in - Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),universes) + let names = Pfedit.get_universe_binders () in + let binders, ctx = Evd.universe_context ?names (Evd.from_ctx universes) in + Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), + (universes, Some binders)) in Proof_global.get_terminator() pe | Vernacexpr.Proved (is_opaque,idopt) -> diff --git a/stm/lemmas.mli b/stm/lemmas.mli index 6556aa2297..376374cb85 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -14,7 +14,6 @@ open Vernacexpr open Pfedit type 'a declaration_hook - val mk_hook : (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook @@ -24,20 +23,24 @@ val call_hook : (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (types -> unit) -> unit -val start_proof : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types -> +val start_proof : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> + ?sign:Environ.named_context_val -> types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> unit declaration_hook -> unit -val start_proof_univs : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types -> +val start_proof_univs : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> + ?sign:Environ.named_context_val -> types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> - (Proof_global.proof_universes option -> unit declaration_hook) -> unit + (Evd.evar_universe_context option -> unit declaration_hook) -> unit val start_proof_com : goal_kind -> Vernacexpr.proof_expr list -> unit declaration_hook -> unit val start_proof_with_initialization : - goal_kind -> Evd.evar_map -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> - (Id.t * (types * (Name.t list * Impargs.manual_explicitation list))) list + goal_kind -> Evd.evar_map -> + (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> + ((Id.t * universe_binders option) * + (types * (Name.t list * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val standard_proof_terminator : diff --git a/toplevel/command.ml b/toplevel/command.ml index 0b709a3fc4..91cfddb547 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -1128,7 +1128,8 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps)))) + fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in @@ -1164,7 +1165,8 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps)))) + fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in -- cgit v1.2.3 From 15aeb84a0deb444af81f4035dbcf791566bafe5f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 28 Nov 2015 19:43:58 +0100 Subject: Closed bugs. --- test-suite/bugs/closed/3807.v | 33 +++++++++++++++++++++++++++++++++ test-suite/bugs/closed/4400.v | 19 +++++++++++++++++++ test-suite/bugs/closed/4433.v | 29 +++++++++++++++++++++++++++++ 3 files changed, 81 insertions(+) create mode 100644 test-suite/bugs/closed/3807.v create mode 100644 test-suite/bugs/closed/4400.v create mode 100644 test-suite/bugs/closed/4433.v diff --git a/test-suite/bugs/closed/3807.v b/test-suite/bugs/closed/3807.v new file mode 100644 index 0000000000..108ebf592b --- /dev/null +++ b/test-suite/bugs/closed/3807.v @@ -0,0 +1,33 @@ +Set Universe Polymorphism. +Set Printing Universes. +Unset Universe Minimization ToSet. + + +Definition foo : Type := nat. +About foo. +(* foo@{Top.1} : Type@{Top.1}*) +(* Top.1 |= *) + +Definition bar : foo -> nat. +Admitted. +About bar. +(* bar@{Top.2} : foo@{Top.2} -> nat *) +(* Top.2 |= *) + +Lemma baz@{i} : foo@{i} -> nat. +Proof. + exact bar. +Defined. + +Definition bar'@{i} : foo@{i} -> nat. + intros f. exact 0. +Admitted. +About bar'. +(* bar'@{i} : foo@{i} -> nat *) +(* i |= *) + +Axiom f@{i} : Type@{i}. +(* +*** [ f@{i} : Type@{i} ] +(* i |= *) +*) \ No newline at end of file diff --git a/test-suite/bugs/closed/4400.v b/test-suite/bugs/closed/4400.v new file mode 100644 index 0000000000..5c23f8404b --- /dev/null +++ b/test-suite/bugs/closed/4400.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-emacs" "-require" "Coq.Compat.Coq84" "-compat" "8.4") -*- *) +Require Import Coq.Lists.List Coq.Logic.JMeq Program.Equality. +Set Printing Universes. +Inductive Foo (I : Type -> Type) (A : Type) : Type := +| foo (B : Type) : A -> I B -> Foo I A. +Definition Family := Type -> Type. +Definition FooToo : Family -> Family := Foo. +Definition optionize (I : Type -> Type) (A : Type) := option (I A). +Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo(optionize I) A := foo (optionize I) A A. +Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. +Definition barRec : Rec (optionize id) := {| rec := bar id |}. +Inductive Empty {T} : T -> Prop := . +Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) +nil)) (b : unit) : + Empty (a, b) -> False. +Proof. + intro e. + dependent induction e. +Qed. diff --git a/test-suite/bugs/closed/4433.v b/test-suite/bugs/closed/4433.v new file mode 100644 index 0000000000..9eeb864689 --- /dev/null +++ b/test-suite/bugs/closed/4433.v @@ -0,0 +1,29 @@ +Require Import Coq.Arith.Arith Coq.Init.Wf. +Axiom proof_admitted : False. +Goal exists x y z : nat, Fix + Wf_nat.lt_wf + (fun _ => nat -> nat) + (fun x' f => match x' as x'0 + return match x'0 with + | 0 => True + | S x'' => x'' < x' + end + -> nat -> nat + with + | 0 => fun _ _ => 0 + | S x'' => f x'' + end + (match x' with + | 0 => I + | S x'' => (Nat.lt_succ_diag_r _) + end)) + z + y + = 0. +Proof. + do 3 (eexists; [ shelve.. | ]). + match goal with |- ?G => let G' := (eval lazy in G) in change G with G' end. + case proof_admitted. + Unshelve. + all:constructor. +Defined. \ No newline at end of file -- cgit v1.2.3 From 8d6e58e16cc53a3198eb4c4afef0a2c39f6a5c56 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 28 Nov 2015 20:02:52 +0100 Subject: Test-suite files for closed bugs --- test-suite/bugs/closed/3735.v | 4 ++++ test-suite/bugs/closed/4284.v | 6 ++++++ 2 files changed, 10 insertions(+) create mode 100644 test-suite/bugs/closed/3735.v create mode 100644 test-suite/bugs/closed/4284.v diff --git a/test-suite/bugs/closed/3735.v b/test-suite/bugs/closed/3735.v new file mode 100644 index 0000000000..a50572ace0 --- /dev/null +++ b/test-suite/bugs/closed/3735.v @@ -0,0 +1,4 @@ +Require Import Coq.Program.Tactics. +Class Foo := { bar : Type }. +Fail Lemma foo : Foo -> bar. (* 'Command has indeed failed.' in both 8.4 and trunk *) +Fail Program Lemma foo : Foo -> bar. \ No newline at end of file diff --git a/test-suite/bugs/closed/4284.v b/test-suite/bugs/closed/4284.v new file mode 100644 index 0000000000..0fff3026ff --- /dev/null +++ b/test-suite/bugs/closed/4284.v @@ -0,0 +1,6 @@ +Set Primitive Projections. +Record total2 { T: Type } ( P: T -> Type ) := tpair { pr1 : T; pr2 : P pr1 }. +Theorem onefiber' {X : Type} (P : X -> Type) (x : X) : True. +Proof. +set (Q1 := total2 (fun f => pr1 P f = x)). +set (f1:=fun q1 : Q1 => pr2 _ (pr1 _ q1)). -- cgit v1.2.3 From 30efd8d3501ff724e6f75acf7c2355a107da1c70 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 30 Nov 2015 12:36:04 +0100 Subject: Test for bug #4149. --- test-suite/bugs/closed/4149.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/4149.v diff --git a/test-suite/bugs/closed/4149.v b/test-suite/bugs/closed/4149.v new file mode 100644 index 0000000000..b81c680cd7 --- /dev/null +++ b/test-suite/bugs/closed/4149.v @@ -0,0 +1,4 @@ +Goal forall A, A -> Type. +Proof. + intros; eauto. +Qed. -- cgit v1.2.3 From d43915ae5ca44ad0f41a8accd9ab908779f382e5 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 30 Nov 2015 16:05:19 +0100 Subject: Simplify coqdep lexer by removing global references. --- tools/coqdep_lexer.mll | 126 ++++++++++++++++++------------------------------- 1 file changed, 47 insertions(+), 79 deletions(-) diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index 291bc55fbe..0696e94662 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -25,13 +25,6 @@ exception Fin_fichier exception Syntax_error of int*int - let module_current_name = ref [] - let module_names = ref [] - let ml_module_name = ref "" - let loadpath = ref "" - - let mllist = ref ([] : string list) - let field_name s = String.sub s 1 (String.length s - 1) let unquote_string s = @@ -46,11 +39,6 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) - - (** This is the prefix that should be pre-prepended to files due to the use - ** of [From], i.e. [From Xxx... Require ...] - **) - let from_pre_ident = ref None } let space = [' ' '\t' '\n' '\r'] @@ -81,9 +69,9 @@ let dot = '.' ( space+ | eof) rule coq_action = parse | "Require" space+ - { require_modifiers lexbuf } + { require_modifiers None lexbuf } | "Local"? "Declare" space+ "ML" space+ "Module" space+ - { mllist := []; modules lexbuf } + { modules [] lexbuf } | "Load" space+ { load_file lexbuf } | "Add" space+ "LoadPath" space+ @@ -109,38 +97,34 @@ and from_rule = parse | space+ { from_rule lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - from_pre_ident := Some (coq_qual_id_tail lexbuf); - module_names := []; - consume_require lexbuf } + { let from = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + consume_require (Some from) lexbuf } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } -and require_modifiers = parse +and require_modifiers from = parse | "(*" - { comment lexbuf; require_modifiers lexbuf } + { comment lexbuf; require_modifiers from lexbuf } | "Import" space+ - { require_file lexbuf } + { require_file from lexbuf } | "Export" space+ - { require_file lexbuf } + { require_file from lexbuf } | space+ - { require_modifiers lexbuf } + { require_modifiers from lexbuf } | eof { syntax_error lexbuf } | _ - { backtrack lexbuf ; require_file lexbuf } + { backtrack lexbuf ; require_file from lexbuf } -and consume_require = parse +and consume_require from = parse | "(*" - { comment lexbuf; consume_require lexbuf } + { comment lexbuf; consume_require from lexbuf } | space+ - { consume_require lexbuf } + { consume_require from lexbuf } | "Require" space+ - { require_modifiers lexbuf } - | eof - { syntax_error lexbuf } + { require_modifiers from lexbuf } | _ { syntax_error lexbuf } @@ -152,20 +136,19 @@ and add_loadpath = parse | eof { syntax_error lexbuf } | '"' [^ '"']* '"' (*'"'*) - { loadpath := unquote_string (lexeme lexbuf); - add_loadpath_as lexbuf } + { add_loadpath_as (unquote_string (lexeme lexbuf)) lexbuf } -and add_loadpath_as = parse +and add_loadpath_as path = parse | "(*" - { comment lexbuf; add_loadpath_as lexbuf } + { comment lexbuf; add_loadpath_as path lexbuf } | space+ - { add_loadpath_as lexbuf } + { add_loadpath_as path lexbuf } | "as" { let qid = coq_qual_id lexbuf in skip_to_dot lexbuf; - AddRecLoadPath (!loadpath,qid) } + AddRecLoadPath (path, qid) } | dot - { AddLoadPath !loadpath } + { AddLoadPath path } and caml_action = parse | space + @@ -176,8 +159,7 @@ and caml_action = parse { caml_action lexbuf } | caml_low_ident { caml_action lexbuf } | caml_up_ident - { ml_module_name := Lexing.lexeme lexbuf; - qual_id lexbuf } + { qual_id (Lexing.lexeme lexbuf) lexbuf } | ['0'-'9']+ | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ | '0' ['o' 'O'] ['0'-'7']+ @@ -260,18 +242,15 @@ and load_file = parse | _ { syntax_error lexbuf } -and require_file = parse +and require_file from = parse | "(*" - { comment lexbuf; require_file lexbuf } + { comment lexbuf; require_file from lexbuf } | space+ - { require_file lexbuf } + { require_file from lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - module_names := [coq_qual_id_tail lexbuf]; - let qid = coq_qual_id_list lexbuf in + { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + let qid = coq_qual_id_list [name] lexbuf in parse_dot lexbuf; - let from = !from_pre_ident in - from_pre_ident := None; Require (from, qid) } | eof { syntax_error lexbuf } @@ -294,66 +273,55 @@ and coq_qual_id = parse | space+ { coq_qual_id lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - coq_qual_id_tail lexbuf } - | eof - { syntax_error lexbuf } + { coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf } | _ - { backtrack lexbuf; - let qid = List.rev !module_current_name in - module_current_name := []; - qid } + { syntax_error lexbuf } -and coq_qual_id_tail = parse +and coq_qual_id_tail module_name = parse | "(*" - { comment lexbuf; coq_qual_id_tail lexbuf } + { comment lexbuf; coq_qual_id_tail module_name lexbuf } | space+ - { coq_qual_id_tail lexbuf } + { coq_qual_id_tail module_name lexbuf } | coq_field - { module_current_name := - field_name (Lexing.lexeme lexbuf) :: !module_current_name; - coq_qual_id_tail lexbuf } + { coq_qual_id_tail (field_name (Lexing.lexeme lexbuf) :: module_name) lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; - let qid = List.rev !module_current_name in - module_current_name := []; - qid } + List.rev module_name } -and coq_qual_id_list = parse +and coq_qual_id_list module_names = parse | "(*" - { comment lexbuf; coq_qual_id_list lexbuf } + { comment lexbuf; coq_qual_id_list module_names lexbuf } | space+ - { coq_qual_id_list lexbuf } + { coq_qual_id_list module_names lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - module_names := coq_qual_id_tail lexbuf :: !module_names; - coq_qual_id_list lexbuf + { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + coq_qual_id_list (name :: module_names) lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; - List.rev !module_names } + List.rev module_names } -and modules = parse +and modules mllist = parse | space+ - { modules lexbuf } + { modules mllist lexbuf } | "(*" - { comment lexbuf; modules lexbuf } + { comment lexbuf; modules mllist lexbuf } | '"' [^'"']* '"' { let lex = (Lexing.lexeme lexbuf) in let str = String.sub lex 1 (String.length lex - 2) in - mllist := str :: !mllist; modules lexbuf} + modules (str :: mllist) lexbuf} | eof { syntax_error lexbuf } | _ - { (Declare (List.rev !mllist)) } + { Declare (List.rev mllist) } -and qual_id = parse - | '.' [^ '.' '(' '['] { - Use_module (String.uncapitalize !ml_module_name) } +and qual_id ml_module_name = parse + | '.' [^ '.' '(' '['] + { Use_module (String.uncapitalize ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } -- cgit v1.2.3 From 315aac9ae0d411c10849c421d5dfd8e134919233 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 1 Dec 2015 11:30:35 +0100 Subject: vio: fix argument parsing (progress on #4442) --- stm/vio_checking.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 06bf955c82..ce930cacb7 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -43,7 +43,7 @@ let schedule_vio_checking j fs = let rec filter_argv b = function | [] -> [] | "-schedule-vio-checking" :: rest -> filter_argv true rest - | s :: rest when s.[0] = '-' && b -> filter_argv false (s :: rest) + | s :: rest when String.length s > 0 && s.[0] = '-' && b -> filter_argv false (s :: rest) | _ :: rest when b -> filter_argv b rest | s :: rest -> s :: filter_argv b rest in let pack = function -- cgit v1.2.3 From f7030a3358dda9bbc6de8058ab3357be277c031a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 26 Nov 2015 14:19:37 +0100 Subject: Remove unneeded fixpoint in normalize_context_set. Note that it is no longer stable w.r.t. equality constraints as the universe graph will choose different canonical levels depending on the equalities given to it (l = r vs r = l). --- engine/evd.ml | 34 ++++++---------------------------- engine/uState.ml | 30 ++++++++++++++---------------- engine/uState.mli | 2 +- 3 files changed, 21 insertions(+), 45 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index 00a869fda8..425b67e080 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -275,9 +275,6 @@ let add_universe_constraints_context = UState.add_universe_constraints let constrain_variables = UState.constrain_variables let evar_universe_context_of_binders = UState.of_binders -(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) -(* let add_universe_constraints_context = *) -(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *) (*******************************************************************) (* Metamaps *) @@ -860,12 +857,9 @@ let set_eq_sort env d s1 s2 = d let has_lub evd u1 u2 = - (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *) - (* (\* let dref, norm = memo_normalize_universe d in *\) *) - (* let u1 = normalize u1 and u2 = normalize u2 in *) - if Univ.Universe.equal u1 u2 then evd - else add_universe_constraints evd - (Universes.Constraints.singleton (u1,Universes.ULub,u2)) + if Univ.Universe.equal u1 u2 then evd + else add_universe_constraints evd + (Universes.Constraints.singleton (u1,Universes.ULub,u2)) let set_eq_level d u1 u2 = add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty) @@ -883,15 +877,9 @@ let set_leq_sort env evd s1 s2 = match is_eq_sort s1 s2 with | None -> evd | Some (u1, u2) -> - (* if Univ.is_type0_univ u2 then *) - (* if Univ.is_small_univ u1 then evd *) - (* else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *) - (* else if Univ.is_type0m_univ u2 then *) - (* raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *) - (* else *) - if not (type_in_type env) then - add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2)) - else evd + if not (type_in_type env) then + add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2)) + else evd let check_eq evd s s' = UGraph.check_eq (UState.ugraph evd.universes) s s' @@ -901,10 +889,6 @@ let check_leq evd s s' = let normalize_evar_universe_context_variables = UState.normalize_variables -(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *) -(* let normalize_evar_universe_context_variables = *) -(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *) - let abstract_undefined_variables = UState.abstract_undefined_variables let fix_undefined_variables evd = @@ -927,12 +911,6 @@ let nf_constraints evd = let uctx' = normalize_evar_universe_context uctx' in {evd with universes = uctx'} -let nf_constraints = - if Flags.profile then - let nfconstrkey = Profile.declare_profile "nf_constraints" in - Profile.profile1 nfconstrkey nf_constraints - else nf_constraints - let universe_of_name evd s = UState.universe_of_name evd.universes s let add_universe_name evd s l = diff --git a/engine/uState.ml b/engine/uState.ml index c1aa75c091..75c03bc89c 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -434,23 +434,21 @@ let refresh_undefined_univ_variables uctx = uctx', subst let normalize uctx = - let rec fixpoint uctx = - let ((vars',algs'), us') = - Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables - uctx.uctx_univ_algebraic + let ((vars',algs'), us') = + Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables + uctx.uctx_univ_algebraic + in + if Univ.ContextSet.equal us' uctx.uctx_local then uctx + else + let us', universes = + Universes.refresh_constraints uctx.uctx_initial_universes us' in - if Univ.ContextSet.equal us' uctx.uctx_local then uctx - else - let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in - let uctx' = - { uctx_names = uctx.uctx_names; - uctx_local = us'; - uctx_univ_variables = vars'; - uctx_univ_algebraic = algs'; - uctx_universes = universes; - uctx_initial_universes = uctx.uctx_initial_universes } - in fixpoint uctx' - in fixpoint uctx + { uctx_names = uctx.uctx_names; + uctx_local = us'; + uctx_univ_variables = vars'; + uctx_univ_algebraic = algs'; + uctx_universes = universes; + uctx_initial_universes = uctx.uctx_initial_universes } let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) diff --git a/engine/uState.mli b/engine/uState.mli index 3a6f77e14e..a188a5269f 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -44,7 +44,7 @@ val ugraph : t -> UGraph.t val algebraics : t -> Univ.LSet.t (** The subset of unification variables that can be instantiated with algebraic - universes as they appear in types and universe instances only. *) + universes as they appear in inferred types only. *) val constraints : t -> Univ.constraints (** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *) -- cgit v1.2.3 From 551a03d3e50d067b4b10669b6b302692e6ac3081 Mon Sep 17 00:00:00 2001 From: Jacques-Henri Jourdan Date: Fri, 10 Jul 2015 16:20:33 +0200 Subject: New algorithm for universe cycle detections. --- kernel/uGraph.ml | 1264 ++++++++++++++++++++++++++------------------------- test-suite/Makefile | 2 +- 2 files changed, 652 insertions(+), 614 deletions(-) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index ee4231b1fa..9e8ffbc7f2 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -18,67 +18,73 @@ open Univ (* Support for universe polymorphism by MS [2014] *) (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, - Pierre-Marie Pédrot *) + Pierre-Marie Pédrot, Jacques-Henri Jourdan *) let error_inconsistency o u v (p:explanation option) = raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) -type status = Unset | SetLe | SetLt +(* Universes are stratified by a partial ordering $\le$. + Let $\~{}$ be the associated equivalence. We also have a strict ordering + $<$ between equivalence classes, and we maintain that $<$ is acyclic, + and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + + At every moment, we have a finite number of universes, and we + maintain the ordering in the presence of assertions $U false -| SetLe | SetLt -> true - -let arc_is_lt arc = match arc.status with -| Unset | SetLe -> false -| SetLt -> true - -let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset} - -module UMap : -sig - type key = Level.t - type +'a t - val empty : 'a t - val add : key -> 'a -> 'a t -> 'a t - val find : key -> 'a t -> 'a - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val iter : (key -> 'a -> unit) -> 'a t -> unit - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t -end = HMap.Make(Level) +let big_rank = 1000000 (* A Level.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = - Canonical of canonical_arc + Canonical of canonical_node | Equiv of Level.t -type universes = univ_entry UMap.t +type universes = + { entries : univ_entry UMap.t; + index : int; + n_nodes : int; n_edges : int } type t = universes (** Used to cleanup universes if a traversal function is interrupted before it has the opportunity to do it itself. *) let unsafe_cleanup_universes g = - let iter _ arc = match arc with + let iter _ n = match n with | Equiv _ -> () - | Canonical arc -> arc.status <- Unset + | Canonical n -> n.status <- NoMark in - UMap.iter iter g + UMap.iter iter g.entries let rec cleanup_universes g = try unsafe_cleanup_universes g @@ -89,30 +95,43 @@ let rec cleanup_universes g = succeed. *) cleanup_universes g; raise e -let enter_equiv_arc u v g = - UMap.add u (Equiv v) g - -let enter_arc ca g = - UMap.add ca.univ (Canonical ca) g - (* Every Level.t has a unique canonical arc representative *) -(** The graph always contains nodes for Prop and Set. *) - -let terminal_lt u v = - {(terminal u) with lt=[v]} - -let empty_universes = - let g = enter_arc (terminal Level.set) UMap.empty in - let g = enter_arc (terminal_lt Level.prop Level.set) g in - g - -(* repr : universes -> Level.t -> canonical_arc *) +(* Low-level function : makes u an alias for v. + Does not removes edges from n_edges, but decrements n_nodes. + u should be entered as canonical before. *) +let enter_equiv g u v = + { entries = + UMap.modify u (fun _ a -> + match a with + | Canonical n -> + n.status <- NoMark; + Equiv v + | _ -> assert false) g.entries; + index = g.index; + n_nodes = g.n_nodes - 1; + n_edges = g.n_edges } + +(* Low-level function : changes data associated with a canonical node. + Resets the mutable fields in the old record, in order to avoid breaking + invariants for other users of this record. + n.univ should already been inserted as a canonical node. *) +let change_node g n = + { g with entries = + UMap.modify n.univ + (fun _ a -> + match a with + | Canonical n' -> + n'.status <- NoMark; + Canonical n + | _ -> assert false) + g.entries } + +(* repr : universes -> Level.t -> canonical_node *) (* canonical representative : we follow the Equiv links *) - let rec repr g u = let a = - try UMap.find u g + try UMap.find u g.entries with Not_found -> anomaly ~label:"Univ.repr" (str"Universe " ++ Level.pr u ++ str" undefined") in @@ -127,272 +146,474 @@ let is_prop_arc u = Level.is_prop u.univ exception AlreadyDeclared -let add_universe vlev strict g = - try - let _arcv = UMap.find vlev g in - raise AlreadyDeclared - with Not_found -> - let v = terminal vlev in - let arc = - let arc = get_set_arc g in - if strict then - { arc with lt=vlev::arc.lt} - else - { arc with le=vlev::arc.le} - in - let g = enter_arc arc g in - enter_arc v g - -(* reprleq : canonical_arc -> canonical_arc list *) -(* All canonical arcv such that arcu<=arcv with arcv#arcu *) -let reprleq g arcu = - let rec searchrec w = function - | [] -> w - | v :: vl -> - let arcv = repr g v in - if List.memq arcv w || arcu==arcv then - searchrec w vl - else - searchrec (arcv :: w) vl +(* Reindexes the given universe, using the next available index. *) +let use_index g u = + let u = repr g u in + let g = change_node g { u with ilvl = g.index } in + assert (g.index > min_int); + { g with index = g.index - 1 } + +(* [safe_repr] is like [repr] but if the graph doesn't contain the + searched universe, we add it. *) +let rec safe_repr g u = + let rec safe_repr_rec entries u = + match UMap.find u entries with + | Equiv v -> safe_repr_rec entries v + | Canonical arc -> arc in - searchrec [] arcu.le - - -(* between : Level.t -> canonical_arc -> canonical_arc list *) -(* between u v = { w | u<=w<=v, w canonical } *) -(* between is the most costly operation *) - -let between g arcu arcv = - (* good are all w | u <= w <= v *) - (* bad are all w | u <= w ~<= v *) - (* find good and bad nodes in {w | u <= w} *) - (* explore b u = (b or "u is good") *) - let rec explore ((good, bad, b) as input) arcu = - if List.memq arcu good then - (good, bad, true) (* b or true *) - else if List.memq arcu bad then - input (* (good, bad, b or false) *) + try g, safe_repr_rec g.entries u + with Not_found -> + let can = + { univ = u; + ltle = UMap.empty; gtge = LSet.empty; + rank = if Level.is_small u then big_rank else 0; + klvl = 0; ilvl = 0; + status = NoMark } + in + let g = { g with + entries = UMap.add u (Canonical can) g.entries; + n_nodes = g.n_nodes + 1 } + in + let g = use_index g u in + g, repr g u + +(* Returns 1 if u is higher than v in topological order. + -1 lower + 0 if u = v *) +let topo_compare u v = + if u.klvl > v.klvl then 1 + else if u.klvl < v.klvl then -1 + else if u.ilvl > v.ilvl then 1 + else if u.ilvl < v.ilvl then -1 + else (assert (u==v); 0) + +(* Checks most of the invariants of the graph. For debugging purposes. *) +let check_universes_invariants g = + let n_edges = ref 0 in + let n_nodes = ref 0 in + UMap.iter (fun l u -> + match u with + | Canonical u -> + UMap.iter (fun v strict -> + incr n_edges; + let v = repr g v in + assert (topo_compare u v = -1); + if u.klvl = v.klvl then + assert (LSet.mem u.univ v.gtge || + LSet.exists (fun l -> u == repr g l) v.gtge)) + u.ltle; + LSet.iter (fun v -> + let v = repr g v in + assert (v.klvl = u.klvl && + (UMap.mem u.univ v.ltle || + UMap.exists (fun l _ -> u == repr g l) v.ltle)) + ) u.gtge; + assert (u.status = NoMark); + assert (Level.equal l u.univ); + assert (u.ilvl > g.index); + assert (not (UMap.mem u.univ u.ltle)); + incr n_nodes + | Equiv _ -> assert (not (Level.is_small l))) + g.entries; + assert (!n_edges = g.n_edges); + assert (!n_nodes = g.n_nodes) + +let clean_ltle g ltle = + UMap.fold (fun u strict acc -> + let uu = (repr g u).univ in + if Level.equal uu u then acc + else ( + let acc = UMap.remove u (fst acc) in + if not strict && UMap.mem uu acc then (acc, true) + else (UMap.add uu strict acc, true))) + ltle (ltle, false) + +let clean_gtge g gtge = + LSet.fold (fun u acc -> + let uu = (repr g u).univ in + if Level.equal uu u then acc + else LSet.add uu (LSet.remove u (fst acc)), true) + gtge (gtge, false) + +(* [get_ltle] and [get_gtge] return ltle and gtge arcs. + Moreover, if one of these lists is dirty (e.g. points to a + non-canonical node), these functions clean this node in the + graph by removing some duplicate edges *) +let get_ltle g u = + let ltle, chgt_ltle = clean_ltle g u.ltle in + if not chgt_ltle then u.ltle, u, g + else + let sz = UMap.cardinal u.ltle in + let sz2 = UMap.cardinal ltle in + let u = { u with ltle } in + let g = change_node g u in + let g = { g with n_edges = g.n_edges + sz2 - sz } in + u.ltle, u, g + +let get_gtge g u = + let gtge, chgt_gtge = clean_gtge g u.gtge in + if not chgt_gtge then u.gtge, u, g + else + let u = { u with gtge } in + let g = change_node g u in + u.gtge, u, g + +(* [revert_graph] rollbacks the changes made to mutable fields in + nodes in the graph. + [to_revert] contains the touched nodes. *) +let revert_graph to_revert g = + List.iter (fun t -> + match UMap.find t g.entries with + | Equiv _ -> () + | Canonical t -> + t.status <- NoMark) to_revert + +exception AbortBackward of universes +exception CycleDetected + +(* Implementation of the algorithm described in § 5.1 of the following paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. *) + +(* [delta] is the timeout for backward search. It might be + usefull to tune a multiplicative constant. *) +let get_delta g = + int_of_float + (min (float_of_int g.n_edges ** 0.5) + (float_of_int g.n_nodes ** (2./.3.))) + +let rec backward_traverse to_revert b_traversed count g x = + let x = repr g x in + let count = count - 1 in + if count < 0 then begin + revert_graph to_revert g; + raise (AbortBackward g) + end; + if x.status = NoMark then begin + x.status <- Visited; + let to_revert = x.univ::to_revert in + let gtge, x, g = get_gtge g x in + let to_revert, b_traversed, count, g = + LSet.fold (fun y (to_revert, b_traversed, count, g) -> + backward_traverse to_revert b_traversed count g y) + gtge (to_revert, b_traversed, count, g) + in + to_revert, x.univ::b_traversed, count, g + end + else to_revert, b_traversed, count, g + +let rec forward_traverse f_traversed g v_klvl x y = + let y = repr g y in + if y.klvl < v_klvl then begin + let y = { y with klvl = v_klvl; + gtge = if x == y then LSet.empty + else LSet.singleton x.univ } + in + let g = change_node g y in + let ltle, y, g = get_ltle g y in + let f_traversed, g = + UMap.fold (fun z _ (f_traversed, g) -> + forward_traverse f_traversed g v_klvl y z) + ltle (f_traversed, g) + in + y.univ::f_traversed, g + end else if y.klvl = v_klvl && x != y then + let g = change_node g + { y with gtge = LSet.add x.univ y.gtge } in + f_traversed, g + else f_traversed, g + +let rec find_to_merge to_revert g x v = + let x = repr g x in + match x.status with + | Visited -> false, to_revert | ToMerge -> true, to_revert + | NoMark -> + let to_revert = x::to_revert in + if Level.equal x.univ v then + begin x.status <- ToMerge; true, to_revert end else - let leq = reprleq g arcu in - (* is some universe >= u good ? *) - let good, bad, b_leq = - List.fold_left explore (good, bad, false) leq - in - if b_leq then - arcu::good, bad, true (* b or true *) - else - good, arcu::bad, b (* b or false *) + begin + let merge, to_revert = LSet.fold + (fun y (merge, to_revert) -> + let merge', to_revert = find_to_merge to_revert g y v in + merge' || merge, to_revert) x.gtge (false, to_revert) + in + x.status <- if merge then ToMerge else Visited; + merge, to_revert + end + | _ -> assert false + +let get_new_edges g to_merge = + (* Computing edge sets. *) + let to_merge_lvl = + List.fold_left (fun acc u -> UMap.add u.univ u acc) + UMap.empty to_merge + in + let ltle = + UMap.fold (fun _ n acc -> + UMap.merge (fun _ strict1 strict2 -> + match strict1, strict2 with + | Some true, _ | _, Some true -> Some true + | _, _ -> Some false) + acc n.ltle) + to_merge_lvl UMap.empty in - let good,_,_ = explore ([arcv],[],false) arcu in - good -(* We assume compare(u,v) = LE with v canonical (see compare below). - In this case List.hd(between g u v) = repr u - Otherwise, between g u v = [] - *) - -(** [fast_compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? - - In [strict] mode, we fully distinguish between LE and LT, while in - non-strict mode, we simply answer LE for both situations. - - If [arcv] is encountered in a LT part, we could directly answer - without visiting unneeded parts of this transitive closure. - In [strict] mode, if [arcv] is encountered in a LE part, we could only - change the default answer (1st arg [c]) from NLE to LE, since a strict - constraint may appear later. During the recursive traversal, - [lt_done] and [le_done] are universes we have already visited, - they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], - two lists of universes not yet considered, known to be above [arcu], - strictly or not. - - We use depth-first search, but the presence of [arcv] in [new_lt] - is checked as soon as possible : this seems to be slightly faster - on a test. - - We do the traversal imperatively, setting the [status] flag on visited nodes. - This ensures O(1) check, but it also requires unsetting the flag when leaving - the function. Some special care has to be taken in order to ensure we do not - recover a messed up graph at the end. This occurs in particular when the - traversal raises an exception. Even though the code below is exception-free, - OCaml may still raise random exceptions, essentially fatal exceptions or - signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note - also that the use of an imperative solution does make this function - thread-unsafe. For now we do not check universes in different threads, but if - ever this is to be done, we would need some lock somewhere. + let ltle, _ = clean_ltle g ltle in + let ltle = + UMap.merge (fun _ a strict -> + match a, strict with + | Some _, Some true -> + (* There is a lt edge inside the new component. This is a + "bad cycle". *) + raise CycleDetected + | Some _, Some false -> None + | _, _ -> strict + ) to_merge_lvl ltle + in + let gtge = + UMap.fold (fun _ n acc -> LSet.union acc n.gtge) + to_merge_lvl LSet.empty + in + let gtge, _ = clean_gtge g gtge in + let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in + (ltle, gtge) -*) -let get_explanation strict g arcu arcv = - (* [c] characterizes whether (and how) arcv has already been related - to arcu among the lt_done,le_done universe *) - let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with - | [],[] -> (to_revert, c) - | (arc,p)::lt_todo, le_todo -> - if arc_is_lt arc then - cmp c to_revert lt_todo le_todo - else - let rec find lt_todo lt le = match le with - | [] -> - begin match lt with - | [] -> - let () = arc.status <- SetLt in - cmp c (arc :: to_revert) lt_todo le_todo - | u :: lt -> - let arc = repr g u in - let p = (Lt, Universe.make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt le - end - | u :: le -> - let arc = repr g u in - let p = (Le, Universe.make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt le - in - find lt_todo arc.lt arc.le - | [], (arc,p)::le_todo -> - if arc == arcv then - (* No need to continue inspecting universes above arc: - if arcv is strictly above arc, then we would have a cycle. - But we cannot answer LE yet, a stronger constraint may - come later from [le_todo]. *) - if strict then cmp p to_revert [] le_todo else (to_revert, p) - else - if arc_is_le arc then - cmp c to_revert [] le_todo - else - let rec find lt_todo lt = match lt with - | [] -> - let fold accu u = - let p = (Le, Universe.make u) :: p in - let node = (repr g u, p) in - node :: accu - in - let le_new = List.fold_left fold le_todo arc.le in - let () = arc.status <- SetLe in - cmp c (arc :: to_revert) lt_todo le_new - | u :: lt -> - let arc = repr g u in - let p = (Lt, Universe.make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt +let reorder g u v = + (* STEP 1: backward search in the k-level of u. *) + let delta = get_delta g in + + (* [v_klvl] is the chosen future level for u, v and all + traversed nodes. *) + let b_traversed, v_klvl, g = + try + let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in + revert_graph to_revert g; + let v_klvl = (repr g u).klvl in + b_traversed, v_klvl, g + with AbortBackward g -> + (* Backward search was too long, use the next k-level. *) + let v_klvl = (repr g u).klvl + 1 in + [], v_klvl, g + in + let f_traversed, g = + (* STEP 2: forward search. Contrary to what is described in + the paper, we do not test whether v_klvl = u.klvl nor we assign + v_klvl to v.klvl. Indeed, the first call to forward_traverse + will do all that. *) + forward_traverse [] g v_klvl (repr g v) v + in + + (* STEP 3: merge nodes if needed. *) + let to_merge, b_reindex, f_reindex = + if (repr g u).klvl = v_klvl then + begin + let merge, to_revert = find_to_merge [] g u v in + let r = + if merge then + List.filter (fun u -> u.status = ToMerge) to_revert, + List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, + List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed + else [], b_traversed, f_traversed in - find [] arc.lt + List.iter (fun u -> u.status <- NoMark) to_revert; + r + end + else [], b_traversed, f_traversed in - let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in - try - let (to_revert, c) = cmp start [] [] [(arcu, [])] in - (** Reset all the touched arcs. *) - let () = List.iter (fun arc -> arc.status <- Unset) to_revert in - List.rev c - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e + let to_reindex, g = + match to_merge with + | [] -> List.rev_append f_reindex b_reindex, g + | n0::q0 -> + (* Computing new root. *) + let root, rank_rest = + List.fold_left (fun ((best, rank_rest) as acc) n -> + if n.rank >= best.rank then n, best.rank else acc) + (n0, min_int) q0 + in + let ltle, gtge = get_new_edges g to_merge in + (* Inserting the new root. *) + let g = change_node g + { root with ltle; gtge; + rank = max root.rank (rank_rest + 1); } + in -let get_explanation strict g arcu arcv = - if !Flags.univ_print then Some (get_explanation strict g arcu arcv) - else None + (* Inserting shortcuts for old nodes. *) + let g = List.fold_left (fun g n -> + if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ) + g to_merge + in -type fast_order = FastEQ | FastLT | FastLE | FastNLE + (* Updating g.n_edges *) + let oldsz = + List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle) + 0 to_merge + in + let sz = UMap.cardinal ltle in + let g = { g with n_edges = g.n_edges + sz - oldsz } in -let fast_compare_neq strict g arcu arcv = - (* [c] characterizes whether arcv has already been related - to arcu among the lt_done,le_done universe *) - let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with - | [],[] -> (to_revert, c) - | arc::lt_todo, le_todo -> - if arc_is_lt arc then - cmp c to_revert lt_todo le_todo - else - let () = arc.status <- SetLt in - process_lt c (arc :: to_revert) lt_todo le_todo arc.lt arc.le - | [], arc::le_todo -> - if arc == arcv then - (* No need to continue inspecting universes above arc: - if arcv is strictly above arc, then we would have a cycle. - But we cannot answer LE yet, a stronger constraint may - come later from [le_todo]. *) - if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE) - else - if arc_is_le arc then - cmp c to_revert [] le_todo - else - let () = arc.status <- SetLe in - process_le c (arc :: to_revert) [] le_todo arc.lt arc.le - - and process_lt c to_revert lt_todo le_todo lt le = match le with - | [] -> - begin match lt with - | [] -> cmp c to_revert lt_todo le_todo - | u :: lt -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else process_lt c to_revert (arc :: lt_todo) le_todo lt le - end - | u :: le -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else process_lt c to_revert (arc :: lt_todo) le_todo lt le - - and process_le c to_revert lt_todo le_todo lt le = match lt with - | [] -> - let fold accu u = - let node = repr g u in - node :: accu - in - let le_new = List.fold_left fold le_todo le in - cmp c to_revert lt_todo le_new - | u :: lt -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else process_le c to_revert (arc :: lt_todo) le_todo lt le + (* Not clear in the paper: we have to put the newly + created component just between B and F. *) + List.rev_append f_reindex (root.univ::b_reindex), g in + + (* STEP 4: reindex traversed nodes. *) + List.fold_left use_index g to_reindex + +(* Assumes [u] and [v] are already in the graph. *) +(* Does NOT assume that ucan != vcan. *) +let insert_edge strict ucan vcan g = try - let (to_revert, c) = cmp FastNLE [] [] [arcu] in - (** Reset all the touched arcs. *) - let () = List.iter (fun arc -> arc.status <- Unset) to_revert in - c - with e -> + let u = ucan.univ and v = vcan.univ in + (* do we need to reorder nodes ? *) + let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in + + (* insert the new edge in the graph. *) + let u = repr g u in + let v = repr g v in + if u == v then + if strict then raise CycleDetected else g + else + let g = + try let oldstrict = UMap.find v.univ u.ltle in + if strict && not oldstrict then + change_node g { u with ltle = UMap.add v.univ true u.ltle } + else g + with Not_found -> + { (change_node g { u with ltle = UMap.add v.univ strict u.ltle }) + with n_edges = g.n_edges + 1 } + in + if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g + else + let v = { v with gtge = LSet.add u.univ v.gtge } in + change_node g v + with + | CycleDetected as e -> raise e + | e -> (** Unlikely event: fatal error or signal *) let () = cleanup_universes g in raise e -let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv +let add_universe vlev strict g = + try + let _arcv = UMap.find vlev g.entries in + raise AlreadyDeclared + with Not_found -> + assert (g.index > min_int); + let v = { + univ = vlev; + ltle = LMap.empty; + gtge = LSet.empty; + rank = 0; + klvl = 0; + ilvl = g.index; + status = NoMark; + } + in + let entries = UMap.add vlev (Canonical v) g.entries in + let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in + insert_edge strict (get_set_arc g) v g + +exception Found_explanation of explanation + +let get_explanation strict u v g = + let v = repr g v in + let visited_strict = ref UMap.empty in + let rec traverse strict u = + if u == v then + if strict then None else Some [] + else if topo_compare u v = 1 then None + else + let visited = + try not (UMap.find u.univ !visited_strict) || strict + with Not_found -> false + in + if visited then None + else begin + visited_strict := UMap.add u.univ strict !visited_strict; + try + UMap.iter (fun u' strictu' -> + match traverse (strict && not strictu') (repr g u') with + | None -> () + | Some exp -> + let typ = if strictu' then Lt else Le in + raise (Found_explanation ((typ, make u') :: exp))) + u.ltle; + None + with Found_explanation exp -> Some exp + end + in + let u = repr g u in + if u == v then [(Eq, make v.univ)] + else match traverse strict u with Some exp -> exp | None -> assert false -let fast_compare g arcu arcv = - if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv +let get_explanation strict u v g = + if !Flags.univ_print then Some (get_explanation strict u v g) + else None -let is_leq g arcu arcv = - arcu == arcv || - (match fast_compare_neq false g arcu arcv with - | FastNLE -> false - | (FastEQ|FastLE|FastLT) -> true) - -let is_lt g arcu arcv = - if arcu == arcv then false +(* To compare two nodes, we simply do a forward search. + We implement two improvements: + - we ignore nodes that are higher than the destination; + - we do a BFS rather than a DFS because we expect to have a short + path (typically, the shortest path has length 1) +*) +exception Found of canonical_node list +let search_path strict u v g = + let rec loop to_revert todo next_todo = + match todo, next_todo with + | [], [] -> to_revert (* No path found *) + | [], _ -> loop to_revert next_todo [] + | (u, strict)::todo, _ -> + if u.status = Visited || (u.status = WeakVisited && strict) + then loop to_revert todo next_todo + else + let to_revert = + if u.status = NoMark then u::to_revert else to_revert + in + u.status <- if strict then WeakVisited else Visited; + if try UMap.find v.univ u.ltle || not strict + with Not_found -> false + then raise (Found to_revert) + else + begin + let next_todo = + UMap.fold (fun u strictu next_todo -> + let strict = not strictu && strict in + let u = repr g u in + if u == v && not strict then raise (Found to_revert) + else if topo_compare u v = 1 then next_todo + else (u, strict)::next_todo) + u.ltle next_todo + in + loop to_revert todo next_todo + end + in + if u == v then not strict else - match fast_compare_neq true g arcu arcv with - | FastLT -> true - | (FastEQ|FastLE|FastNLE) -> false - -(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ - compare(u,v) = LT or LE => compare(v,u) = NLE - compare(u,v) = NLE => compare(v,u) = NLE or LE or LT - - Adding u>=v is consistent iff compare(v,u) # LT - and then it is redundant iff compare(u,v) # NLE - Adding u>v is consistent iff compare(v,u) = NLE - and then it is redundant iff compare(u,v) = LT *) - -(** * Universe checks [check_eq] and [check_leq], used in coqchk *) + try + let res, to_revert = + try false, loop [] [u, strict] [] + with Found to_revert -> true, to_revert + in + List.iter (fun u -> u.status <- NoMark) to_revert; + res + with e -> + (** Unlikely event: fatal error or signal *) + let () = cleanup_universes g in + raise e + +(** Uncomment to debug the cycle detection algorithm. *) +(*let insert_edge strict ucan vcan g = + check_universes_invariants g; + let g = insert_edge strict ucan vcan g in + check_universes_invariants g; + let ucan = repr g ucan.univ in + let vcan = repr g vcan.univ in + assert (search_path strict ucan vcan g); + g*) (** First, checks on universe levels *) @@ -405,11 +626,11 @@ let check_eq_level g u v = u == v || check_equal g u v let check_smaller g strict u v = let arcu = repr g u and arcv = repr g v in if strict then - is_lt g arcu arcv + search_path true arcu arcv g else is_prop_arc arcu || (is_set_arc arcu && not (is_prop_arc arcv)) - || is_leq g arcu arcv + || search_path false arcu arcv g (** Then, checks on universes *) @@ -448,145 +669,68 @@ let check_leq g u v = is_type0m_univ u || check_eq_univs g u v || real_check_leq g u v -(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) - -(* setlt : Level.t -> Level.t -> reason -> unit *) -(* forces u > v *) -(* this is normally an update of u in g rather than a creation. *) -let setlt g arcu arcv = - let arcu' = {arcu with lt=arcv.univ::arcu.lt} in - enter_arc arcu' g, arcu' - -(* checks that non-redundant *) -let setlt_if (g,arcu) v = - let arcv = repr g v in - if is_lt g arcu arcv then g, arcu - else setlt g arcu arcv - -(* setleq : Level.t -> Level.t -> unit *) -(* forces u >= v *) -(* this is normally an update of u in g rather than a creation. *) -let setleq g arcu arcv = - let arcu' = {arcu with le=arcv.univ::arcu.le} in - enter_arc arcu' g, arcu' - -(* checks that non-redundant *) -let setleq_if (g,arcu) v = - let arcv = repr g v in - if is_leq g arcu arcv then g, arcu - else setleq g arcu arcv - -(* merge : Level.t -> Level.t -> unit *) -(* we assume compare(u,v) = LE *) -(* merge u v forces u ~ v with repr u as canonical repr *) -let merge g arcu arcv = - (* we find the arc with the biggest rank, and we redirect all others to it *) - let arcu, g, v = - let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = - if Level.is_small arc.univ || - (arc.rank >= max_rank && not (Level.is_small best_arc.univ)) - then (arc.rank, max_rank, arc, best_arc::rest) - else (max_rank, old_max_rank, best_arc, arc::rest) - in - match between g arcu arcv with - | [] -> anomaly (str "Univ.between") - | arc::rest -> - let (max_rank, old_max_rank, best_arc, rest) = - List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in - if max_rank > old_max_rank then best_arc, g, rest - else begin - (* one redirected node also has max_rank *) - let arcu = {best_arc with rank = max_rank + 1} in - arcu, enter_arc arcu g, rest - end - in - let redirect (g,w,w') arcv = - let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',List.unionq arcv.lt w,arcv.le@w') - in - let (g',w,w') = List.fold_left redirect (g,[],[]) v in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu w in - let g_arcu = List.fold_left setleq_if g_arcu w' in - fst g_arcu - -(* merge_disc : Level.t -> Level.t -> unit *) -(* we assume compare(u,v) = compare(v,u) = NLE *) -(* merge_disc u v forces u ~ v with repr u as canonical repr *) -let merge_disc g arc1 arc2 = - let arcu, arcv = if Level.is_small arc2.univ || arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in - let arcu, g = - if not (Int.equal arc1.rank arc2.rank) then arcu, g - else - let arcu = {arcu with rank = succ arcu.rank} in - arcu, enter_arc arcu g - in - let g' = enter_equiv_arc arcv.univ arcu.univ g in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in - let g_arcu = List.fold_left setleq_if g_arcu arcv.le in - fst g_arcu +(* enforc_univ_eq g u v will force u=v if possible, will fail otherwise *) -(* enforce_univ_eq : Level.t -> Level.t -> unit *) -(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *) +let rec enforce_univ_eq u v g = + let ucan = repr g u in + let vcan = repr g v in + if topo_compare ucan vcan = 1 then enforce_univ_eq v u g + else + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + error_inconsistency Eq v u (get_explanation true u v g) -let enforce_univ_eq u v g = - let arcu = repr g u and arcv = repr g v in - match fast_compare g arcu arcv with - | FastEQ -> g - | FastLT -> - let p = get_explanation_strict g arcu arcv in - error_inconsistency Eq v u p - | FastLE -> merge g arcu arcv - | FastNLE -> - (match fast_compare g arcv arcu with - | FastLT -> - let p = get_explanation_strict g arcv arcu in - error_inconsistency Eq u v p - | FastLE -> merge g arcv arcu - | FastNLE -> merge_disc g arcu arcv - | FastEQ -> anomaly (Pp.str "Univ.compare")) - -(* enforce_univ_leq : Level.t -> Level.t -> unit *) -(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) +(* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = - let arcu = repr g u and arcv = repr g v in - if is_leq g arcu arcv then g - else - match fast_compare g arcv arcu with - | FastLT -> - let p = get_explanation_strict g arcv arcu in - error_inconsistency Le u v p - | FastLE -> merge g arcv arcu - | FastNLE -> fst (setleq g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") + let ucan = repr g u in + let vcan = repr g v in + try insert_edge false ucan vcan g + with CycleDetected -> + error_inconsistency Le u v (get_explanation true v u g) (* enforce_univ_lt u v will force u g - | FastLE -> fst (setlt g arcu arcv) - | FastEQ -> error_inconsistency Lt u v (Some [(Eq,Universe.make v)]) - | FastNLE -> - match fast_compare_neq false g arcv arcu with - FastNLE -> fst (setlt g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") - | (FastLE|FastLT) -> - let p = get_explanation false g arcv arcu in - error_inconsistency Lt u v p + let ucan = repr g u in + let vcan = repr g v in + try insert_edge true ucan vcan g + with CycleDetected -> + error_inconsistency Lt u v (get_explanation false v u g) + +let empty_universes = + let set_arc = Canonical { + univ = Level.set; + ltle = LMap.empty; + gtge = LSet.empty; + rank = big_rank; + klvl = 0; + ilvl = (-1); + status = NoMark; + } in + let prop_arc = Canonical { + univ = Level.prop; + ltle = LMap.empty; + gtge = LSet.empty; + rank = big_rank; + klvl = 0; + ilvl = 0; + status = NoMark; + } in + let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in + let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in + enforce_univ_lt Level.prop Level.set empty (* Prop = Set is forbidden here. *) let initial_universes = empty_universes -let is_initial_universes g = UMap.equal (==) g initial_universes - +let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries + let enforce_constraint cst g = match cst with | (u,Lt,v) -> enforce_univ_lt u v g | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g - + let merge_constraints c g = Constraint.fold enforce_constraint c g @@ -608,193 +752,89 @@ let lookup_level u g = directly to the canonical representent of their target. The output graph should be equivalent to the input graph from a logical point of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges - (see the assertion)... I (Stéphane Glondu) am not sure if this - plays a role in the rest of the module. *) + a [Canonical] element is its own name, by keeping [Equiv] edges. *) let normalize_universes g = - let rec visit u arc cache = match lookup_level u cache with - | Some x -> x, cache - | None -> match Lazy.force arc with - | None -> - u, UMap.add u u cache - | Some (Canonical {univ=v; lt=_; le=_}) -> - v, UMap.add u v cache - | Some (Equiv v) -> - let v, cache = visit v (lazy (lookup_level v g)) cache in - v, UMap.add u v cache - in - let cache = UMap.fold - (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) - g UMap.empty - in - let repr x = UMap.find x cache in - let lrepr us = List.fold_left - (fun e x -> LSet.add (repr x) e) LSet.empty us + let g = + { g with + entries = UMap.map (fun entry -> + match entry with + | Equiv u -> Equiv ((repr g u).univ) + | Canonical ucan -> Canonical { ucan with rank = 1 }) + g.entries } in - let canonicalize u = function - | Equiv _ -> Equiv (repr u) - | Canonical {univ=v; lt=lt; le=le; rank=rank} -> - assert (u == v); - (* avoid duplicates and self-loops *) - let lt = lrepr lt and le = lrepr le in - let le = LSet.filter - (fun x -> x != u && not (LSet.mem x lt)) le - in - LSet.iter (fun x -> assert (x != u)) lt; - Canonical { - univ = v; - lt = LSet.elements lt; - le = LSet.elements le; - rank = rank; - status = Unset; - } - in - UMap.mapi canonicalize g + UMap.fold (fun _ u g -> + match u with + | Equiv u -> g + | Canonical u -> + let _, u, g = get_ltle g u in + let _, _, g = get_gtge g u in + g) + g.entries g let constraints_of_universes g = let constraints_of u v acc = match v with - | Canonical {univ=u; lt=lt; le=le} -> - let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in - let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in - acc + | Canonical {univ=u; ltle} -> + UMap.fold (fun v strict acc-> + let typ = if strict then Lt else Le in + Constraint.add (u,typ,v) acc) ltle acc | Equiv v -> Constraint.add (u,Eq,v) acc in - UMap.fold constraints_of g Constraint.empty + UMap.fold constraints_of g.entries Constraint.empty let constraints_of_universes g = constraints_of_universes (normalize_universes g) -(** Longest path algorithm. This is used to compute the minimal number of - universes required if the only strict edge would be the Lt one. This - algorithm assumes that the given universes constraints are a almost DAG, in - the sense that there may be {Eq, Le}-cycles. This is OK for consistent - universes, which is the only case where we use this algorithm. *) - -(** Adjacency graph *) -type graph = constraint_type LMap.t LMap.t - -exception Connected - -(** Check connectedness *) -let connected x y (g : graph) = - let rec connected x target seen g = - if Level.equal x target then raise Connected - else if not (LSet.mem x seen) then - let seen = LSet.add x seen in - let fold z _ seen = connected z target seen g in - let neighbours = try LMap.find x g with Not_found -> LMap.empty in - LMap.fold fold neighbours seen - else seen +(** [sort_universes g] builds a totally ordered universe graph. The + output graph should imply the input graph (and the implication + will be strict most of the time), but is not necessarily minimal. + Moreover, it adds levels [Type.n] to identify universes at level + n. An artificial constraint Set < Type.2 is added to ensure that + Type.n and small universes are not merged. Note: the result is + unspecified if the input graph already contains [Type.n] nodes + (calling a module Type is probably a bad idea anyway). *) +let sort_universes g = + let cans = + UMap.fold (fun _ u l -> + match u with + | Equiv _ -> l + | Canonical can -> can :: l + ) g.entries [] in - try ignore(connected x y LSet.empty g); false with Connected -> true - -let add_edge x y v (g : graph) = - try - let neighbours = LMap.find x g in - let neighbours = LMap.add y v neighbours in - LMap.add x neighbours g - with Not_found -> - LMap.add x (LMap.singleton y v) g - -(** We want to keep the graph DAG. If adding an edge would cause a cycle, that - would necessarily be an {Eq, Le}-cycle, otherwise there would have been a - universe inconsistency. Therefore we may omit adding such a cycling edge - without changing the compacted graph. *) -let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g - -(** Construct the DAG and its inverse at the same time. *) -let make_graph g : (graph * graph) = - let fold u arc accu = match arc with - | Equiv v -> - let (dir, rev) = accu in - (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev) - | Canonical { univ; lt; le; } -> - let () = assert (u == univ) in - let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in - let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in - (** Order is important : lt after le, because of the possible redundancy - between [le] and [lt] in a canonical arc. This way, the [lt] constraint - is the last one set, which is correct because it implies [le]. *) - let accu = List.fold_left fold_le accu le in - let accu = List.fold_left fold_lt accu lt in - accu - in - UMap.fold fold g (LMap.empty, LMap.empty) - -(** Construct a topological order out of a DAG. *) -let rec topological_fold u g rem seen accu = - let is_seen = - try - let status = LMap.find u seen in - assert status; (** If false, not a DAG! *) - true - with Not_found -> false + let cans = List.sort topo_compare cans in + let lowest_levels = + UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2) + (UMap.filter + (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) + g.entries) in - if not is_seen then - let rem = LMap.remove u rem in - let seen = LMap.add u false seen in - let neighbours = try LMap.find u g with Not_found -> LMap.empty in - let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in - let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in - (rem, LMap.add u true seen, u :: accu) - else (rem, seen, accu) - -let rec topological g rem seen accu = - let node = try Some (LMap.choose rem) with Not_found -> None in - match node with - | None -> accu - | Some (u, _) -> - let rem, seen, accu = topological_fold u g rem seen accu in - topological g rem seen accu - -(** Compute the longest path from any vertex. *) -let constraint_cost = function -| Eq | Le -> 0 -| Lt -> 1 - -(** This algorithm browses the graph in topological order, computing for each - encountered node the length of the longest path leading to it. Should be - O(|V|) or so (modulo map representation). *) -let rec flatten_graph rem (rev : graph) map mx = match rem with -| [] -> map, mx -| u :: rem -> - let prev = try LMap.find u rev with Not_found -> LMap.empty in - let fold v cstr accu = - let v_cost = LMap.find v map in - max (v_cost + constraint_cost cstr) accu + let lowest_levels = + List.fold_left (fun lowest_levels can -> + let lvl = UMap.find can.univ lowest_levels in + UMap.fold (fun u' strict lowest_levels -> + let cost = if strict then 1 else 0 in + let u' = (repr g u').univ in + UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels) + can.ltle lowest_levels) + lowest_levels cans in - let u_cost = LMap.fold fold prev 0 in - let map = LMap.add u u_cost map in - flatten_graph rem rev map (max mx u_cost) - -(** [sort_universes g] builds a map from universes in [g] to natural - numbers. It outputs a graph containing equivalence edges from each - level appearing in [g] to [Type.n], and [lt] edges between the - [Type.n]s. The output graph should imply the input graph (and the - [Type.n]s. The output graph should imply the input graph (and the - implication will be strict most of the time), but is not - necessarily minimal. Note: the result is unspecified if the input - graph already contains [Type.n] nodes (calling a module Type is - probably a bad idea anyway). *) -let sort_universes orig = - let (dir, rev) = make_graph orig in - let order = topological dir dir LMap.empty [] in - let compact, max = flatten_graph order rev LMap.empty 0 in + let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in let mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let types = Array.init (max + 1) (fun n -> Level.make mp n) in - (** Old universes are made equal to [Type.n] *) - let fold u level accu = UMap.add u (Equiv types.(level)) accu in - let sorted = LMap.fold fold compact UMap.empty in - (** Add all [Type.n] nodes *) - let fold i accu u = - if i < max then - let pred = types.(i + 1) in - let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in - UMap.add u (Canonical arc) accu - else accu + let types = Array.init (max_lvl + 1) (function + | 0 -> Level.prop + | 1 -> Level.set + | n -> Level.make mp (n-2)) + in + let g = Array.fold_left (fun g u -> + let g, u = safe_repr g u in + change_node g { u with rank = big_rank }) g types in - Array.fold_left_i fold sorted types + let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in + let g = + UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g) + lowest_levels g + in + normalize_universes g (** Instances *) @@ -807,39 +847,38 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) +(** Pretty-printing *) + let pr_arc prl = function - | _, Canonical {univ=u; lt=[]; le=[]} -> - mt () - | _, Canonical {univ=u; lt=lt; le=le} -> - let opt_sep = match lt, le with - | [], _ | _, [] -> mt () - | _ -> spc () - in + | _, Canonical {univ=u; ltle} -> + if UMap.is_empty ltle then mt () + else prl u ++ str " " ++ v 0 - (pr_sequence (fun v -> str "< " ++ prl v) lt ++ - opt_sep ++ - pr_sequence (fun v -> str "<= " ++ prl v) le) ++ + (pr_sequence (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + (UMap.bindings ltle)) ++ fnl () | u, Equiv v -> prl u ++ str " = " ++ prl v ++ fnl () let pr_universes prl g = - let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in + let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in prlist (pr_arc prl) graph (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function - | Canonical {univ=u; lt=lt; le=le} -> + | Canonical {univ=u; ltle} -> let u_str = Level.to_string u in - List.iter (fun v -> output Lt u_str (Level.to_string v)) lt; - List.iter (fun v -> output Le u_str (Level.to_string v)) le + UMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u_str (Level.to_string v)) ltle; | Equiv v -> output Eq (Level.to_string u) (Level.to_string v) in - UMap.iter dump_arc g + UMap.iter dump_arc g.entries (** Profiling *) @@ -848,7 +887,6 @@ let merge_constraints = let key = Profile.declare_profile "merge_constraints" in Profile.profile2 key merge_constraints else merge_constraints - let check_constraints = if Flags.profile then let key = Profile.declare_profile "check_constraints" in diff --git a/test-suite/Makefile b/test-suite/Makefile index 31b2129001..6274183b36 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -388,7 +388,7 @@ misc/deps-order.log: } > "$@" # Sort universes for the whole standard library -EXPECTED_UNIVERSES := 5 +EXPECTED_UNIVERSES := 4 # Prop is not counted universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" -- cgit v1.2.3 From b5990eb632c2a959b7a86ea9c7e4970505e976a1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Dec 2015 14:25:31 +0100 Subject: Removing dead code in Obligations. --- tactics/tacinterp.mli | 1 - toplevel/obligations.ml | 13 +------------ 2 files changed, 1 insertion(+), 13 deletions(-) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 7605c91554..05fbd67cba 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -47,7 +47,6 @@ val extract_ltac_constr_values : interp_sign -> Environ.env -> (** To embed several objects in Coqast.t *) val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t -val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr) val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 50ecef0b0c..66bf9b383d 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -52,9 +52,6 @@ type oblinfo = ev_tac: unit Proofview.tactic option; ev_deps: Int.Set.t } -(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *) -let evar_tactic = Store.field () - (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) @@ -229,17 +226,9 @@ let eterm_obligations env name evm fs ?status t ty = | Some s -> s, None | None -> Evar_kinds.Define true, None in - let tac = match Store.get ev.evar_extra evar_tactic with - | Some t -> - if Dyn.has_tag t "tactic" then - Some (Tacinterp.interp - (Tacinterp.globTacticIn (Tacinterp.tactic_out t))) - else None - | None -> None - in let info = { ev_name = (n, nstr); ev_hyps = hyps; ev_status = status; ev_chop = chop; - ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } + ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } in (id, info) :: l) evn [] in -- cgit v1.2.3 From 16504ad480a920e1800d52f5adbea8ddecefbeb0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 2 Dec 2015 14:28:29 +0100 Subject: Fix a bug in externalisation which prevented printing of projections using dot notation. --- interp/constrextern.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 5160f07af0..ba20f9fa06 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -447,8 +447,8 @@ let is_projection nargs = function | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections -> (try let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then None - else Some n + if n <= nargs then Some n + else None with Not_found -> None) | _ -> None -- cgit v1.2.3 From c62eb0470975c9b5960a49a90b49b4aa191efd1c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 2 Dec 2015 15:37:14 +0100 Subject: Add an option to deactivate compatibility printing of primitive projections (off by default). --- pretyping/detyping.ml | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index b5228094a2..67261def0b 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -166,6 +166,18 @@ let _ = declare_bool_option optread = print_primproj_params; optwrite = (:=) print_primproj_params_value } +let print_primproj_compatibility_value = ref true +let print_primproj_compatibility () = !print_primproj_compatibility_value + +let _ = declare_bool_option + { optsync = true; + optdepr = false; + optname = "backwards-compatible printing of primitive projections"; + optkey = ["Printing";"Primitive";"Projection";"Compatibility"]; + optread = print_primproj_compatibility; + optwrite = (:=) print_primproj_compatibility_value } + + (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) @@ -476,7 +488,7 @@ let rec detype flags avoid env sigma t = GApp (dl, GRef (dl, ConstRef (Projection.constant p), None), [detype flags avoid env sigma c]) else - if Projection.unfolded p then + if print_primproj_compatibility () && Projection.unfolded p then (** Print the compatibility match version *) let c' = try -- cgit v1.2.3 From 42c68765690710b16f3e878bf1d914eaa75d8291 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 2 Dec 2015 17:35:25 +0100 Subject: Fix bug #4444: Next Obligation performed after a Section opening was using the wrong context. This is very bad style but currently unavoidable, at least we don't throw an anomaly anymore. --- toplevel/obligations.ml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index e091d825cd..f2b0380786 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -320,6 +320,7 @@ type program_info_aux = { prg_reduce : constr -> constr; prg_hook : (Evd.evar_universe_context -> unit) Lemmas.declaration_hook; prg_opaque : bool; + prg_sign: named_context_val; } type program_info = program_info_aux Ephemeron.key @@ -643,7 +644,7 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls kind reduce hook = +let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -667,8 +668,8 @@ let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; - prg_hook = hook; - prg_opaque = opaque; } + prg_hook = hook; prg_opaque = opaque; + prg_sign = sign } let map_cardinal m = let i = ref 0 in @@ -858,7 +859,7 @@ let rec solve_obligation prg num tac = let evd = Evd.from_ctx prg.prg_ctx in let auto n tac oblset = auto_solve_obligations n ~oblset tac in let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in - let () = Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type hook in + let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type hook in let () = trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type) in let _ = Pfedit.by (snd (get_default_tactic ())) in @@ -993,8 +994,9 @@ let show_term n = let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = + let sign = Decls.initialize_named_context_for_proof () in let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info ~opaque n term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info sign ~opaque n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -1011,10 +1013,11 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = + let sign = Decls.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info ~opaque n (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info sign ~opaque n (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n (Ephemeron.create prg)) l; let _defined = -- cgit v1.2.3 From 2374a23fb7ebfa547eb16ce2ab8dc9efb2a3f855 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 2 Dec 2015 17:52:07 +0100 Subject: Univs/Program: update the universe context with global universe constraints at the time of Next Obligation/Solve Obligations so that interleaving definitions and obligation solving commands works properly. --- toplevel/obligations.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index f2b0380786..314789ced6 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -857,6 +857,7 @@ let rec solve_obligation prg num tac = let obl = subst_deps_obl obls obl in let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in let evd = Evd.from_ctx prg.prg_ctx in + let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n tac oblset = auto_solve_obligations n ~oblset tac in let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type hook in @@ -893,9 +894,11 @@ and solve_obligation_by_tac prg obls i tac = | Some t -> t | None -> snd (get_default_tactic ()) in + let evd = Evd.from_ctx !prg.prg_ctx in + let evd = Evd.update_sigma_env evd (Global.env ()) in let t, ty, ctx = solve_by_tac obl.obl_name (evar_of_obligation obl) tac - (pi2 !prg.prg_kind) !prg.prg_ctx + (pi2 !prg.prg_kind) (Evd.evar_universe_context evd) in let uctx = Evd.evar_context_universe_context ctx in let () = prg := {!prg with prg_ctx = ctx} in -- cgit v1.2.3 From 9205d8dc7b9e97b6c2f0815fddc5673c21d11089 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 2 Nov 2015 12:26:53 +0100 Subject: Changing syntax "$(tactic)$" into "ltac:(tactic)", as discussed in WG. --- CHANGES | 8 ++++++++ doc/refman/RefMan-ext.tex | 4 ++-- parsing/g_constr.ml4 | 2 +- parsing/g_ltac.ml4 | 4 ++-- test-suite/bugs/closed/3249.v | 4 ++-- test-suite/bugs/closed/3285.v | 2 +- test-suite/bugs/closed/3286.v | 8 ++++---- test-suite/bugs/closed/3314.v | 4 ++-- test-suite/bugs/closed/3330.v | 2 +- test-suite/bugs/closed/3347.v | 2 +- test-suite/bugs/closed/3354.v | 2 +- test-suite/bugs/closed/3467.v | 2 +- test-suite/bugs/closed/3487.v | 2 +- test-suite/bugs/closed/3682.v | 2 +- test-suite/bugs/closed/3684.v | 2 +- test-suite/bugs/closed/3690.v | 2 +- test-suite/bugs/closed/3881.v | 2 +- test-suite/bugs/closed/HoTT_coq_077.v | 2 +- test-suite/bugs/closed/HoTT_coq_114.v | 2 +- test-suite/bugs/opened/3248.v | 4 ++-- test-suite/bugs/opened/3277.v | 2 +- test-suite/bugs/opened/3278.v | 8 ++++---- test-suite/bugs/opened/3304.v | 2 +- test-suite/bugs/opened/3459.v | 4 ++-- test-suite/success/polymorphism.v | 4 ++-- 25 files changed, 45 insertions(+), 37 deletions(-) diff --git a/CHANGES b/CHANGES index 07d6281717..662b7b9a24 100644 --- a/CHANGES +++ b/CHANGES @@ -10,6 +10,10 @@ Vernacular commands introducing it. - New command "Show id" to show goal named id. +Specification language + +- Syntax "$(tactic)$" changed to "ltac: tactic". + Tactics - New flag "Regular Subst Tactic" which fixes "subst" in situations where @@ -83,6 +87,10 @@ Logic - The VM now supports inductive types with up to 8388851 non-constant constructors and up to 8388607 constant ones. +Specification language + +- Syntax "$(tactic)$" changed to "ltac: tactic". + Tactics - A script using the admit tactic can no longer be concluded by either diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index b77118e1f9..80e12898f0 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -1998,7 +1998,7 @@ variables, use \end{quote} \subsection{Solving existential variables using tactics} -\ttindex{\textdollar( \ldots )\textdollar} +\ttindex{ltac:( \ldots )} \def\expr{\textrm{\textsl{tacexpr}}} @@ -2012,7 +2012,7 @@ binding as well as those introduced by tactic binding. The expression {\expr} can be any tactic expression as described at section~\ref{TacticLanguage}. \begin{coq_example*} -Definition foo (x : nat) : nat := $( exact x )$. +Definition foo (x : nat) : nat := ltac:(exact x). \end{coq_example*} This construction is useful when one wants to define complicated terms using diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index e2e6795f73..8df91da24b 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -218,7 +218,7 @@ GEXTEND Gram CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (!@loc, Explicit, None, c) - | "$("; tac = Tactic.tactic; ")$" -> + | "ltac:"; "("; tac = Tactic.tactic_expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in CHole (!@loc, None, IntroAnonymous, Some arg) ] ] diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index a4dba506d2..4a9ca23f15 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -134,8 +134,8 @@ GEXTEND Gram ; (* Tactic arguments *) tactic_arg: - [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) + [ [ "ltac:"; a = tactic_expr LEVEL "0" -> arg_of_expr a + | "ltac:"; n = natural -> TacGeneric (genarg_of_int n) | a = tactic_top_or_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) diff --git a/test-suite/bugs/closed/3249.v b/test-suite/bugs/closed/3249.v index d41d231739..71d457b002 100644 --- a/test-suite/bugs/closed/3249.v +++ b/test-suite/bugs/closed/3249.v @@ -5,7 +5,7 @@ Ltac ret_and_left T := lazymatch eval hnf in t with | ?a /\ ?b => constr:(proj1 T) | forall x : ?T', @?f x => - constr:(fun x : T' => $(let fx := constr:(T x) in + constr:(fun x : T' => ltac:(let fx := constr:(T x) in let t := ret_and_left fx in - exact t)$) + exact t)) end. diff --git a/test-suite/bugs/closed/3285.v b/test-suite/bugs/closed/3285.v index 25162329ef..68e6b7386f 100644 --- a/test-suite/bugs/closed/3285.v +++ b/test-suite/bugs/closed/3285.v @@ -1,7 +1,7 @@ Goal True. Proof. match goal with - | _ => let x := constr:($(fail)$) in idtac + | _ => let x := constr:(ltac:(fail)) in idtac | _ => idtac end. Abort. diff --git a/test-suite/bugs/closed/3286.v b/test-suite/bugs/closed/3286.v index b08b7ab3cc..701480fc83 100644 --- a/test-suite/bugs/closed/3286.v +++ b/test-suite/bugs/closed/3286.v @@ -6,20 +6,20 @@ Ltac make_apply_under_binders_in lem H := | forall x : ?T, @?P x => let ret := constr:(fun x' : T => let Hx := H x' in - $(let ret' := tac lem Hx in - exact ret')$) in + ltac:(let ret' := tac lem Hx in + exact ret')) in match eval cbv zeta in ret with | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in constr:(Some P') end - | _ => let ret := constr:($(match goal with + | _ => let ret := constr:(ltac:(match goal with | _ => (let H' := fresh in pose H as H'; apply lem in H'; exact (Some H')) | _ => exact (@None nat) end - )$) in + )) in let ret' := (eval cbv beta zeta in ret) in constr:(ret') | _ => constr:(@None nat) diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index fb3791af55..a5782298c3 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -1,9 +1,9 @@ Require Import TestSuite.admit. Set Universe Polymorphism. Definition Lift -: $(let U1 := constr:(Type) in +: ltac:(let U1 := constr:(Type) in let U0 := constr:(Type : U1) in - exact (U0 -> U1))$ + exact (U0 -> U1)) := fun T => T. Fail Check nat:Prop. (* The command has indeed failed with message: diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index e6a50449da..e3b5e94356 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -8,7 +8,7 @@ Inductive foo : Type@{l} := bar : foo . Section MakeEq. Variables (a : foo@{i}) (b : foo@{j}). - Let t := $(let ty := type of b in exact ty)$. + Let t := ltac:(let ty := type of b in exact ty). Definition make_eq (x:=b) := a : t. End MakeEq. diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v index 63d5c7a57b..dcf5394eaf 100644 --- a/test-suite/bugs/closed/3347.v +++ b/test-suite/bugs/closed/3347.v @@ -1,7 +1,7 @@ Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *) Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. Inductive Unit : Type1 := tt : Unit. Fail Check Unit : Set. (* [Check Unit : Set] should fail if [Type1] is defined correctly *) diff --git a/test-suite/bugs/closed/3354.v b/test-suite/bugs/closed/3354.v index 14b66db362..a635285f2c 100644 --- a/test-suite/bugs/closed/3354.v +++ b/test-suite/bugs/closed/3354.v @@ -1,5 +1,5 @@ Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive Empty : Type1 := . Fail Check Empty : Set. (* Toplevel input, characters 15-116: diff --git a/test-suite/bugs/closed/3467.v b/test-suite/bugs/closed/3467.v index 7e37116249..88ae030578 100644 --- a/test-suite/bugs/closed/3467.v +++ b/test-suite/bugs/closed/3467.v @@ -1,5 +1,5 @@ Module foo. - Notation x := $(exact I)$. + Notation x := ltac:(exact I). End foo. Module bar. Include foo. diff --git a/test-suite/bugs/closed/3487.v b/test-suite/bugs/closed/3487.v index 03c60a8baa..1321a8598c 100644 --- a/test-suite/bugs/closed/3487.v +++ b/test-suite/bugs/closed/3487.v @@ -1,4 +1,4 @@ -Notation bar := $(exact I)$. +Notation bar := ltac:(exact I). Notation foo := bar (only parsing). Class baz := { x : False }. Instance: baz. diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v index 2a282d221f..9d37d1a2d0 100644 --- a/test-suite/bugs/closed/3682.v +++ b/test-suite/bugs/closed/3682.v @@ -3,4 +3,4 @@ Class Foo. Definition bar `{Foo} (x : Set) := Set. Instance: Foo. Definition bar1 := bar nat. -Definition bar2 := bar $(admit)$. +Definition bar2 := bar ltac:(admit). diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v index f7b137386b..130d57779d 100644 --- a/test-suite/bugs/closed/3684.v +++ b/test-suite/bugs/closed/3684.v @@ -1,5 +1,5 @@ Require Import TestSuite.admit. Definition foo : Set. Proof. - refine ($(abstract admit)$). + refine (ltac:(abstract admit)). Qed. diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index df9f5f4761..c24173abf1 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -18,7 +18,7 @@ Top.8} Top.6 Top.7 Top.8 |= *) *) -Definition bar := $(let t := eval compute in foo in exact t)$. +Definition bar := ltac:(let t := eval compute in foo in exact t). Check @bar. (* bar@{Top.13 Top.14 Top.15 Top.16} : Type@{Top.16+1} diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index 4408ab885d..070d1e9c71 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -8,7 +8,7 @@ Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Notation "A -> B" := (forall (_ : A), B) : type_scope. Axiom admit : forall {T}, T. Notation "g 'o' f" := (fun x => g (f x)) (at level 40, left associativity). -Notation "g 'o' f" := $(let g' := g in let f' := f in exact (fun x => g' (f' x)))$ (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) +Notation "g 'o' f" := ltac:(let g' := g in let f' := f in exact (fun x => g' (f' x))) (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) Inductive eq {A} (x:A) : A -> Prop := eq_refl : x = x where "x = y" := (@eq _ x y) : type_scope. Arguments eq_refl {_ _}. Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with eq_refl => eq_refl end. diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v index db3b60edae..017780c1f3 100644 --- a/test-suite/bugs/closed/HoTT_coq_077.v +++ b/test-suite/bugs/closed/HoTT_coq_077.v @@ -30,7 +30,7 @@ Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B) (p : prod A B) : P p := u (fst p) (snd p). -Notation typeof x := ($(let T := type of x in exact T)$) (only parsing). +Notation typeof x := (ltac:(let T := type of x in exact T)) (only parsing). (* Check for eta *) Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect'). diff --git a/test-suite/bugs/closed/HoTT_coq_114.v b/test-suite/bugs/closed/HoTT_coq_114.v index 341128338e..3535e6c41f 100644 --- a/test-suite/bugs/closed/HoTT_coq_114.v +++ b/test-suite/bugs/closed/HoTT_coq_114.v @@ -1 +1 @@ -Inductive test : $(let U := type of Type in exact U)$ := t. +Inductive test : ltac:(let U := type of Type in exact U) := t. diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v index 9e7d1eb5dd..33c408a28c 100644 --- a/test-suite/bugs/opened/3248.v +++ b/test-suite/bugs/opened/3248.v @@ -3,7 +3,7 @@ Ltac ret_and_left f := let T := type of f in lazymatch eval hnf in T with | ?T' -> _ => - let ret := constr:(fun x' : T' => $(tac (f x'))$) in + let ret := constr:(fun x' : T' => ltac:(tac (f x'))) in exact ret | ?T' => exact f end. @@ -12,6 +12,6 @@ Goal forall A B : Prop, forall x y : A, True. Proof. intros A B x y. pose (f := fun (x y : A) => conj x y). - pose (a := $(ret_and_left f)$). + pose (a := ltac:(ret_and_left f)). Fail unify (a x y) (conj x y). Abort. diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v index 19ed787d1e..5f4231363a 100644 --- a/test-suite/bugs/opened/3277.v +++ b/test-suite/bugs/opened/3277.v @@ -4,4 +4,4 @@ Goal True. evarr _. Admitted. Goal True. - Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *) + Fail exact ltac:(evarr _). (* Error: Cannot infer this placeholder. *) diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v index ced535afd5..1c6deae94b 100644 --- a/test-suite/bugs/opened/3278.v +++ b/test-suite/bugs/opened/3278.v @@ -1,8 +1,8 @@ Module a. Check let x' := _ in - $(exact x')$. + ltac:(exact x'). - Notation foo x := (let x' := x in $(exact x')$). + Notation foo x := (let x' := x in ltac:(exact x')). Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: @@ -12,10 +12,10 @@ x' := ?42 : ?41 End a. Module b. - Notation foo x := (let x' := x in let y := ($(exact I)$ : True) in I). + Notation foo x := (let x' := x in let y := (ltac:(exact I) : True) in I). Notation bar x := (let x' := x in let y := (I : True) in I). - Check let x' := _ in $(exact I)$. (* let x' := ?5 in I *) + Check let x' := _ in ltac:(exact I). (* let x' := ?5 in I *) Check bar _. (* let x' := ?9 in let y := I in I *) Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v index 529cc737df..66668930c7 100644 --- a/test-suite/bugs/opened/3304.v +++ b/test-suite/bugs/opened/3304.v @@ -1,3 +1,3 @@ -Fail Notation "( x , y , .. , z )" := $(let r := constr:(prod .. (prod x y) .. z) in r)$. +Fail Notation "( x , y , .. , z )" := ltac:(let r := constr:(prod .. (prod x y) .. z) in r). (* The command has indeed failed with message: => Error: Special token .. is for use in the Notation command. *) diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v index 9e6107b30a..762611f751 100644 --- a/test-suite/bugs/opened/3459.v +++ b/test-suite/bugs/opened/3459.v @@ -7,9 +7,9 @@ Proof. (* This line used to fail with a Not_found up to some point, and then to produce an ill-typed term *) match goal with - | [ |- context G[2] ] => let y := constr:(fun x => $(let r := constr:(@eq Set x x) in + | [ |- context G[2] ] => let y := constr:(fun x => ltac:(let r := constr:(@eq Set x x) in clear x; - exact r)$) in + exact r)) in pose y end. (* Add extra test for typability (should not fail when bug closed) *) diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index d6bbfe29ac..878875bd92 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -242,7 +242,7 @@ Fail Check (Prop : Set). Fail Check (Set : Set). Check (Set : Type). Check (Prop : Type). -Definition setType := $(let t := type of Set in exact t)$. +Definition setType := ltac:(let t := type of Set in exact t). Definition foo (A : Prop) := A. @@ -303,7 +303,7 @@ Set Printing Universes. Axiom admit : forall A, A. Record R := {O : Type}. -Definition RL (x : R@{i}) : $(let u := constr:(Type@{i}:Type@{j}) in exact (R@{j}) )$ := {|O := @O x|}. +Definition RL (x : R@{i}) : ltac:(let u := constr:(Type@{i}:Type@{j}) in exact (R@{j}) ) := {|O := @O x|}. Definition RLRL : forall x : R, RL x = RL (RL x) := fun x => eq_refl. Definition RLRL' : forall x : R, RL x = RL (RL x). intros. apply eq_refl. -- cgit v1.2.3 From 7a33a6284ba4e0953f82cf436fe324cdb95497e7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 12:10:29 +0100 Subject: Update history of revisions. --- dev/doc/versions-history.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index 1b1d3500a4..492e75a7bb 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -223,6 +223,7 @@ version & date & comments \\ Coq ``V6'' archive & 20 March 1996 & new cvs repository on pauillac.inria.fr with code ported \\ & & to Caml Special Light (to later become Objective Caml)\\ & & has implicit arguments and coercions\\ + & & has coinductive types\\ Coq V6.1beta& released 18 November 1996 & \feature{coercions} [23-5-1996], \feature{user-level implicit arguments} [23-5-1996]\\ & & \feature{omega} [10-9-1996] \\ -- cgit v1.2.3 From cc153dbbe45d5cf7f6ebfef6010adcc4f5bb568c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 15:18:42 +0100 Subject: Dead code from August 2014 in apply in. --- intf/tacexpr.mli | 2 +- parsing/g_tactic.ml4 | 2 +- printing/pptactic.ml | 3 +-- tactics/tacintern.ml | 4 ++-- tactics/tacinterp.ml | 8 ++++---- tactics/tactics.ml | 12 ++++++------ tactics/tactics.mli | 4 ++-- 7 files changed, 17 insertions(+), 18 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index eb4e5ae7d3..8c55a57051 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -136,7 +136,7 @@ type 'a gen_atomic_tactic_expr = | TacIntroMove of Id.t option * 'nam move_location | TacExact of 'trm | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - (clear_flag * 'nam * 'dtrm intro_pattern_expr located option) option + ('nam * 'dtrm intro_pattern_expr located option) option | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacFix of Id.t option * int diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index c94ac846f1..8e5e1f1fb8 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -399,7 +399,7 @@ GEXTEND Gram | -> [] ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (None,id,ipat) + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) | -> None ] ] ; orient: diff --git a/printing/pptactic.ml b/printing/pptactic.ml index a669aef9a8..bc559460e0 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -581,8 +581,7 @@ module Make let pr_in_hyp_as prc pr_id = function | None -> mt () - | Some (clear,id,ipat) -> - pr_in (spc () ++ pr_clear_flag clear pr_id id) ++ pr_as_ipat prc ipat + | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat let pr_clauses default_is_concl pr_id = function | { onhyps=Some []; concl_occs=occs } diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index fb22da83aa..1778221b02 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -400,8 +400,8 @@ let intern_red_expr ist = function | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r -let intern_in_hyp_as ist lf (clear,id,ipat) = - (clear,intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) let intern_hyp_list ist = List.map (intern_hyp ist) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index ee21a51598..693b382cac 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -902,9 +902,9 @@ let interp_intro_pattern_option ist env sigma = function let sigma, ipat = interp_intro_pattern ist env sigma ipat in sigma, Some ipat -let interp_in_hyp_as ist env sigma (clear,id,ipat) = +let interp_in_hyp_as ist env sigma (id,ipat) = let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in - sigma,(clear,interp_hyp ist env sigma id,ipat) + sigma,(interp_hyp ist env sigma id,ipat) let interp_quantified_hypothesis ist = function | AnonHyp n -> AnonHyp n @@ -1835,8 +1835,8 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma,tac = match cl with | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l | Some cl -> - let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev clear id l cl in + let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in + sigma, Tactics.apply_delayed_in a ev id l cl in Tacticals.New.tclWITHHOLES ev tac sigma end end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 8daa7c4b86..d4480ec922 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2287,7 +2287,7 @@ let assert_as first hd ipat t = (* apply in as *) let general_apply_in sidecond_first with_delta with_destruct with_evars - with_clear id lemmas ipat = + id lemmas ipat = let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in @@ -2312,12 +2312,12 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id) *) -let apply_in simple with_evars clear_flag id lemmas ipat = +let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, fun _ sigma -> sigma, l)) lemmas in - general_apply_in false simple simple with_evars clear_flag id lemmas ipat + general_apply_in false simple simple with_evars id lemmas ipat -let apply_delayed_in simple with_evars clear_flag id lemmas ipat = - general_apply_in false simple simple with_evars clear_flag id lemmas ipat +let apply_delayed_in simple with_evars id lemmas ipat = + general_apply_in false simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) @@ -4553,7 +4553,7 @@ module Simple = struct let case c = general_case_analysis false None (c,NoBindings) let apply_in id c = - apply_in false false None id [None,(Loc.ghost, (c, NoBindings))] None + apply_in false false id [None,(Loc.ghost, (c, NoBindings))] None end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index ade89fc989..b9a0184180 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -196,12 +196,12 @@ val eapply_with_bindings : constr with_bindings -> unit Proofview.tactic val cut_and_apply : constr -> unit Proofview.tactic val apply_in : - advanced_flag -> evars_flag -> clear_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * constr with_bindings located) list -> intro_pattern option -> unit Proofview.tactic val apply_delayed_in : - advanced_flag -> evars_flag -> clear_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * delayed_open_constr_with_bindings located) list -> intro_pattern option -> unit Proofview.tactic -- cgit v1.2.3 From 6ab4479dfa0f9b8fd4df4342fdfdab6c25b62fb7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 12:10:53 +0100 Subject: Improving syntax of pat/constr introduction pattern so that pat/c1/.../cn behaves as intro H; apply c1, ... , cn in H as pat. Open to other suggestions of syntax though. --- doc/refman/RefMan-tac.tex | 11 +++++++---- parsing/g_tactic.ml4 | 10 ++++++++-- test-suite/success/intros.v | 9 +++++++++ 3 files changed, 24 insertions(+), 6 deletions(-) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 1551b8eefd..03c4f6a365 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -828,7 +828,9 @@ either: \item a pattern for decomposing an equality: {\tt [= $p_1$ \dots\ $p_n$]} \item the rewriting orientations: {\tt ->} or {\tt <-} \end{itemize} - \item the on-the-fly application of a lemma: $p${\tt /{\term}} + \item the on-the-fly application of lemmas: $p${\tt /{\term$_1$}} + \ldots {\tt /{\term$_n$}} where $p$ itself is not an on-the-fly + application of lemmas pattern \end{itemize} \item the wildcard: {\tt \_} \end{itemize} @@ -896,9 +898,10 @@ introduction pattern~$p$: itself is erased; if the term to substitute is a variable, it is substituted also in the context of goal and the variable is removed too; -\item introduction over a pattern $p${\tt /{\term}} first applies - {\term} on the hypothesis to be introduced (as in {\tt apply - }{\term} {\tt in}), prior to the application of the introduction +\item introduction over a pattern $p${\tt /{\term$_1$}} \ldots {\tt + /{\term$_n$}} first applies {\term$_1$},\ldots, {\term$_n$} on the + hypothesis to be introduced (as in {\tt apply }{\term}$_1$, \ldots, + {\term}$_n$ {\tt in}), prior to the application of the introduction pattern $p$; \item introduction on the wildcard depends on whether the product is dependent or not: in the non-dependent case, it erases the diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 8e5e1f1fb8..b7559a1989 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -296,11 +296,17 @@ GEXTEND Gram | "**" -> !@loc, IntroForthcoming false ]] ; simple_intropattern: + [ [ pat = simple_intropattern_closed; l = LIST0 ["/"; c = constr -> c] -> + let loc0,pat = pat in + let f c pat = + let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in + IntroAction (IntroApplyOn (c,(loc,pat))) in + !@loc, List.fold_right f l pat ] ] + ; + simple_intropattern_closed: [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) | pat = equality_intropattern -> !@loc, IntroAction pat | "_" -> !@loc, IntroAction IntroWildcard - | pat = simple_intropattern; "/"; c = constr -> - !@loc, IntroAction (IntroApplyOn (c,pat)) | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] ; simple_binding: diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 35ba94fb67..741f372ff2 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -69,3 +69,12 @@ intros H (H1,?)/H. change (1=1) in H0. exact H1. Qed. + +(* Checking iterated pat/c1.../cn introduction patterns and side conditions *) + +Goal forall A B C D:Prop, (A -> B -> C) -> (C -> D) -> B -> A -> D. +intros * H H0 H1. +intros H2/H/H0. +- exact H2. +- exact H1. +Qed. -- cgit v1.2.3 From a80351f98adeada2b9219679de130e28c1b41479 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 14:04:33 +0100 Subject: Slight simplification of code for pat/constr. --- tactics/tactics.ml | 16 +++------------- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d4480ec922..3e6cea5ddd 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2216,19 +2216,9 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with Proofview.tclUNIT () (* apply_in_once do a replacement *) else Proofview.V82.tactic (clear [id]) in - Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let env = Proofview.Goal.env gl in - let sigma,c = f env sigma in - Tacticals.New.tclWITHHOLES false - (Tacticals.New.tclTHENFIRST - (* Skip the side conditions of the apply *) - (apply_in_once false true true true naming id - (None,(sigma,(c,NoBindings))) - (fun id -> Tacticals.New.tclTHEN doclear (tac_ipat id))) - (tac thin None [])) - sigma - end + let f env sigma = let (sigma,c) = f env sigma in (sigma,(c,NoBindings)) in + apply_in_delayed_once false true true true naming id (None,(loc,f)) + (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc dft destopt = function | IntroNaming ipat -> -- cgit v1.2.3 From 6316e8b380a9942cd587f250eb4a69668e52019e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 18:24:03 +0100 Subject: Adding a target report to test-suite's Makefile to get a short summary. --- Makefile.build | 2 +- test-suite/Makefile | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/Makefile.build b/Makefile.build index 0455a247bd..98ef81f38c 100644 --- a/Makefile.build +++ b/Makefile.build @@ -494,7 +494,7 @@ check: validate test-suite test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all - $(HIDE)if grep -F 'Error!' test-suite/summary.log ; then false; fi + $(MAKE) $(MAKE_TSOPTS) report ################################################################## # partial targets: 1) core ML parts diff --git a/test-suite/Makefile b/test-suite/Makefile index 31b2129001..7150d1fd4f 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -154,6 +154,9 @@ summary.log: $(SHOW) SUMMARY $(HIDE)$(MAKE) --quiet summary > "$@" +report: summary.log + $(HIDE)if grep -F 'Error!' summary.log ; then false; fi + ####################################################################### # Regression (and progression) tests ####################################################################### -- cgit v1.2.3 From fbb0d3151820517dee2f8e467435a6f045efbee0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 2 Dec 2015 14:36:10 +0100 Subject: Removing the use of tacticIn in Tauto. --- tactics/tacinterp.mli | 2 -- tactics/tauto.ml4 | 74 ++++++++++++++++++++++++++++++++++++--------------- 2 files changed, 53 insertions(+), 23 deletions(-) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 05fbd67cba..60f1a47492 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -46,8 +46,6 @@ val extract_ltac_constr_values : interp_sign -> Environ.env -> a [constr]. *) (** To embed several objects in Coqast.t *) -val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t - val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 9bee7ab3ed..a96adcca8a 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -52,6 +52,13 @@ type tauto_flags = { strict_unit : bool; } +let wit_tauto_flags : tauto_flags uniform_genarg_type = + Genarg.create_arg None "tauto_flags" + +let assoc_flags ist = + let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in + try Genarg.out_gen (topwit wit_tauto_flags) v with _ -> assert false + (* Whether inner not are unfolded *) let negation_unfolding = ref true @@ -85,21 +92,38 @@ let make_lfun l = let fold accu (id, v) = Id.Map.add (Id.of_string id) v accu in List.fold_left fold Id.Map.empty l +let tacticIn tac name = + let open Tacexpr in + let name = { mltac_plugin = "tauto"; mltac_tactic = name; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let tac _ ist = + let avoid = Option.default [] (TacStore.get ist.extra f_avoid_ids) in + let debug = Option.default Tactic_debug.DebugOff (TacStore.get ist.extra f_debug) in + interp_tac_gen ist.lfun avoid debug (tac ist) + in + Tacenv.register_ml_tactic name [| tac |]; + TacML (Loc.ghost, entry, []) + let is_empty ist = if is_empty_type (assoc_var "X1" ist) then <:tactic> else <:tactic> +let t_is_empty = tacticIn is_empty "is_empty" + (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) -let is_unit_or_eq flags ist = +let is_unit_or_eq ist = + let flags = assoc_flags ist in let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in if test (assoc_var "X1" ist) then <:tactic> else <:tactic> +let t_is_unit_or_eq = tacticIn is_unit_or_eq "is_unit_or_eq" + let is_record t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with @@ -122,7 +146,8 @@ let iter_tac tacl = (** Dealing with conjunction *) -let is_conj flags ist = +let is_conj ist = + let flags = assoc_flags ist in let ind = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && is_conjunction @@ -133,7 +158,10 @@ let is_conj flags ist = else <:tactic> -let flatten_contravariant_conj flags ist = +let t_is_conj = tacticIn is_conj "is_conj" + +let flatten_contravariant_conj ist = + let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in @@ -156,6 +184,9 @@ let flatten_contravariant_conj flags ist = | _ -> <:tactic> +let t_flatten_contravariant_conj = + tacticIn flatten_contravariant_conj "flatten_contravariant_conj" + (** Dealing with disjunction *) let constructor i = @@ -165,7 +196,8 @@ let constructor i = let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in Tacexpr.TacML (Loc.ghost, name, [i]) -let is_disj flags ist = +let is_disj ist = + let flags = assoc_flags ist in let t = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && is_disjunction @@ -176,7 +208,10 @@ let is_disj flags ist = else <:tactic> -let flatten_contravariant_disj flags ist = +let t_is_disj = tacticIn is_disj "is_disj" + +let flatten_contravariant_disj ist = + let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in let hyp = assoc_var "id" ist in @@ -197,6 +232,8 @@ let flatten_contravariant_disj flags ist = | _ -> <:tactic> +let t_flatten_contravariant_disj = + tacticIn flatten_contravariant_disj "flatten_contravariant_disj" (** Main tactic *) @@ -207,9 +244,9 @@ let not_dep_intros ist = | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro end >> -let axioms flags ist = - let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags) - and t_is_empty = tacticIn is_empty in +let t_not_dep_intros = tacticIn not_dep_intros "not_dep_intros" + +let axioms ist = let c1 = constructor 1 in <:tactic< match reverse goal with @@ -218,14 +255,9 @@ let axioms flags ist = | _:?X1 |- ?X1 => assumption end >> +let t_axioms = tacticIn axioms "axioms" -let simplif flags ist = - let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags) - and t_is_conj = tacticIn (is_conj flags) - and t_flatten_contravariant_conj = tacticIn (flatten_contravariant_conj flags) - and t_flatten_contravariant_disj = tacticIn (flatten_contravariant_disj flags) - and t_is_disj = tacticIn (is_disj flags) - and t_not_dep_intros = tacticIn not_dep_intros in +let simplif ist = let c1 = constructor 1 in <:tactic< $t_not_dep_intros; @@ -262,11 +294,11 @@ let simplif flags ist = end; $t_not_dep_intros) >> -let rec tauto_intuit flags t_reduce solver = - let t_axioms = tacticIn (axioms flags) - and t_simplif = tacticIn (simplif flags) - and t_is_disj = tacticIn (is_disj flags) in - let lfun = make_lfun [("t_solver", solver)] in +let t_simplif = tacticIn simplif "simplif" + +let tauto_intuit flags t_reduce solver = + let flags = Genarg.in_gen (topwit wit_tauto_flags) flags in + let lfun = make_lfun [("t_solver", solver); ("tauto_flags", flags)] in let ist = { default_ist () with lfun = lfun; } in let vars = [Id.of_string "t_solver"] in (vars, ist, <:tactic< @@ -303,7 +335,7 @@ let reduction_not_iff _ist = | false, true -> <:tactic< unfold Coq.Init.Logic.iff in * >> | false, false -> <:tactic< idtac >> -let t_reduction_not_iff = tacticIn reduction_not_iff +let t_reduction_not_iff = tacticIn reduction_not_iff "reduction_not_iff" let intuition_gen ist flags tac = Proofview.Goal.enter { enter = begin fun gl -> -- cgit v1.2.3 From f5a752261f210e9c5ecbbbf54886904f0856975a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Dec 2015 14:11:14 +0100 Subject: Removing the last use of tacticIn in setoid_ring. --- plugins/setoid_ring/newring.ml | 33 ++++++++++++++++++++++----------- tactics/tacinterp.ml | 6 ------ tactics/tacinterp.mli | 1 - 3 files changed, 22 insertions(+), 18 deletions(-) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 142257bc80..afee6ff60d 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -198,20 +198,31 @@ let constr_of v = match Value.to_constr v with | Some c -> c | None -> failwith "Ring.exec_tactic: anomaly" +let tactic_res = ref [||] + +let get_res = + let open Tacexpr in + let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let tac args ist = + let n = Genarg.out_gen (Genarg.topwit Stdarg.wit_int) (List.hd args) in + let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in + tactic_res := Array.init n init; + Proofview.tclUNIT () + in + Tacenv.register_ml_tactic name [| tac |]; + entry + let exec_tactic env evd n f args = + let args = List.map carg args in let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in - let res = ref [||] in - let get_res ist = - let l = List.map (fun id -> Id.Map.find id ist.lfun) lid in - res := Array.of_list l; - TacId[] in - let getter = - Tacexp(TacFun(List.map(fun id -> Some id) lid, - Tacintern.glob_tactic(tacticIn get_res))) in + let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in + let get_res = TacML (Loc.ghost, get_res, [n]) in + let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in - Array.map (fun x -> nf (constr_of x)) !res, snd (Evd.universe_context evd) + Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -652,7 +663,7 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = let rk = reflect_coeff morphth in let params,ctx = exec_tactic env !evd 5 (zltac "ring_lemmas") - (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in + [sth;ext;rth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -937,7 +948,7 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power let rk = reflect_coeff morphth in let params,ctx = exec_tactic env !evd 9 (field_ltac"field_lemmas") - (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in + [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in let lemma3 = params.(5) in diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 2597606aa1..1928b44b47 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -2389,12 +2389,6 @@ let interp_redexp env sigma r = (* Embed tactics in raw or glob tactic expr *) let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t)) -let tacticIn t = - globTacticIn (fun ist -> - try glob_tactic (t ist) - with e when Errors.noncritical e -> anomaly ~label:"tacticIn" - (str "Incorrect tactic expression. Received exception is:" ++ - Errors.print e)) (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 60f1a47492..60c9dc43e4 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -46,7 +46,6 @@ val extract_ltac_constr_values : interp_sign -> Environ.env -> a [constr]. *) (** To embed several objects in Coqast.t *) -val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg -- cgit v1.2.3 From 281bed69ee7d4a7638d07f07f9d6722b897f29cc Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 3 Dec 2015 14:59:27 +0100 Subject: Improving over printing of let-tuple (see #4447). For instance, #4447 is now printed: λ Ca Da : ℕAlg, let (ℕ, ℕ0) := (Ca, Da) in let (C, p) := ℕ in let (c₀, cs) := p in let (D, p0) := ℕ0 in let (d₀, ds) := p0 in {h : C → D & ((h c₀ = d₀) * (∀ c : C, h (cs c) = ds (h c)))%type} : ℕAlg → ℕAlg → Type --- printing/ppconstr.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index ea705e335e..663b8b8101 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -638,13 +638,13 @@ end) = struct | CLetTuple (_,nal,(na,po),c,b) -> return ( hv 0 ( - keyword "let" ++ spc () ++ - hov 0 (str "(" ++ + hov 2 (keyword "let" ++ spc () ++ + hov 1 (str "(" ++ prlist_with_sep sep_v pr_lname nal ++ str ")" ++ - pr_simple_return_type (pr mt) na po ++ str " :=" ++ - pr spc ltop c ++ spc () - ++ keyword "in") ++ + pr_simple_return_type (pr mt) na po ++ str " :=") ++ + pr spc ltop c + ++ keyword " in") ++ pr spc ltop b), lletin ) -- cgit v1.2.3 From f41968d8c240db4653d0b9fe76e1646cd7c6fb68 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 3 Dec 2015 19:08:51 +0100 Subject: Univs: fix bug #4443. Do not substitute rigid variables during minimization, keeping their equality constraints instead. --- library/universes.ml | 18 ++++++++++++------ test-suite/bugs/closed/4443.v | 31 +++++++++++++++++++++++++++++++ 2 files changed, 43 insertions(+), 6 deletions(-) create mode 100644 test-suite/bugs/closed/4443.v diff --git a/library/universes.ml b/library/universes.ml index a8e9478e13..3eae612c8c 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -205,7 +205,7 @@ let leq_constr_univs_infer univs m n = else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in if Univ.check_leq univs u1 u2 then - ((if Univ.is_small_univ u1 then + ((if Univ.is_type0_univ u1 then cstrs := Constraints.add (u1, ULe, u2) !cstrs); true) else @@ -904,22 +904,28 @@ let normalize_context_set ctx us algs = let noneqs = Constraint.union noneqs smallles in let partition = UF.partition uf in let flex x = LMap.mem x us in - let ctx, subst, eqs = List.fold_left (fun (ctx, subst, cstrs) s -> + let ctx, subst, us, eqs = List.fold_left (fun (ctx, subst, us, cstrs) s -> let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in (* Add equalities for globals which can't be merged anymore. *) let cstrs = LSet.fold (fun g cst -> Constraint.add (canon, Univ.Eq, g) cst) global cstrs in + (* Also add equalities for rigid variables *) + let cstrs = LSet.fold (fun g cst -> + Constraint.add (canon, Univ.Eq, g) cst) rigid + cstrs + in let subst = LSet.fold (fun f -> LMap.add f canon) rigid subst in - let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in - (LSet.diff (LSet.diff ctx rigid) flexible, subst, cstrs)) - (ctx, LMap.empty, Constraint.empty) partition + let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in + let canonu = Some (Universe.make canon) in + let us = LSet.fold (fun f -> LMap.add f canonu) flexible us in + (LSet.diff ctx flexible, subst, us, cstrs)) + (ctx, LMap.empty, us, Constraint.empty) partition in (* Noneqs is now in canonical form w.r.t. equality constraints, and contains only inequality constraints. *) let noneqs = subst_univs_level_constraints subst noneqs in - let us = LMap.fold (fun u v acc -> LMap.add u (Some (Universe.make v)) acc) subst us in (* Compute the left and right set of flexible variables, constraints mentionning other variables remain in noneqs. *) let noneqs, ucstrsl, ucstrsr = diff --git a/test-suite/bugs/closed/4443.v b/test-suite/bugs/closed/4443.v new file mode 100644 index 0000000000..66dfa0e685 --- /dev/null +++ b/test-suite/bugs/closed/4443.v @@ -0,0 +1,31 @@ +Set Universe Polymorphism. + +Record TYPE@{i} := cType { + type : Type@{i}; +}. + +Definition PROD@{i j k} + (A : Type@{i}) + (B : A -> Type@{j}) + : TYPE@{k}. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + +Local Unset Strict Universe Declaration. +Definition PRODinj + (A : Type@{i}) + (B : A -> Type) + : TYPE. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + + Monomorphic Universe i j. + Monomorphic Constraint j < i. +Set Printing Universes. +Check PROD@{i i i}. +Check PRODinj@{i j}. +Fail Check PRODinj@{j i}. \ No newline at end of file -- cgit v1.2.3 From f135a3967ca3d22bdc5566a54f042ba5bd6a343c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Dec 2015 20:10:26 +0100 Subject: Fixing Tauto compilation for older versions of OCaml. --- tactics/tauto.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index a96adcca8a..a3894a9134 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -14,6 +14,7 @@ open Names open Pp open Genarg open Stdarg +open Tacexpr open Tacinterp open Tactics open Errors @@ -93,7 +94,6 @@ let make_lfun l = List.fold_left fold Id.Map.empty l let tacticIn tac name = - let open Tacexpr in let name = { mltac_plugin = "tauto"; mltac_tactic = name; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac _ ist = -- cgit v1.2.3 From 3e0643a4073c02767f44c0b77019a0e183e1e296 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Dec 2015 20:30:49 +0100 Subject: Removing the globTacticIn primitive. It was not used in Coq codebase, and the only known user was ssreflect up to commit 95354e0dee. --- tactics/tacintern.ml | 2 +- tactics/tacinterp.ml | 13 +------------ tactics/tacinterp.mli | 1 - tactics/tacsubst.ml | 2 +- 4 files changed, 3 insertions(+), 15 deletions(-) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 1778221b02..23e7b85a6c 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -710,7 +710,7 @@ and intern_tacarg strict onlytac ist = function let (_, arg) = Genintern.generic_intern ist arg in TacGeneric arg | TacDynamic(loc,t) as x -> - if Dyn.has_tag t "tactic" || Dyn.has_tag t "value" then x + if Dyn.has_tag t "value" then x else if Dyn.has_tag t "constr" then if onlytac then error_tactic_expected loc else x else diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index f1fd526082..922dc2bc41 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -212,10 +212,6 @@ let constr_of_id env id = (* To embed tactics *) -let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t), - (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) = - Dyn.create "tactic" - let ((value_in : value -> Dyn.t), (value_out : Dyn.t -> value)) = Dyn.create "value" @@ -1459,9 +1455,7 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = | Tacexp t -> val_interp ist t | TacDynamic(_,t) -> let tg = (Dyn.tag t) in - if String.equal tg "tactic" then - val_interp ist (tactic_out t ist) - else if String.equal tg "value" then + if String.equal tg "value" then Ftactic.return (value_out t) else if String.equal tg "constr" then Ftactic.return (Value.of_constr (constr_out t)) @@ -2385,11 +2379,6 @@ let interp_redexp env sigma r = let gist = { fully_empty_glob_sign with genv = env; } in interp_red_expr ist env sigma (intern_red_expr gist r) -(***************************************************************************) -(* Embed tactics in raw or glob tactic expr *) - -let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t)) - (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 60c9dc43e4..c7364ee62d 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -46,7 +46,6 @@ val extract_ltac_constr_values : interp_sign -> Environ.env -> a [constr]. *) (** To embed several objects in Coqast.t *) -val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg (** Sets the debugger mode *) diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index afffaffbe9..8e46e625f3 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -268,7 +268,7 @@ and subst_tacarg subst = function | TacGeneric arg -> TacGeneric (Genintern.generic_substitute subst arg) | TacDynamic(the_loc,t) as x -> (match Dyn.tag t with - | "tactic" | "value" -> x + | "value" -> x | "constr" -> TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t))) | s -> Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp" -- cgit v1.2.3 From 0021067bf7fbb7c1583b8d167829f00c4b2f9977 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Dec 2015 22:29:30 +0100 Subject: Getting rid of dynamic hacks in Setoid_newring. --- plugins/setoid_ring/newring.ml | 46 ++++++++++++++++++++++++++++-------------- 1 file changed, 31 insertions(+), 15 deletions(-) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index afee6ff60d..2b07ba7044 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -179,16 +179,20 @@ let ltac_lcall tac args = let ltac_letin (x, e1) e2 = TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2) -let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) = - Tacinterp.eval_tactic +let ltac_apply (f:glob_tactic_expr) (args: Tacinterp.Value.t list) = + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar (Loc.ghost, id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + Tacinterp.eval_tactic_ist ist (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args)) let ltac_record flds = TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds) - -let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c) - let dummy_goal env sigma = let (gl,_,sigma) = Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in @@ -214,13 +218,21 @@ let get_res = entry let exec_tactic env evd n f args = - let args = List.map carg args in + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar (Loc.ghost, id)) in + (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in let get_res = TacML (Loc.ghost, get_res, [n]) in let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in + (** Evaluate the whole result *) let gl = dummy_goal env evd in - let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in + let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd) @@ -743,18 +755,22 @@ let make_term_list env evd carrier rl = (plapp evd coq_nil [|carrier|]) in Typing.solve_evars env evd l +let carg = Tacinterp.Value.of_constr +let tacarg expr = + Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr + let ltac_ring_structure e = let req = carg e.ring_req in let sth = carg e.ring_setoid in let ext = carg e.ring_ext in let morph = carg e.ring_morph in let th = carg e.ring_th in - let cst_tac = Tacexp e.ring_cst_tac in - let pow_tac = Tacexp e.ring_pow_tac in + let cst_tac = tacarg e.ring_cst_tac in + let pow_tac = tacarg e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in - let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in + let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in + let posttac = tacarg (TacFun([None],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] @@ -1018,15 +1034,15 @@ let process_field_mods l = let ltac_field_structure e = let req = carg e.field_req in - let cst_tac = Tacexp e.field_cst_tac in - let pow_tac = Tacexp e.field_pow_tac in + let cst_tac = tacarg e.field_cst_tac in + let pow_tac = tacarg e.field_pow_tac in let field_ok = carg e.field_ok in let field_simpl_ok = carg e.field_simpl_ok in let field_simpl_eq_ok = carg e.field_simpl_eq_ok in let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in - let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.field_post_tac)) in + let pretac = tacarg (TacFun([None],e.field_pre_tac)) in + let posttac = tacarg (TacFun([None],e.field_post_tac)) in [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] -- cgit v1.2.3 From 38e62610be0386a37172fa5aca44e3b3d2c14b9a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Dec 2015 00:09:50 +0100 Subject: Removing dynamic inclusion of constrs in tactic AST. --- pretyping/pretyping.ml | 4 ---- pretyping/pretyping.mli | 3 --- tactics/tacintern.ml | 2 -- tactics/tacinterp.ml | 2 -- tactics/tacsubst.ml | 2 -- 5 files changed, 13 deletions(-) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 78f134248c..ce6d189855 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -95,10 +95,6 @@ let search_guard loc env possible_indexes fixdefs = user_err_loc (loc,"search_guard", Pp.str errmsg) with Found indexes -> indexes) -(* To embed constr in glob_constr *) -let ((constr_in : constr -> Dyn.t), - (constr_out : Dyn.t -> constr)) = Dyn.create "constr" - (* To force universe name declaration before use *) let strict_universe_declarations = ref true diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 5f0e19cf2b..f8587d01cd 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -148,9 +148,6 @@ val ise_pretype_gen : (** To embed constr in glob_constr *) -val constr_in : constr -> Dyn.t -val constr_out : Dyn.t -> constr - val interp_sort : evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 23e7b85a6c..29f679e715 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -711,8 +711,6 @@ and intern_tacarg strict onlytac ist = function TacGeneric arg | TacDynamic(loc,t) as x -> if Dyn.has_tag t "value" then x - else if Dyn.has_tag t "constr" then - if onlytac then error_tactic_expected loc else x else let tag = Dyn.tag t in anomaly ~loc (str "Unknown dynamic: <" ++ str tag ++ str ">") diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 922dc2bc41..bb54a9cb7a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1457,8 +1457,6 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = let tg = (Dyn.tag t) in if String.equal tg "value" then Ftactic.return (value_out t) - else if String.equal tg "constr" then - Ftactic.return (Value.of_constr (constr_out t)) else Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp" (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">") diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 8e46e625f3..fd7eaafbc6 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -269,8 +269,6 @@ and subst_tacarg subst = function | TacDynamic(the_loc,t) as x -> (match Dyn.tag t with | "value" -> x - | "constr" -> - TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t))) | s -> Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp" (str "Unknown dynamic: <" ++ str s ++ str ">")) -- cgit v1.2.3 From 86304bddaff73bdc0f8aa6c7619d806c001040ec Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Dec 2015 11:16:36 +0100 Subject: Removing the last use of valueIn in Tauto. --- tactics/tauto.ml4 | 53 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 20 deletions(-) diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index a3894a9134..1080e76d03 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -93,17 +93,26 @@ let make_lfun l = let fold accu (id, v) = Id.Map.add (Id.of_string id) v accu in List.fold_left fold Id.Map.empty l -let tacticIn tac name = +let tacticIn_ist tac name = let name = { mltac_plugin = "tauto"; mltac_tactic = name; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac _ ist = let avoid = Option.default [] (TacStore.get ist.extra f_avoid_ids) in let debug = Option.default Tactic_debug.DebugOff (TacStore.get ist.extra f_debug) in - interp_tac_gen ist.lfun avoid debug (tac ist) + let (tac, ist) = tac ist in + interp_tac_gen ist.lfun avoid debug tac in Tacenv.register_ml_tactic name [| tac |]; TacML (Loc.ghost, entry, []) +let tacticIn tac name = + tacticIn_ist (fun ist -> tac ist, ist) name + +let push_ist ist args = + let fold accu (id, arg) = Id.Map.add (Id.of_string id) arg accu in + let lfun = List.fold_left fold ist.lfun args in + { ist with lfun } + let is_empty ist = if is_empty_type (assoc_var "X1" ist) then <:tactic> @@ -170,22 +179,21 @@ let flatten_contravariant_conj ist = ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let newtyp = valueIn (Value.of_constr (List.fold_right mkArrow args c)) in - let hyp = valueIn (Value.of_constr hyp) in + let newtyp = Value.of_constr (List.fold_right mkArrow args c) in + let hyp = Value.of_constr hyp in + let ist = push_ist ist [("newtyp", newtyp); ("hyp", hyp)] in let intros = iter_tac (List.map (fun _ -> <:tactic< intro >>) args) <:tactic< idtac >> in <:tactic< - let newtyp := $newtyp in - let hyp := $hyp in assert newtyp by ($intros; apply hyp; split; assumption); clear hyp - >> + >>, ist | _ -> - <:tactic> + <:tactic>, ist let t_flatten_contravariant_conj = - tacticIn flatten_contravariant_conj "flatten_contravariant_conj" + tacticIn_ist flatten_contravariant_conj "flatten_contravariant_conj" (** Dealing with disjunction *) @@ -220,20 +228,25 @@ let flatten_contravariant_disj ist = ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let hyp = valueIn (Value.of_constr hyp) in - iter_tac (List.map_i (fun i arg -> - let typ = valueIn (Value.of_constr (mkArrow arg c)) in - let ci = constructor i in - <:tactic< - let typ := $typ in - let hyp := $hyp in - assert typ by (intro; apply hyp; $ci; assumption) - >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >> + let hyp = Value.of_constr hyp in + let ist = push_ist ist ["hyp", hyp] in + let fold arg (i, ist, tacs) = + let typ = Value.of_constr (mkArrow arg c) in + let ist = push_ist ist ["typ" ^ string_of_int i, typ] in + let t = Id.of_string ("typ" ^ string_of_int i) in + let typ = Reference (Libnames.Ident (Loc.ghost, t)) in + let ci = constructor i in + let tac = <:tactic< let typ := $typ in assert typ by (intro; apply hyp; $ci; assumption) >> in + (pred i, ist, <:tactic< $tac; $tacs >>) + in + let tac0 = <:tactic< clear hyp >> in + let (_, ist, tac) = List.fold_right fold args (List.length args, ist, tac0) in + (tac, ist) | _ -> - <:tactic> + <:tactic>, ist let t_flatten_contravariant_disj = - tacticIn flatten_contravariant_disj "flatten_contravariant_disj" + tacticIn_ist flatten_contravariant_disj "flatten_contravariant_disj" (** Main tactic *) -- cgit v1.2.3 From 9ee4a02e9234ad6cebb3365881250d7539d00d03 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 4 Dec 2015 15:14:23 +0100 Subject: Fix in setoid_rewrite in Type: avoid the generation of a rigid universe on applications of inverse (flip) on a crelation. This was poluting universe constraints of lemmas using generalized rewriting in Type. --- tactics/rewrite.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 182c232ae9..a230ea251a 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -403,7 +403,7 @@ module TypeGlobal = struct let inverse env (evd,cstrs) car rel = - let evd, (sort,_) = Evarutil.new_type_evar env evd Evd.univ_flexible in + let evd, sort = Evarutil.new_Type ~rigid:Evd.univ_flexible env evd in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end -- cgit v1.2.3 From 0aba678e885fa53fa649de59eb1d06b4af3a847c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Dec 2015 20:42:07 +0100 Subject: Getting rid of the dynamic node of the tactic AST. --- intf/tacexpr.mli | 1 - printing/pptactic.ml | 3 --- tactics/tacintern.ml | 7 +------ tactics/tacinterp.ml | 21 +++++---------------- tactics/tacinterp.mli | 3 --- tactics/tacsubst.ml | 5 ----- 6 files changed, 6 insertions(+), 34 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 73130d3804..ead221c5fb 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -209,7 +209,6 @@ constraint 'a = < (** Possible arguments of a tactic definition *) and 'a gen_tactic_arg = - | TacDynamic of Loc.t * Dyn.t | TacGeneric of 'lev generic_argument | MetaIdArg of Loc.t * bool * string | ConstrMayEval of ('trm,'cst,'pat) may_eval diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 766222156a..97917d2c72 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1263,9 +1263,6 @@ module Make else str"(" ++ strm ++ str")" and pr_tacarg = function - | TacDynamic (loc,t) -> - pr_with_comments loc - (str "<" ++ keyword "dynamic" ++ str " [" ++ str (Dyn.tag t) ++ str "]>") | MetaIdArg (loc,true,s) -> pr_with_comments loc (str "$" ++ str s) | MetaIdArg (loc,false,s) -> diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 29f679e715..b5a3633715 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -672,7 +672,7 @@ and intern_tactic_seq onlytac ist = function and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with | TacCall _ | Reference _ - | TacDynamic _ | TacGeneric _ as a -> TacArg (loc,a) + | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a | ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> if onlytac then error_tactic_expected loc else TacArg (loc,a) @@ -709,11 +709,6 @@ and intern_tacarg strict onlytac ist = function | TacGeneric arg -> let (_, arg) = Genintern.generic_intern ist arg in TacGeneric arg - | TacDynamic(loc,t) as x -> - if Dyn.has_tag t "value" then x - else - let tag = Dyn.tag t in - anomaly ~loc (str "Unknown dynamic: <" ++ str tag ++ str ">") (* Reads the rules of a Match Context or a Match *) and intern_match_rule onlytac ist = function diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index bb54a9cb7a..850580f75d 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -86,7 +86,7 @@ type tacvalue = Id.t option list * glob_tactic_expr | VRec of value Id.Map.t ref * glob_tactic_expr -let (wit_tacvalue : (Empty.t, Empty.t, tacvalue) Genarg.genarg_type) = +let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = Genarg.create_arg None "tacvalue" let of_tacvalue v = in_gen (topwit wit_tacvalue) v @@ -210,13 +210,6 @@ let pr_inspect env expr result = let constr_of_id env id = Term.mkVar (let _ = Environ.lookup_named id env in id) -(* To embed tactics *) - -let ((value_in : value -> Dyn.t), - (value_out : Dyn.t -> value)) = Dyn.create "value" - -let valueIn t = TacDynamic (Loc.ghost, value_in t) - (** Generic arguments : table of interpretation functions *) let push_trace call ist = match TacStore.get ist.extra f_trace with @@ -1453,13 +1446,6 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = Proofview.tclUNIT (Value.of_int i) end | Tacexp t -> val_interp ist t - | TacDynamic(_,t) -> - let tg = (Dyn.tag t) in - if String.equal tg "value" then - Ftactic.return (value_out t) - else - Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp" - (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">") (* Interprets an application node *) and interp_app loc ist fv largs : typed_generic_argument Ftactic.t = @@ -2356,7 +2342,7 @@ let () = let () = let interp ist gl tac = let f = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - (project gl, TacArg (dloc, valueIn (of_tacvalue f))) + (project gl, TacArg (dloc, TacGeneric (Genarg.in_gen (glbwit wit_tacvalue) f))) in Geninterp.register_interp0 wit_tactic interp @@ -2365,6 +2351,9 @@ let () = project gl , interp_uconstr ist (pf_env gl) c ) +let () = + Geninterp.register_interp0 wit_tacvalue (fun ist gl c -> project gl, c) + (***************************************************************************) (* Other entry points *) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index c7364ee62d..88802bf350 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -45,9 +45,6 @@ val extract_ltac_constr_values : interp_sign -> Environ.env -> (** Given an interpretation signature, extract all values which are coercible to a [constr]. *) -(** To embed several objects in Coqast.t *) -val valueIn : value -> raw_tactic_arg - (** Sets the debugger mode *) val set_debug : debug_info -> unit diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index fd7eaafbc6..f5b6c3250d 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -266,11 +266,6 @@ and subst_tacarg subst = function | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (subst_tactic subst t) | TacGeneric arg -> TacGeneric (Genintern.generic_substitute subst arg) - | TacDynamic(the_loc,t) as x -> - (match Dyn.tag t with - | "value" -> x - | s -> Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp" - (str "Unknown dynamic: <" ++ str s ++ str ">")) (* Reads the rules of a Match Context or a Match *) and subst_match_rule subst = function -- cgit v1.2.3 From 153d77d00ccbacf22aa5d70ca2c1cacab2749339 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Dec 2015 21:46:12 +0100 Subject: Specializing the Dyn module to each usecase. Actually, we never mix the various uses of each dynamic type created through the Dyn module. To enforce this statically, we functorize the Dyn module so that we recover a fresh instance at each use point. --- lib/cSig.mli | 2 ++ lib/dyn.ml | 15 +++++++++++++++ lib/dyn.mli | 6 ++++++ lib/future.ml | 7 ++++--- lib/future.mli | 3 ++- library/libobject.ml | 4 ++++ library/libobject.mli | 4 ++++ library/summary.ml | 4 ++++ library/summary.mli | 4 ++++ stm/stm.ml | 5 ++--- 10 files changed, 47 insertions(+), 7 deletions(-) diff --git a/lib/cSig.mli b/lib/cSig.mli index 2a8bda2936..4463e8d9c6 100644 --- a/lib/cSig.mli +++ b/lib/cSig.mli @@ -45,3 +45,5 @@ sig end (** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml documentation for more information. *) + +module type EmptyS = sig end diff --git a/lib/dyn.ml b/lib/dyn.ml index 056b687313..60167ef1ba 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -9,6 +9,19 @@ open Errors open Pp +module type S = +sig +type t + +val create : string -> ('a -> t) * (t -> 'a) +val tag : t -> string +val has_tag : t -> string -> bool +val pointer_equal : t -> t -> bool +val dump : unit -> (int * string) list +end + +module Make(M : CSig.EmptyS) = +struct (* Dynamics, programmed with DANGER !!! *) type t = int * Obj.t @@ -48,3 +61,5 @@ let tag (s,_) = let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2 let dump () = Int.Map.bindings !dyntab + +end \ No newline at end of file diff --git a/lib/dyn.mli b/lib/dyn.mli index cac912aca1..55c4f0ce8f 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -8,6 +8,8 @@ (** Dynamics. Use with extreme care. Not for kids. *) +module type S = +sig type t val create : string -> ('a -> t) * (t -> 'a) @@ -15,3 +17,7 @@ val tag : t -> string val has_tag : t -> string -> bool val pointer_equal : t -> t -> bool val dump : unit -> (int * string) list +end + +(** FIXME: use OCaml 4.02 generative functors when available *) +module Make(M : CSig.EmptyS) : S diff --git a/lib/future.ml b/lib/future.ml index 78a158264b..b6012ed207 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -7,8 +7,9 @@ (************************************************************************) (* To deal with side effects we have to save/restore the system state *) -let freeze = ref (fun () -> assert false : unit -> Dyn.t) -let unfreeze = ref (fun _ -> () : Dyn.t -> unit) +type freeze +let freeze = ref (fun () -> assert false : unit -> freeze) +let unfreeze = ref (fun _ -> () : freeze -> unit) let set_freeze f g = freeze := f; unfreeze := g let not_ready_msg = ref (fun name -> @@ -58,7 +59,7 @@ type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computat and 'a comp = | Delegated of (unit -> unit) | Closure of (unit -> 'a) - | Val of 'a * Dyn.t option + | Val of 'a * freeze option | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = diff --git a/lib/future.mli b/lib/future.mli index adc15e49c7..29b71b70a8 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -157,10 +157,11 @@ val transactify : ('a -> 'b) -> 'a -> 'b (** Debug: print a computation given an inner printing function. *) val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds +type freeze (* These functions are needed to get rid of side effects. Thy are set for the outermos layer of the system, since they have to deal with the whole system state. *) -val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit +val set_freeze : (unit -> freeze) -> (freeze -> unit) -> unit val customize_not_ready_msg : (string -> Pp.std_ppcmds) -> unit val customize_not_here_msg : (string -> Pp.std_ppcmds) -> unit diff --git a/library/libobject.ml b/library/libobject.ml index 85c830ea2c..c638759070 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -9,6 +9,8 @@ open Libnames open Pp +module Dyn = Dyn.Make(struct end) + (* The relax flag is used to make it possible to load files while ignoring failures to incorporate some objects. This can be useful when one wants to work with restricted Coq programs that have only parts of @@ -158,3 +160,5 @@ let discharge_object ((_,lobj) as node) = let rebuild_object lobj = apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj + +let dump = Dyn.dump diff --git a/library/libobject.mli b/library/libobject.mli index 099381897f..e49f3fd5c6 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -109,3 +109,7 @@ val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj val relax : bool -> unit + +(** {6 Debug} *) + +val dump : unit -> (int * string) list diff --git a/library/summary.ml b/library/summary.ml index 8e2abbf15b..6ef4e131c7 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -10,6 +10,8 @@ open Pp open Errors open Util +module Dyn = Dyn.Make(struct end) + type marshallable = [ `Yes | `No | `Shallow ] type 'a summary_declaration = { freeze_function : marshallable -> 'a; @@ -176,3 +178,5 @@ let ref ?(freeze=fun _ r -> r) ~name x = unfreeze_function = ((:=) r); init_function = (fun () -> r := x) }; r + +let dump = Dyn.dump diff --git a/library/summary.mli b/library/summary.mli index 48c9390d07..a35113fd2e 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -71,3 +71,7 @@ val unfreeze_summary : frozen_bits -> unit val surgery_summary : frozen -> frozen_bits -> frozen val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits val pointer_equal : frozen_bits -> frozen_bits -> bool + +(** {6 Debug} *) + +val dump : unit -> (int * string) list diff --git a/stm/stm.ml b/stm/stm.ml index 6236297459..ea669b1596 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -631,10 +631,9 @@ end = struct (* {{{ *) States.unfreeze system; Proof_global.unfreeze proof (* hack to make futures functional *) - let in_t, out_t = Dyn.create "state4future" let () = Future.set_freeze - (fun () -> in_t (freeze_global_state `No, !cur_id)) - (fun t -> let s,i = out_t t in unfreeze_global_state s; cur_id := i) + (fun () -> Obj.magic (freeze_global_state `No, !cur_id)) + (fun t -> let s,i = Obj.magic t in unfreeze_global_state s; cur_id := i) type frozen_state = state type proof_part = -- cgit v1.2.3 From 05a710d636634b35d8147fe819d061e367f02591 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Dec 2015 22:19:09 +0100 Subject: Getting rid of some quoted tactics in Tauto. --- tactics/tauto.ml4 | 122 +++++++++++++++++++++++++++--------------------------- 1 file changed, 61 insertions(+), 61 deletions(-) diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 1080e76d03..415bbb2908 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -19,6 +19,7 @@ open Tacinterp open Tactics open Errors open Util +open Tacticals.New open Proofview.Notations DECLARE PLUGIN "tauto" @@ -87,23 +88,48 @@ let _ = optread = (fun () -> !iff_unfolding); optwrite = (:=) iff_unfolding } +(** Base tactics *) + +let idtac = Proofview.tclUNIT () +let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) + +let intro = Tactics.intro + +let assert_ ?by c = + let tac = match by with + | None -> None + | Some tac -> Some (tclCOMPLETE tac) + in + Proofview.tclINDEPENDENT (Tactics.forward true tac None c) + +let apply c = Tactics.apply c + +let clear id = Proofview.V82.tactic (fun gl -> Tactics.clear [id] gl) + +let assumption = Tactics.assumption + +let split = Tactics.split_with_bindings false [Misctypes.NoBindings] + (** Test *) let make_lfun l = let fold accu (id, v) = Id.Map.add (Id.of_string id) v accu in List.fold_left fold Id.Map.empty l -let tacticIn_ist tac name = +let register_tauto_tactic tac name = let name = { mltac_plugin = "tauto"; mltac_tactic = name; } in let entry = { mltac_name = name; mltac_index = 0 } in + Tacenv.register_ml_tactic name [| tac |]; + TacML (Loc.ghost, entry, []) + +let tacticIn_ist tac name = let tac _ ist = let avoid = Option.default [] (TacStore.get ist.extra f_avoid_ids) in let debug = Option.default Tactic_debug.DebugOff (TacStore.get ist.extra f_debug) in let (tac, ist) = tac ist in interp_tac_gen ist.lfun avoid debug tac in - Tacenv.register_ml_tactic name [| tac |]; - TacML (Loc.ghost, entry, []) + register_tauto_tactic tac name let tacticIn tac name = tacticIn_ist (fun ist -> tac ist, ist) name @@ -113,25 +139,19 @@ let push_ist ist args = let lfun = List.fold_left fold ist.lfun args in { ist with lfun } -let is_empty ist = - if is_empty_type (assoc_var "X1" ist) then - <:tactic> - else - <:tactic> +let is_empty _ ist = + if is_empty_type (assoc_var "X1" ist) then idtac else fail -let t_is_empty = tacticIn is_empty "is_empty" +let t_is_empty = register_tauto_tactic is_empty "is_empty" (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) -let is_unit_or_eq ist = +let is_unit_or_eq _ ist = let flags = assoc_flags ist in let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test (assoc_var "X1" ist) then - <:tactic> - else - <:tactic> + if test (assoc_var "X1" ist) then idtac else fail -let t_is_unit_or_eq = tacticIn is_unit_or_eq "is_unit_or_eq" +let t_is_unit_or_eq = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" let is_record t = let (hdapp,args) = decompose_app t in @@ -150,26 +170,21 @@ let bugged_is_binary t = Int.equal mib.Declarations.mind_nparams 2 | _ -> false -let iter_tac tacl = - List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl - (** Dealing with conjunction *) -let is_conj ist = +let is_conj _ ist = let flags = assoc_flags ist in let ind = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && is_conjunction ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode ind - then - <:tactic> - else - <:tactic> + then idtac + else fail -let t_is_conj = tacticIn is_conj "is_conj" +let t_is_conj = register_tauto_tactic is_conj "is_conj" -let flatten_contravariant_conj ist = +let flatten_contravariant_conj _ ist = let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in @@ -179,21 +194,14 @@ let flatten_contravariant_conj ist = ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let newtyp = Value.of_constr (List.fold_right mkArrow args c) in - let hyp = Value.of_constr hyp in - let ist = push_ist ist [("newtyp", newtyp); ("hyp", hyp)] in - let intros = - iter_tac (List.map (fun _ -> <:tactic< intro >>) args) - <:tactic< idtac >> in - <:tactic< - assert newtyp by ($intros; apply hyp; split; assumption); - clear hyp - >>, ist - | _ -> - <:tactic>, ist + let newtyp = List.fold_right mkArrow args c in + let intros = tclMAP (fun _ -> intro) args in + let by = tclTHENLIST [intros; apply hyp; split; assumption] in + tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] + | _ -> fail let t_flatten_contravariant_conj = - tacticIn_ist flatten_contravariant_conj "flatten_contravariant_conj" + register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" (** Dealing with disjunction *) @@ -204,21 +212,19 @@ let constructor i = let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in Tacexpr.TacML (Loc.ghost, name, [i]) -let is_disj ist = +let is_disj _ ist = let flags = assoc_flags ist in let t = assoc_var "X1" ist in if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && is_disjunction ~strict:flags.strict_in_hyp_and_ccl ~onlybinary:flags.binary_mode t - then - <:tactic> - else - <:tactic> + then idtac + else fail -let t_is_disj = tacticIn is_disj "is_disj" +let t_is_disj = register_tauto_tactic is_disj "is_disj" -let flatten_contravariant_disj ist = +let flatten_contravariant_disj _ ist = let flags = assoc_flags ist in let typ = assoc_var "X1" ist in let c = assoc_var "X2" ist in @@ -228,25 +234,19 @@ let flatten_contravariant_disj ist = ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let hyp = Value.of_constr hyp in - let ist = push_ist ist ["hyp", hyp] in - let fold arg (i, ist, tacs) = - let typ = Value.of_constr (mkArrow arg c) in - let ist = push_ist ist ["typ" ^ string_of_int i, typ] in - let t = Id.of_string ("typ" ^ string_of_int i) in - let typ = Reference (Libnames.Ident (Loc.ghost, t)) in - let ci = constructor i in - let tac = <:tactic< let typ := $typ in assert typ by (intro; apply hyp; $ci; assumption) >> in - (pred i, ist, <:tactic< $tac; $tacs >>) + let map i arg = + let typ = mkArrow arg c in + let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in + let by = tclTHENLIST [intro; apply hyp; ci; assumption] in + assert_ ~by typ in - let tac0 = <:tactic< clear hyp >> in - let (_, ist, tac) = List.fold_right fold args (List.length args, ist, tac0) in - (tac, ist) - | _ -> - <:tactic>, ist + let tacs = List.mapi map args in + let tac0 = clear (destVar hyp) in + tclTHEN (tclTHENLIST tacs) tac0 + | _ -> fail let t_flatten_contravariant_disj = - tacticIn_ist flatten_contravariant_disj "flatten_contravariant_disj" + register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" (** Main tactic *) -- cgit v1.2.3 From cbceffe424a6b4477eb822f3887776b587503cbd Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 00:42:24 +0100 Subject: Fix CHANGES. --- CHANGES | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/CHANGES b/CHANGES index 662b7b9a24..96f02bc27c 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,10 @@ +Changes from V8.5beta3 +====================== + +Specification language + +- Syntax "$(tactic)$" changed to "ltac:(tactic)". + Changes from V8.5beta2 to V8.5beta3 =================================== @@ -10,10 +17,6 @@ Vernacular commands introducing it. - New command "Show id" to show goal named id. -Specification language - -- Syntax "$(tactic)$" changed to "ltac: tactic". - Tactics - New flag "Regular Subst Tactic" which fixes "subst" in situations where -- cgit v1.2.3 From 387351b4c0ffeff65d8a7192f5073cfd4bd20f53 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 00:14:37 +0100 Subject: Changing "destruct !hyp" into "destruct (hyp)" (and similarly for induction) based on a suggestion of Guillaume M. (done like this in ssreflect). This is actually consistent with the hack of using "destruct (1)" to mean the term 1 by opposition to the use of "destruct 1" to mean the first non-dependent hypothesis of the goal. --- CHANGES | 5 +++++ doc/refman/RefMan-tac.tex | 47 ++++++++++++++++++------------------------- parsing/g_tactic.ml4 | 17 +++++++++++++++- test-suite/success/destruct.v | 2 +- 4 files changed, 42 insertions(+), 29 deletions(-) diff --git a/CHANGES b/CHANGES index 96f02bc27c..70ed1bef01 100644 --- a/CHANGES +++ b/CHANGES @@ -5,6 +5,11 @@ Specification language - Syntax "$(tactic)$" changed to "ltac:(tactic)". +Tactics + +- Syntax "destruct !hyp" changed to "destruct (hyp)", and similarly + for induction. + Changes from V8.5beta2 to V8.5beta3 =================================== diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 03c4f6a365..55b5f622ff 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -1531,25 +1531,27 @@ for each possible form of {\term}, i.e. one for each constructor of the inductive or co-inductive type. Unlike {\tt induction}, no induction hypothesis is generated by {\tt destruct}. -If the argument is dependent in either the conclusion or some -hypotheses of the goal, the argument is replaced by the appropriate -constructor form in each of the resulting subgoals, thus performing -case analysis. If non-dependent, the tactic simply exposes the -inductive or co-inductive structure of the argument. - There are special cases: \begin{itemize} \item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt destruct {\ident}} -behaves as {\tt intros until {\ident}; destruct {\ident}}. + variable of the conclusion of the goal, then {\tt destruct {\ident}} + behaves as {\tt intros until {\ident}; destruct {\ident}}. If + {\ident} is not anymore dependent in the goal after application of + {\tt destruct}, it is erased (to avoid erasure, use + parentheses, as in {\tt destruct ({\ident})}). \item If {\term} is a {\num}, then {\tt destruct {\num}} behaves as {\tt intros until {\num}} followed by {\tt destruct} applied to the last introduced hypothesis. Remark: For destruction of a numeral, use syntax {\tt destruct ({\num})} (not very interesting anyway). +\item In case {\term} is an hypothesis {\ident} of the context, + and {\ident} is not anymore dependent in the goal after + application of {\tt destruct}, it is erased (to avoid erasure, use + parentheses, as in {\tt destruct ({\ident})}). + \item The argument {\term} can also be a pattern of which holes are denoted by ``\_''. In this case, the tactic checks that all subterms matching the pattern in the conclusion and the hypotheses are @@ -1626,14 +1628,6 @@ syntax {\tt destruct ({\num})} (not very interesting anyway). They combine the effects of the {\tt with}, {\tt as}, {\tt eqn:}, {\tt using}, and {\tt in} clauses. -\item{\tt destruct !{\ident}} - - This is a case when the destructed term is an hypothesis of the - context. The ``!'' modifier tells to keep the hypothesis in the - context after destruction. - - This applies also to the other form of {\tt destruct} and {\tt edestruct}. - \item{\tt case \term}\label{case}\tacindex{case} The tactic {\tt case} is a more basic tactic to perform case @@ -1699,14 +1693,22 @@ There are particular cases: \begin{itemize} \item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt induction {\ident}} -behaves as {\tt intros until {\ident}; induction {\ident}}. + variable of the conclusion of the goal, then {\tt induction + {\ident}} behaves as {\tt intros until {\ident}; induction + {\ident}}. If {\ident} is not anymore dependent in the goal + after application of {\tt induction}, it is erased (to avoid + erasure, use parentheses, as in {\tt induction ({\ident})}). \item If {\term} is a {\num}, then {\tt induction {\num}} behaves as {\tt intros until {\num}} followed by {\tt induction} applied to the last introduced hypothesis. Remark: For simple induction on a numeral, use syntax {\tt induction ({\num})} (not very interesting anyway). +\item In case {\term} is an hypothesis {\ident} of the context, + and {\ident} is not anymore dependent in the goal after + application of {\tt induction}, it is erased (to avoid erasure, use + parentheses, as in {\tt induction ({\ident})}). + \item The argument {\term} can also be a pattern of which holes are denoted by ``\_''. In this case, the tactic checks that all subterms matching the pattern in the conclusion and the hypotheses are @@ -1821,15 +1823,6 @@ Show 2. einduction}. It combines the effects of the {\tt with}, {\tt as}, %%{\tt eqn:}, {\tt using}, and {\tt in} clauses. -\item{\tt induction !{\ident}} - - This is a case when the term on which to apply induction is an - hypothesis of the context. The ``!'' modifier tells to keep the - hypothesis in the context after induction. - - This applies also to the other form of {\tt induction} and {\tt - einduction}. - \item {\tt elim \term}\label{elim} This is a more basic induction tactic. Again, the type of the diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index b7559a1989..4d42dfe85a 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -44,6 +44,20 @@ let test_lpar_id_coloneq = | _ -> err ()) | _ -> err ()) +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = Gram.Entry.of_parser "test_lpar_idnum_coloneq" @@ -224,8 +238,9 @@ GEXTEND Gram ; induction_arg: [ [ n = natural -> (None,ElimOnAnonHyp n) + | test_lpar_id_rpar; c = constr_with_bindings -> + (Some false,induction_arg_of_constr c) | c = constr_with_bindings -> (None,induction_arg_of_constr c) - | "!"; c = constr_with_bindings -> (Some false,induction_arg_of_constr c) ] ] ; constr_with_bindings_arg: diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 59cd25cd76..9f091e3996 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -389,7 +389,7 @@ Abort. Goal forall b:bool, True. intro b. -destruct !b. +destruct (b). clear b. (* b has to be here *) Abort. -- cgit v1.2.3 From d1c4ea65c490b59d34a5464554237a270063cbc9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 19 Nov 2015 22:32:54 +0100 Subject: Ensuring that documentation of mli code works in the presence of utf-8 characters. --- Makefile.build | 7 +++++-- dev/ocamldoc/fix-ocamldoc-utf8 | 6 ++++++ dev/ocamldoc/header.tex | 14 ++++++++++++++ 3 files changed, 25 insertions(+), 2 deletions(-) create mode 100755 dev/ocamldoc/fix-ocamldoc-utf8 create mode 100644 dev/ocamldoc/header.tex diff --git a/Makefile.build b/Makefile.build index 37c8e4c674..a4e1587d28 100644 --- a/Makefile.build +++ b/Makefile.build @@ -828,8 +828,11 @@ source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf $(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi) $(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ - $(DOCMLIS) -t "Coq mlis documentation" \ - -intro $(OCAMLDOCDIR)/docintro -o $@ + $(DOCMLIS) -noheader -t "Coq mlis documentation" \ + -intro $(OCAMLDOCDIR)/docintro -o $@.tmp + $(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp + cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@ +# rm $@.tmp mli-doc: $(DOCMLIS:.mli=.cmi) $(OCAMLFIND) ocamldoc -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ diff --git a/dev/ocamldoc/fix-ocamldoc-utf8 b/dev/ocamldoc/fix-ocamldoc-utf8 new file mode 100755 index 0000000000..fe2e0c1155 --- /dev/null +++ b/dev/ocamldoc/fix-ocamldoc-utf8 @@ -0,0 +1,6 @@ +#!/bin/sh + +# This reverts automatic translation of latin1 accentuated letters by ocamldoc +# Usage: fix-ocamldoc-utf8 file + +sed -i -e 's/\\`a/\d224/g' -e "s/\\\^a/\d226/g" -e "s/\\\'e/\d233/g" -e 's/\\`e/\d232/g' -e "s/\\\^e/\d234/g" -e 's/\\\"e/\d235/g' -e "s/\\\^o/\d244/g" -e 's/\\\"o/\d246/g' -e "s/\\\^i/\d238/g" -e 's/\\\"i/\d239/g' -e 's/\\`u/\d249/g' -e "s/\\\^u/\d251/g" -e "s/\\\c{c}/\d231/g" $1 diff --git a/dev/ocamldoc/header.tex b/dev/ocamldoc/header.tex new file mode 100644 index 0000000000..4091f8144f --- /dev/null +++ b/dev/ocamldoc/header.tex @@ -0,0 +1,14 @@ +\documentclass[11pt]{article} +\usepackage[utf8x]{inputenc} +\usepackage[T1]{fontenc} +\usepackage{textcomp} +\usepackage{tipa} +\usepackage{textgreek} +\usepackage{fullpage} +\usepackage{url} +\usepackage{ocamldoc} +\title{Coq mlis documentation} +\begin{document} +\maketitle +\tableofcontents +\vspace{0.2cm} -- cgit v1.2.3 From f4002e6c85f575fc8451adb80dba705795f0a0c9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 19 Nov 2015 22:35:03 +0100 Subject: Using x in output test-suite Cases.v (cosmetic). --- test-suite/output/Cases.out | 4 ++-- test-suite/output/Cases.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index f846f4ee10..f44465456f 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -47,10 +47,10 @@ foo' = if A 0 then true else false f = fun H : B => match H with -| AC H0 => +| AC x => let b0 := b in (if b0 as b return (P b -> True) then fun _ : P true => Logic.I - else fun _ : P false => Logic.I) H0 + else fun _ : P false => Logic.I) x end : B -> True diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index a95b085ac0..a4d19d6930 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -72,7 +72,7 @@ Inductive B : Prop := AC : P b -> B. Definition f : B -> True. Proof. -intros []. +intros [x]. destruct b as [|] ; exact Logic.I. Defined. -- cgit v1.2.3 From f22ad605a14eb14d11b0a1615f7014f2dca3b483 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 22 Nov 2015 17:38:18 +0100 Subject: An example in centralizing similar functions to a common place so that cleaning the interfaces is eventually easier. Here, adding find_mrectype_vect to simplify vnorm.ml. --- pretyping/inductiveops.ml | 7 +++++-- pretyping/inductiveops.mli | 1 + pretyping/vnorm.ml | 8 +------- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index cb091f2d6f..632e00ed70 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -430,12 +430,15 @@ let extract_mrectype t = | Ind ind -> (ind, l) | _ -> raise Not_found -let find_mrectype env sigma c = - let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in +let find_mrectype_vect env sigma c = + let (t, l) = decompose_appvect (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found +let find_mrectype env sigma c = + let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v) + let find_rectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 757599a3ce..9036f521ec 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -159,6 +159,7 @@ val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given a valid inductive type *) val extract_mrectype : constr -> pinductive * constr list val find_mrectype : env -> evar_map -> types -> pinductive * constr list +val find_mrectype_vect : env -> evar_map -> types -> pinductive * constr array val find_rectype : env -> evar_map -> types -> inductive_type val find_inductive : env -> evar_map -> types -> pinductive * constr list val find_coinductive : env -> evar_map -> types -> pinductive * constr list diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index be772a6677..60140a31d9 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -45,13 +45,7 @@ let invert_tag cst tag reloc_tbl = with Find_at j -> (j+1) (* Argggg, ces constructeurs de ... qui commencent a 1*) -let find_rectype_a env c = - let (t, l) = - let t = whd_betadeltaiota env c in - try destApp t with DestKO -> (t,[||]) in - match kind_of_term t with - | Ind ind -> (ind, l) - | _ -> raise Not_found +let find_rectype_a env c = Inductiveops.find_mrectype_vect env Evd.empty c (* Instantiate inductives and parameters in constructor type *) -- cgit v1.2.3 From 2e3ee15b03cf4b7428e1a7453385d79f434ec4a7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 8 Nov 2015 09:54:42 +0100 Subject: Moving three related small half-general half-ad-hoc utility functions next to each other, waiting for possible integration into a more uniform API. --- engine/termops.ml | 28 ++++++++++++++++++++++++++ engine/termops.mli | 10 +++++++++ kernel/term.ml | 19 ----------------- kernel/term.mli | 7 ------- plugins/funind/functional_principles_proofs.ml | 1 + plugins/funind/invfun.ml | 1 + plugins/funind/recdef.ml | 1 + tactics/extratactics.ml4 | 1 + tactics/tactics.ml | 13 ++---------- toplevel/obligations.ml | 2 +- 10 files changed, 45 insertions(+), 38 deletions(-) diff --git a/engine/termops.ml b/engine/termops.ml index ebd9d939aa..5716a19dd1 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -846,6 +846,34 @@ let decompose_prod_letin : constr -> int * rel_context * constr = | _ -> i,l,c in prodec_rec 0 [] +(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction + * gives n (casts are ignored) *) +let nb_lam = + let rec nbrec n c = match kind_of_term c with + | Lambda (_,_,c) -> nbrec (n+1) c + | Cast (c,_,_) -> nbrec n c + | _ -> n + in + nbrec 0 + +(* similar to nb_lam, but gives the number of products instead *) +let nb_prod = + let rec nbrec n c = match kind_of_term c with + | Prod (_,_,c) -> nbrec (n+1) c + | Cast (c,_,_) -> nbrec n c + | _ -> n + in + nbrec 0 + +let nb_prod_modulo_zeta x = + let rec count n c = + match kind_of_term c with + Prod(_,_,t) -> count (n+1) t + | LetIn(_,a,_,t) -> count n (subst1 a t) + | Cast(c,_,_) -> count n c + | _ -> n + in count 0 x + let align_prod_letin c a : rel_context * constr = let (lc,_,_) = decompose_prod_letin c in let (la,l,a) = decompose_prod_letin a in diff --git a/engine/termops.mli b/engine/termops.mli index 6c680005db..5d812131ed 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -174,6 +174,16 @@ val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst val decompose_prod_letin : constr -> int * rel_context * constr val align_prod_letin : constr -> constr -> rel_context * constr +(** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction + gives {% $ %}n{% $ %} (casts are ignored) *) +val nb_lam : constr -> int + +(** Similar to [nb_lam], but gives the number of products instead *) +val nb_prod : constr -> int + +(** Similar to [nb_prod], but zeta-contracts let-in on the way *) +val nb_prod_modulo_zeta : constr -> int + (** Get the last arg of a constr intended to be an application *) val last_arg : constr -> constr diff --git a/kernel/term.ml b/kernel/term.ml index 33ed25fe1b..7d47c46097 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -616,25 +616,6 @@ let decompose_lam_n_decls n = in lamdec_rec empty_rel_context n -(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction - * gives n (casts are ignored) *) -let nb_lam = - let rec nbrec n c = match kind_of_term c with - | Lambda (_,_,c) -> nbrec (n+1) c - | Cast (c,_,_) -> nbrec n c - | _ -> n - in - nbrec 0 - -(* similar to nb_lam, but gives the number of products instead *) -let nb_prod = - let rec nbrec n c = match kind_of_term c with - | Prod (_,_,c) -> nbrec (n+1) c - | Cast (c,_,_) -> nbrec n c - | _ -> n - in - nbrec 0 - let prod_assum t = fst (decompose_prod_assum t) let prod_n_assum n t = fst (decompose_prod_n_assum n t) let strip_prod_assum t = snd (decompose_prod_assum t) diff --git a/kernel/term.mli b/kernel/term.mli index 2bb8110608..69adb517a0 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -308,13 +308,6 @@ val decompose_lam_n_assum : int -> constr -> rel_context * constr (** Idem, counting let-ins *) val decompose_lam_n_decls : int -> constr -> rel_context * constr -(** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction - gives {% $ %}n{% $ %} (casts are ignored) *) -val nb_lam : constr -> int - -(** Similar to [nb_lam], but gives the number of products instead *) -val nb_prod : constr -> int - (** Return the premisses/parameters of a type/term (let-in included) *) val prod_assum : types -> rel_context val lam_assum : constr -> rel_context diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index c9dd18a2fc..5b9f82aa53 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -9,6 +9,7 @@ open Names open Declarations open Pp open Tacmach +open Termops open Proof_type open Tacticals open Tactics diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d074bbabd8..363dd1b3b7 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -19,6 +19,7 @@ open Tactics open Indfun_common open Tacmach open Misctypes +open Termops (* Some pretty printing function for debugging purpose *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index dd5381c760..6867939c26 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -29,6 +29,7 @@ open Proof_type open Pfedit open Glob_term open Pretyping +open Termops open Constrintern open Misctypes open Genredexpr diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index bf8f348551..ff1ed40301 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -19,6 +19,7 @@ open Tactics open Errors open Util open Evd +open Termops open Equality open Misctypes open Sigma.Notations diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 4fb206ec94..a2275b08fb 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -45,15 +45,6 @@ open Misctypes open Proofview.Notations open Sigma.Notations -let nb_prod x = - let rec count n c = - match kind_of_term c with - Prod(_,_,t) -> count (n+1) t - | LetIn(_,a,_,t) -> count n (subst1 a t) - | Cast(c,_,_) -> count n c - | _ -> n - in count 0 x - let inj_with_occurrences e = (AllOccurrences,e) let dloc = Loc.ghost @@ -1511,7 +1502,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) - let concl_nprod = nb_prod concl in + let concl_nprod = nb_prod_modulo_zeta concl in let rec try_main_apply with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1520,7 +1511,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try - let n = nb_prod thm_ty - nprod in + let n = nb_prod_modulo_zeta thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index bfa49fab86..cac81a9395 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -528,7 +528,7 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) - let m = nb_prod fixtype in + let m = Termops.nb_prod fixtype in let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx -- cgit v1.2.3 From caeba655b78a0107c1988e5377cdd11fa91c5ea2 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 22:48:15 +0100 Subject: Experimenting removing strong normalization of the mid-statement in tactic cut. --- tactics/tactics.ml | 4 +++- theories/Program/Wf.v | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index a2275b08fb..c76aeb4a88 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1031,6 +1031,8 @@ let map_induction_arg f = function (* tactic "cut" (actually modus ponens) *) (****************************************) +let normalize_cut = false + let cut c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1049,7 +1051,7 @@ let cut c = if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) - let c = local_strong whd_betaiota sigma c in + let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Proofview.Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index d89919b0a0..6e5919b342 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -89,7 +89,7 @@ Section Measure_well_founded. Lemma measure_wf: well_founded MR. Proof with auto. unfold well_founded. - cut (forall a: M, (fun mm: M => forall a0: T, m a0 = mm -> Acc MR a0) a). + cut (forall (a: M) (a0: T), m a0 = a -> Acc MR a0). intros. apply (H (m a))... apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). -- cgit v1.2.3 From e3e86829780f664ae7a81582a4c6251ceec4f622 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 09:51:32 +0100 Subject: A few renaming and simplification in inductive.ml. --- kernel/inductive.ml | 20 ++++---------------- 1 file changed, 4 insertions(+), 16 deletions(-) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 1f8706652f..e06ea75e6a 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -270,18 +270,6 @@ let type_of_constructors (ind,u) (mib,mip) = (* Type of case predicates *) -let local_rels ctxt = - let (rels,_) = - Context.fold_rel_context_reverse - (fun (rels,n) (_,copt,_) -> - match copt with - None -> (mkRel n :: rels, n+1) - | Some _ -> (rels, n+1)) - ~init:([],1) - ctxt - in - rels - (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = @@ -369,16 +357,16 @@ let is_correct_arity env c pj ind specif params = let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,u,specif,params) cty in - let (args,ccl) = decompose_prod_assum typi in - let nargs = rel_context_length args in + let (cstrsign,ccl) = decompose_prod_assum typi in + let nargs = rel_context_length cstrsign in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in + let dep_cstr = applist (mkConstructU (cstr,u),lparams@(extended_rel_list 0 cstrsign)) in vargs @ [dep_cstr] in let base = betazeta_appvect mip.mind_nrealdecls (lift nargs p) (Array.of_list cargs) in - it_mkProd_or_LetIn base args in + it_mkProd_or_LetIn base cstrsign in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the -- cgit v1.2.3 From ff8d99117f142dd6851eb7cecc0ae84ec8642fe1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 09:51:42 +0100 Subject: Contracting one extra beta-redex on the fly when typing branches of "match". --- kernel/inductive.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index e06ea75e6a..cefb5eca54 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -365,7 +365,7 @@ let build_branches_type (ind,u) (_,mip as specif) params p = let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (mkConstructU (cstr,u),lparams@(extended_rel_list 0 cstrsign)) in vargs @ [dep_cstr] in - let base = betazeta_appvect mip.mind_nrealdecls (lift nargs p) (Array.of_list cargs) in + let base = betazeta_appvect (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base cstrsign in Array.mapi build_one_branch mip.mind_nf_lc -- cgit v1.2.3 From f66e604a9d714ee9dba09234d935ee208bc89d97 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 19 Nov 2015 22:36:48 +0100 Subject: Experimenting documentation of the Vars.subst functions. Related questions: - What balance to find between precision and conciseness? - What convention to follow for typesetting the different components of the documentation is unclear? New tentative type substl to emphasize that substitutions (for substl) are represented the other way round compared to instances for application (applist), though there are represented the same way (i.e. most recent/dependent component on top) as instances of evars (mkEvar). Also removing unused subst*_named_decl functions (at least substnl_named_decl is somehow non-sense). --- kernel/vars.ml | 21 ++++++----------- kernel/vars.mli | 70 +++++++++++++++++++++++++++++++++++++++++++-------------- 2 files changed, 60 insertions(+), 31 deletions(-) diff --git a/kernel/vars.ml b/kernel/vars.ml index a800e25315..f8c0a65e64 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -151,6 +151,11 @@ let make_subst = function done; subst +(* The type of substitutions, with term substituting most recent + binder at the head *) + +type substl = Constr.t list + let substnl laml n c = substn_many (make_subst laml) n c let substl laml c = substn_many (make_subst laml) 0 c let subst1 lam c = substn_many [|make_substituend lam|] 0 c @@ -159,13 +164,6 @@ let substnl_decl laml k r = map_rel_declaration (fun c -> substnl laml k c) r let substl_decl laml r = map_rel_declaration (fun c -> substnl laml 0 c) r let subst1_decl lam r = map_rel_declaration (fun c -> subst1 lam c) r -let substnl_named_decl laml k d = - map_named_declaration (fun c -> substnl laml k c) d -let substl_named_decl laml d = - map_named_declaration (fun c -> substnl laml 0 c) d -let subst1_named_decl lam d = - map_named_declaration (fun c -> subst1 lam c) d - (* (thin_val sigma) removes identity substitutions from sigma *) let rec thin_val = function @@ -197,15 +195,10 @@ let replace_vars var_alist x = in substrec 0 x -(* -let repvarkey = Profile.declare_profile "replace_vars";; -let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;; -*) - -(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *) +(* (subst_var str t) substitute (Var str) by (Rel 1) in t *) let subst_var str t = replace_vars [(str, Constr.mkRel 1)] t -(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *) +(* (subst_vars [id1;...;idn] t) substitute (Var idj) by (Rel j) in t *) let substn_vars p vars c = let _,subst = List.fold_left (fun (n,l) var -> ((n+1),(var,Constr.mkRel n)::l)) (p,[]) vars diff --git a/kernel/vars.mli b/kernel/vars.mli index c0fbeeb6e6..ab10ba93bf 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -42,33 +42,69 @@ val liftn : int -> int -> constr -> constr (** [lift n c] lifts by [n] the positive indexes in [c] *) val lift : int -> constr -> constr -(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an] +(** The type [substl] is the type of substitutions [u₁..un] of type + some context Δ and defined in some environment Γ. Typing of + substitutions is defined by: + - Γ ⊢ ∅ : ∅, + - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ u{_n} : An\[u₁..u{_n-1}\] implies + Γ ⊢ u₁..u{_n} : Δ,x{_n}:A{_n} + - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ un : A{_n}\[u₁..u{_n-1}\] implies + Γ ⊢ u₁..u{_n} : Δ,x{_n}:=c{_n}:A{_n} when Γ ⊢ u{_n} ≡ c{_n}\[u₁..u{_n-1}\] + + Note that [u₁..un] is represented as a list with [un] at the head of + the list, i.e. as [[un;...;u₁]]. *) + +type substl = constr list + +(** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates - accordingly indexes in [a1],...,[an] and [c] *) -val substnl : constr list -> int -> constr -> constr -val substl : constr list -> constr -> constr + accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if + Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ' ⊢ c : T with |Γ'|=k, then + Γ, Γ' ⊢ [substnl [a₁;...;an] k c] : [substnl [a₁;...;an] k T]. *) +val substnl : substl -> int -> constr -> constr + +(** [substl σ c] is a short-hand for [substnl σ 0 c] *) +val substl : substl -> constr -> constr + +(** [substl a c] is a short-hand for [substnl [a] 0 c] *) val subst1 : constr -> constr -> constr -val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration -val substl_decl : constr list -> rel_declaration -> rel_declaration -val subst1_decl : constr -> rel_declaration -> rel_declaration +(** [substnl_decl [a₁;...;an] k Ω] substitutes in parallel [a₁], ..., [an] + for respectively [Rel(k+1)], ..., [Rel(k+n)] in [Ω]; it relocates + accordingly indexes in [a₁],...,[an] and [c]. In terms of typing, if + Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ', Ω ⊢ with |Γ'|=[k], then + Γ, Γ', [substnl_decl [a₁;...;an]] k Ω ⊢. *) +val substnl_decl : substl -> int -> rel_declaration -> rel_declaration + +(** [substl_decl σ Ω] is a short-hand for [substnl_decl σ 0 Ω] *) +val substl_decl : substl -> rel_declaration -> rel_declaration -val substnl_named_decl : constr list -> int -> named_declaration -> named_declaration -val subst1_named_decl : constr -> named_declaration -> named_declaration -val substl_named_decl : constr list -> named_declaration -> named_declaration +(** [subst1_decl a Ω] is a short-hand for [substnl_decl [a] 0 Ω] *) +val subst1_decl : constr -> rel_declaration -> rel_declaration +(** [replace_vars k [(id₁,c₁);...;(idn,cn)] t] substitutes [Var idj] by + [cj] in [t]. *) val replace_vars : (Id.t * constr) list -> constr -> constr -(** (subst_var str t) substitute (VAR str) by (Rel 1) in t *) -val subst_var : Id.t -> constr -> constr -(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] - if two names are identical, the one of least indice is kept *) -val subst_vars : Id.t list -> constr -> constr +(** [substn_vars k [id₁;...;idn] t] substitutes [Var idj] by [Rel j+k-1] in [t]. + If two names are identical, the one of least index is kept. In terms of + typing, if Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ t:T, together with id{_j}:T{_j} and + Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ T{_j}\[id{_j+1}..id{_n}:=x{_j+1}..x{_n}\] ≡ Uj, + then Γ\\{id₁,...,id{_n}\},x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ [substn_vars + (|Γ'|+1) [id₁;...;idn] t] : [substn_vars (|Γ'|+1) [id₁;...;idn] + T]. *) -(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] - if two names are identical, the one of least indice is kept *) val substn_vars : int -> Id.t list -> constr -> constr +(** [subst_vars [id1;...;idn] t] is a short-hand for [substn_vars + [id1;...;idn] 1 t]: it substitutes [Var idj] by [Rel j] in [t]. If + two names are identical, the one of least index is kept. *) +val subst_vars : Id.t list -> constr -> constr + +(** [subst_var id t] is a short-hand for [substn_vars [id] 1 t]: it + substitutes [Var id] by [Rel 1] in [t]. *) +val subst_var : Id.t -> constr -> constr + (** {3 Substitution of universes} *) open Univ -- cgit v1.2.3 From ade2363e357db3ac3f258e645fe6bba988e7e7dd Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 19 Nov 2015 22:49:25 +0100 Subject: About building of substitutions from instances. Redefining adjust_subst_to_rel_context from instantiate_context who was hidden in inductiveops.ml, renamed the latter into subst_of_rel_context_instance and moving them to Vars. The new name highlights that the input is an instance (as for applist) and the output a substitution (as for substl). This is a clearer unified interface, centralizing the difficult de-Bruijn job in one place. It saves a couple of List.rev. --- engine/termops.ml | 10 ---------- engine/termops.mli | 2 +- kernel/vars.ml | 15 +++++++++++++++ kernel/vars.mli | 18 ++++++++++++++++++ pretyping/cases.ml | 8 ++++---- pretyping/inductiveops.ml | 10 +--------- pretyping/vnorm.ml | 2 +- 7 files changed, 40 insertions(+), 25 deletions(-) diff --git a/engine/termops.ml b/engine/termops.ml index 5716a19dd1..63baec129e 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -953,16 +953,6 @@ let smash_rel_context sign = aux (List.rev (substl_rel_context [b] (List.rev acc))) l in List.rev (aux [] sign) -let adjust_subst_to_rel_context sign l = - let rec aux subst sign l = - match sign, l with - | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' - | (_,Some c,_)::sign', args' -> - aux (substl subst c :: subst) sign' args' - | [], [] -> List.rev subst - | _ -> anomaly (Pp.str "Instance and signature do not match") - in aux [] (List.rev sign) l - let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init let rec mem_named_context id = function diff --git a/engine/termops.mli b/engine/termops.mli index 5d812131ed..94c485a261 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -219,7 +219,7 @@ val assums_of_rel_context : rel_context -> (Name.t * constr) list val lift_rel_context : int -> rel_context -> rel_context val substl_rel_context : constr list -> rel_context -> rel_context val smash_rel_context : rel_context -> rel_context (** expand lets in context *) -val adjust_subst_to_rel_context : rel_context -> constr list -> constr list + val map_rel_context_in_env : (env -> constr -> constr) -> env -> rel_context -> rel_context val map_rel_context_with_binders : diff --git a/kernel/vars.ml b/kernel/vars.ml index f8c0a65e64..a00c7036fb 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -164,6 +164,21 @@ let substnl_decl laml k r = map_rel_declaration (fun c -> substnl laml k c) r let substl_decl laml r = map_rel_declaration (fun c -> substnl laml 0 c) r let subst1_decl lam r = map_rel_declaration (fun c -> subst1 lam c) r +(* Build a substitution from an instance, inserting missing let-ins *) + +let subst_of_rel_context_instance sign l = + let rec aux subst sign l = + match sign, l with + | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' + | (_,Some c,_)::sign', args' -> + aux (substl subst c :: subst) sign' args' + | [], [] -> subst + | _ -> Errors.anomaly (Pp.str "Instance and signature do not match") + in aux [] (List.rev sign) l + +let adjust_subst_to_rel_context sign l = + List.rev (subst_of_rel_context_instance sign l) + (* (thin_val sigma) removes identity substitutions from sigma *) let rec thin_val = function diff --git a/kernel/vars.mli b/kernel/vars.mli index ab10ba93bf..a84cf0114e 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -56,6 +56,24 @@ val lift : int -> constr -> constr type substl = constr list +(** Let [Γ] be a context interleaving declarations [x₁:T₁..xn:Tn] + and definitions [y₁:=c₁..yp:=cp] in some context [Γ₀]. Let + [u₁..un] be an {e instance} of [Γ], i.e. an instance in [Γ₀] + of the [xi]. Then, [subst_of_rel_context_instance Γ u₁..un] + returns the corresponding {e substitution} of [Γ], i.e. the + appropriate interleaving [σ] of the [u₁..un] with the [c₁..cp], + all of them in [Γ₀], so that a derivation [Γ₀, Γ, Γ₁|- t:T] + can be instantiated into a derivation [Γ₀, Γ₁ |- t[σ]:T[σ]] using + [substnl σ |Γ₁| t]. + Note that the instance [u₁..un] is represented starting with [u₁], + as if usable in [applist] while the substitution is + represented the other way round, i.e. ending with either [u₁] or + [c₁], as if usable for [substl]. *) +val subst_of_rel_context_instance : rel_context -> constr list -> substl + +(** For compatibility: returns the substitution reversed *) +val adjust_subst_to_rel_context : rel_context -> constr list -> constr list + (** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a5a7ace221..b894cb8ea4 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -837,10 +837,10 @@ let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0 let substnl_predicate sigma = map_predicate (substnl sigma) (* This is parallel bindings *) -let subst_predicate (args,copt) ccl tms = +let subst_predicate (subst,copt) ccl tms = let sigma = match copt with - | None -> List.rev args - | Some c -> c::(List.rev args) in + | None -> subst + | Some c -> c::subst in substnl_predicate sigma 0 ccl tms let specialize_predicate_var (cur,typ,dep) tms ccl = @@ -1018,7 +1018,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* We prepare the substitution of X and x:I(X) *) let realargsi = if not (Int.equal nrealargs 0) then - adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs) + subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs) else [] in let copti = match depna with diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 632e00ed70..4c2ae61c30 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -354,14 +354,6 @@ let substnl_rel_context subst n sign = let substl_rel_context subst = substnl_rel_context subst 0 -let instantiate_context sign args = - let rec aux subst = function - | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args) - | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args) - | [], [] -> subst - | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family") - in aux [] (List.rev sign,args) - let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in let parsign = @@ -379,7 +371,7 @@ let get_arity env ((ind,u),params) = let parsign = Vars.subst_instance_context u parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in - let subst = instantiate_context parsign params in + let subst = subst_of_rel_context_instance parsign params in let arsign = Vars.subst_instance_context u arsign in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 60140a31d9..c59e085e5b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -57,7 +57,7 @@ let type_constructor mind mib u typ params = if Int.equal ndecls 0 then ctyp else let _,ctyp = decompose_prod_n_assum ndecls ctyp in - substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) + substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) ctyp -- cgit v1.2.3 From e7f7fc3e0582867975642fcaa7bd42140c61cd99 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 22 Nov 2015 13:21:31 +0100 Subject: Simplifying an instantiation function using subst_of_rel_context_instance. --- pretyping/inductiveops.ml | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 4c2ae61c30..cc4ea5a4a2 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -303,21 +303,15 @@ let lift_constructor n cs = { cs_args = lift_rel_context n cs.cs_args; cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs } -(* Accept less parameters than in the signature *) - -let instantiate_params t args sign = - let rec inst s t = function - | ((_,None,_)::ctxt,a::args) -> - (match kind_of_term t with - | Prod(_,_,t) -> inst (a::s) t (ctxt,args) - | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")) - | ((_,(Some b),_)::ctxt,args) -> - (match kind_of_term t with - | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) - | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")) - | _, [] -> substl s t - | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") - in inst [] t (List.rev sign,args) + +(* Accept either all parameters or only recursively uniform ones *) +let instantiate_params t params sign = + let nnonrecpar = rel_context_nhyps sign - List.length params in + (* Adjust the signature if recursively non-uniform parameters are not here *) + let _,sign = List.chop nnonrecpar sign in + let _,t = decompose_prod_n_assum (rel_context_length sign) t in + let subst = subst_of_rel_context_instance sign params in + substl subst t let get_constructor ((ind,u as indu),mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); -- cgit v1.2.3 From 6899d3aa567436784a08af4e179c2ef1fa504a02 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 21 Nov 2015 00:17:21 +0100 Subject: Moving extended_rel_vect/extended_rel_list to the kernel. It will later be used to fix a bug and improve some code. Interestingly, there were a redundant semantic equivalent to extended_rel_list in the kernel called local_rels, and another private copy of extended_rel_list in exactly the same file. --- engine/termops.ml | 13 ------------- engine/termops.mli | 4 ---- kernel/context.ml | 14 ++++++++++++++ kernel/context.mli | 14 ++++++++++++++ kernel/inductive.ml | 8 -------- pretyping/indrec.ml | 32 ++++++++++++++++---------------- pretyping/typeclasses.ml | 2 +- printing/printmod.ml | 1 + proofs/logic.ml | 1 + tactics/extratactics.ml4 | 2 +- toplevel/auto_ind_decl.ml | 1 + toplevel/class.ml | 1 + toplevel/record.ml | 6 +++--- 13 files changed, 53 insertions(+), 46 deletions(-) diff --git a/engine/termops.ml b/engine/termops.ml index 63baec129e..db0f1e4db5 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -158,19 +158,6 @@ let rel_list n m = in reln [] 1 -(* Same as [rel_list] but takes a context as argument and skips let-ins *) -let extended_rel_list n hyps = - let rec reln l p = function - | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps - | [] -> l - in - reln [] 1 hyps - -let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) - - - let push_rel_assum (x,t) env = push_rel (x,None,t) env let push_rels_assum assums = diff --git a/engine/termops.mli b/engine/termops.mli index 94c485a261..87f74f7435 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -37,13 +37,9 @@ val lookup_rel_id : Id.t -> rel_context -> int * constr option * types (** Functions that build argument lists matching a block of binders or a context. [rel_vect n m] builds [|Rel (n+m);...;Rel(n+1)|] - [extended_rel_vect n ctx] extends the [ctx] context of length [m] - with [n] elements. *) val rel_vect : int -> int -> constr array val rel_list : int -> int -> constr list -val extended_rel_list : int -> rel_context -> constr list -val extended_rel_vect : int -> rel_context -> constr array (** iterators/destructors on terms *) val mkProd_or_LetIn : rel_declaration -> types -> types diff --git a/kernel/context.ml b/kernel/context.ml index 796f06d37e..5923048fa4 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -111,6 +111,20 @@ let instance_from_named_context sign = in List.map_filter filter sign +(** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the local definitions of [Γ] skipped in + [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + +let extended_rel_list n hyps = + let rec reln l p = function + | (_, None, _) :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps + | (_, Some _, _) :: hyps -> reln l (p+1) hyps + | [] -> l + in + reln [] 1 hyps + +let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) + let fold_named_context f l ~init = List.fold_right f l init let fold_named_list_context f l ~init = List.fold_right f l init let fold_named_context_reverse f ~init l = List.fold_left f init l diff --git a/kernel/context.mli b/kernel/context.mli index 5279aefb6b..7354677474 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -82,8 +82,21 @@ val fold_named_context_reverse : ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a (** {6 Section-related auxiliary functions } *) + +(** [instance_from_named_context Ω] builds an instance [args] such + that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local + definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it + gives [Var id1, Var id3]. All [idj] are supposed distinct. *) val instance_from_named_context : named_context -> Constr.t list +(** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the local definitions of [Γ] skipped in + [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) +val extended_rel_list : int -> rel_context -> Constr.t list + +(** [extended_rel_vect n Γ] does the same, returning instead an array. *) +val extended_rel_vect : int -> rel_context -> Constr.t array + (** {6 ... } *) (** Signatures of ordered optionally named variables, intended to be accessed by de Bruijn indices *) @@ -120,3 +133,4 @@ val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int (** Indicates whether a LetIn or a Lambda, starting from oldest declaration *) val rel_context_tags : rel_context -> bool list + diff --git a/kernel/inductive.ml b/kernel/inductive.ml index cefb5eca54..466d487153 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -292,14 +292,6 @@ let is_primitive_record (mib,_) = | Some (Some _) -> true | _ -> false -let extended_rel_list n hyps = - let rec reln l p = function - | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps - | [] -> l - in - reln [] 1 hyps - let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 6dfc32bf1a..8ea9a5f66a 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -61,7 +61,7 @@ let check_privacy_block mib = let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in - let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in + let indf = make_ind_family(pind, Context.extended_rel_list 0 lnamespar) in let constrs = get_constructors env indf in let projs = get_projections env indf in @@ -92,8 +92,8 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let pbody = appvect (mkRel (ndepar + nbprod), - if dep then Termops.extended_rel_vect 0 deparsign - else Termops.extended_rel_vect 1 arsign) in + if dep then Context.extended_rel_vect 0 deparsign + else Context.extended_rel_vect 1 arsign) in let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) @@ -165,7 +165,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let base = applist (lift i pk,realargs) in if depK then Reduction.beta_appvect - base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|] + base [|applist (mkRel (i+1), Context.extended_rel_list 0 sign)|] else base | _ -> assert false @@ -237,7 +237,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs - and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in + and arg = appvect (mkRel (i+1), Context.extended_rel_vect 0 hyps) in applist(lift i fk,realargs@[arg]) | _ -> assert false in @@ -323,7 +323,7 @@ let mis_make_indrec env sigma listdepkind mib u = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) - let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in + let args = Context.extended_rel_list (nrec+nbconstruct) lnamesparrec in let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in @@ -337,15 +337,15 @@ let mis_make_indrec env sigma listdepkind mib u = (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) - let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in - let args'' = Termops.extended_rel_list ndepar lnonparrec in + let args' = Context.extended_rel_list (dect+nrec) lnamesparrec in + let args'' = Context.extended_rel_list ndepar lnonparrec in let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in let fi = Termops.rel_vect (dect-i-nctyi) nctyi in let vecfi = Array.map - (fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec)) + (fun f -> appvect (f, Context.extended_rel_vect ndepar lnonparrec)) fi in Array.map3 @@ -366,9 +366,9 @@ let mis_make_indrec env sigma listdepkind mib u = let deparsign' = (Anonymous,None,depind')::arsign' in let pargs = - let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec - and nrar = if dep then Termops.extended_rel_list 0 deparsign' - else Termops.extended_rel_list 1 arsign' + let nrpar = Context.extended_rel_list (2*ndepar) lnonparrec + and nrar = if dep then Context.extended_rel_list 0 deparsign' + else Context.extended_rel_list 1 arsign' in nrpar@nrar in @@ -411,8 +411,8 @@ let mis_make_indrec env sigma listdepkind mib u = let typtyi = let concl = - let pargs = if dep then Termops.extended_rel_vect 0 deparsign - else Termops.extended_rel_vect 1 arsign + let pargs = if dep then Context.extended_rel_vect 0 deparsign + else Context.extended_rel_vect 1 arsign in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) in it_mkProd_or_LetIn_name env concl @@ -439,7 +439,7 @@ let mis_make_indrec env sigma listdepkind mib u = else let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in - let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in + let vargs = Context.extended_rel_list (nrec+i+j) lnamesparrec in let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch @@ -453,7 +453,7 @@ let mis_make_indrec env sigma listdepkind mib u = in let rec put_arity env i = function | ((indi,u),_,_,dep,kinds)::rest -> - let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in + let indf = make_ind_family ((indi,u), Context.extended_rel_list i lnamesparrec) in let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) evdref kinds diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 2ef2896506..deb03f5160 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -287,7 +287,7 @@ let build_subclasses ~check env sigma glob pri = | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = - Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) + Reductionops.whd_beta sigma (appvectc c (Context.extended_rel_vect 0 rels)) in let projargs = Array.of_list (args @ [instapp]) in let projs = List.map_filter diff --git a/printing/printmod.ml b/printing/printmod.ml index 1d275c1aa6..d6f847cc71 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -65,6 +65,7 @@ let get_new_id locals id = (** Inductive declarations *) +open Context open Termops open Reduction diff --git a/proofs/logic.ml b/proofs/logic.ml index e80f5a64c7..1ba14e7d43 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -13,6 +13,7 @@ open Names open Nameops open Term open Vars +open Context open Termops open Environ open Reductionops diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index ff1ed40301..0f907b0ef7 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -315,7 +315,7 @@ let project_hint pri l2r r = | _ -> assert false in let p = if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in + let c = Reductionops.whd_beta Evd.empty (mkApp (c,Context.extended_rel_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in let id = diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index e99b609b6c..98686fb1b7 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -15,6 +15,7 @@ open Util open Pp open Term open Vars +open Context open Termops open Declarations open Names diff --git a/toplevel/class.ml b/toplevel/class.ml index da6624032f..22baa5e61c 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -12,6 +12,7 @@ open Pp open Names open Term open Vars +open Context open Termops open Entries open Environ diff --git a/toplevel/record.ml b/toplevel/record.ml index dc2c9264b8..3a75004b08 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -244,8 +244,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let ctx = Univ.instantiate_univ_context mib.mind_universes in let indu = indsp, u in let r = mkIndU (indsp,u) in - let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in - let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) + let rp = applist (r, Context.extended_rel_list 0 paramdecls) in + let paramargs = Context.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) let x = Name binder_name in let fields = instantiate_possibly_recursive_type indu paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in @@ -353,7 +353,7 @@ open Typeclasses let declare_structure finite poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in - let args = Termops.extended_rel_list nfields params in + let args = Context.extended_rel_list nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in let binder_name = -- cgit v1.2.3 From e3cefca41b568b1e517313051a111b0416cd2594 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 21 Nov 2015 00:16:34 +0100 Subject: Slight simplification of the code of primitive projection (in relation to c71aa6b and 6ababf) so as to rely on generic functions rather than re-doing the de Bruijn indices cooking locally. --- kernel/indtypes.ml | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 21d1e71344..a649ec81e8 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -695,18 +695,12 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params that typechecking projections requires just a substitution and not matching with a parameter context. *) let indty, paramsletsubst = - let _, _, subst, inst = - List.fold_right - (fun (na, b, t) (i, j, subst, inst) -> - match b with - | None -> (i-1, j-1, mkRel i :: subst, mkRel j :: inst) - | Some b -> (i, j-1, substl subst b :: subst, inst)) - paramslet (nparamargs, List.length paramslet, [], []) - in + let inst = extended_rel_list 0 paramslet in + let subst = subst_of_rel_context_instance paramslet inst in let subst = (* For the record parameter: *) mkRel 1 :: List.map (lift 1) subst in - let ty = mkApp (mkIndU indu, CArray.rev_of_list inst) in + let ty = mkApp (mkIndU indu, Array.of_list inst) in ty, subst in let ci = -- cgit v1.2.3 From e8c47b652a0b53f8d3f7eaa877e81910c8de55d0 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 22 Nov 2015 17:11:39 +0100 Subject: Unifying betazeta_applist and prod_applist into a clearer interface. - prod_applist - prod_applist_assum - lambda_applist - lambda_applist_assum expect an instance matching the quantified context. They are now in term.ml, with "list" being possibly "vect". Names are a bit arbitrary. Better propositions are welcome. They are put in term.ml in that reduction is after all not needed, because the intent is not to do β or ι on the fly but rather to substitute a λΓ.c or ∀Γ.c (seen as internalization of a Γ⊢c) into one step, independently of the idea of reducing. On the other side: - beta_applist - beta_appvect are seen as optimizations of application doing reduction on the fly only if possible. They are then kept as functions relevant for reduction.ml. --- kernel/inductive.ml | 4 +-- kernel/reduction.ml | 36 +++++++++++++-------------- kernel/reduction.mli | 9 +++++-- kernel/term.ml | 63 +++++++++++++++++++++++++++++++++++++++-------- kernel/term.mli | 24 ++++++++++++++++-- pretyping/inductiveops.ml | 2 +- pretyping/typing.ml | 3 +-- 7 files changed, 103 insertions(+), 38 deletions(-) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 466d487153..632b4daeae 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -357,14 +357,14 @@ let build_branches_type (ind,u) (_,mip as specif) params p = let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (mkConstructU (cstr,u),lparams@(extended_rel_list 0 cstrsign)) in vargs @ [dep_cstr] in - let base = betazeta_appvect (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in + let base = lambda_appvect_assum (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base cstrsign in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) let build_case_type env n p c realargs = - whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) + whd_betaiota env (lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c]))) let type_case_branches env (pind,largs) pj c = let specif = lookup_mind_specif env (fst pind) in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 1105550113..33beca28a4 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -120,24 +120,6 @@ let whd_betadeltaiota_nolet env t = Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t) -(* Beta *) - -let beta_appvect c v = - let rec stacklam env t stack = - match kind_of_term t, stack with - Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl - | _ -> applist (substl env t, stack) in - stacklam [] c (Array.to_list v) - -let betazeta_appvect n c v = - let rec stacklam n env t stack = - if Int.equal n 0 then applist (substl env t, stack) else - match kind_of_term t, stack with - Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack - | _ -> anomaly (Pp.str "Not enough lambda/let's") in - stacklam n [] c (Array.to_list v) - (********************************************************************) (* Conversion *) (********************************************************************) @@ -733,12 +715,28 @@ let conv env t1 t2 = Profile.profile4 convleqkey conv env t1 t2;; *) +(* Application with on-the-fly reduction *) + +let beta_applist c l = + let rec app subst c l = + match kind_of_term c, l with + | Lambda(_,_,c), arg::l -> app (arg::subst) c l + | _ -> applist (substl subst c, l) in + app [] c l + +let beta_appvect c v = beta_applist c (Array.to_list v) + +let beta_app c a = beta_applist c [a] + +(* Compatibility *) +let betazeta_appvect = lambda_appvect_assum + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) (* pseudo-reduction rule: - * [hnf_prod_app env s (Prod(_,B)) N --> B[N] + * [hnf_prod_app env (Prod(_,B)) N --> B[N] * with an HNF on the first argument to produce a product. * if this does not work, then we use the string S as part of our * error message. *) diff --git a/kernel/reduction.mli b/kernel/reduction.mli index ef764f34f9..7db7e57bb5 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -96,15 +96,20 @@ val default_conv_leq : ?l2r:bool -> types conversion_function (************************************************************************) +(** Builds an application node, reducing beta redexes it may produce. *) +val beta_applist : constr -> constr list -> constr + (** Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr -(** Builds an application node, reducing the [n] first beta-zeta redexes. *) -val betazeta_appvect : int -> constr -> constr array -> constr +(** Builds an application node, reducing beta redexe it may produce. *) +val beta_app : constr -> constr -> constr (** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types +(** Compatibility alias for Term.lambda_appvect_assum *) +val betazeta_appvect : int -> constr -> constr array -> constr (*********************************************************************** s Recognizing products and arities modulo reduction *) diff --git a/kernel/term.ml b/kernel/term.ml index 7d47c46097..455248dd52 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -471,6 +471,36 @@ let rec to_prod n lam = | Cast (c,_,_) -> to_prod n c | _ -> errorlabstrm "to_prod" (mt ()) +let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) +let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) + +(* Application with expected on-the-fly reduction *) + +let lambda_applist c l = + let rec app subst c l = + match kind_of_term c, l with + | Lambda(_,_,c), arg::l -> app (arg::subst) c l + | _, [] -> substl subst c + | _ -> anomaly (Pp.str "Not enough lambda's") in + app [] c l + +let lambda_appvect c v = lambda_applist c (Array.to_list v) + +let lambda_app c a = lambda_applist c [a] + +let lambda_applist_assum n c l = + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Not enough arguments") + else match kind_of_term t, l with + | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _ -> anomaly (Pp.str "Not enough lambda/let's") in + app n [] c l + +let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) + (* pseudo-reduction rule: * [prod_app s (Prod(_,B)) N --> B[N] * with an strip_outer_cast on the first argument to produce a product *) @@ -478,19 +508,32 @@ let rec to_prod n lam = let prod_app t n = match kind_of_term (strip_outer_cast t) with | Prod (_,_,b) -> subst1 n b - | _ -> - errorlabstrm "prod_app" - (str"Needed a product, but didn't find one" ++ fnl ()) - - -(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) -let prod_appvect t nL = Array.fold_left prod_app t nL + | _ -> anomaly (str"Needed a product, but didn't find one") (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) -let prod_applist t nL = List.fold_left prod_app t nL +let prod_applist c l = + let rec app subst c l = + match kind_of_term c, l with + | Prod(_,_,c), arg::l -> app (arg::subst) c l + | _, [] -> substl subst c + | _ -> anomaly (Pp.str "Not enough prod's") in + app [] c l -let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) -let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) +(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) +let prod_appvect c v = prod_applist c (Array.to_list v) + +let prod_applist_assum n c l = + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Not enough arguments") + else match kind_of_term t, l with + | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _ -> anomaly (Pp.str "Not enough prod/let's") in + app n [] c l + +let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v) (*********************************) (* Other term destructors *) diff --git a/kernel/term.mli b/kernel/term.mli index 69adb517a0..972a67ebed 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -262,14 +262,34 @@ val to_lambda : int -> constr -> constr where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *) val to_prod : int -> constr -> constr +val it_mkLambda_or_LetIn : constr -> rel_context -> constr +val it_mkProd_or_LetIn : types -> rel_context -> types + +(** In [lambda_applist c args], [c] is supposed to have the form + [λΓ.c] with [Γ] without let-in; it returns [c] with the variables + of [Γ] instantiated by [args]. *) +val lambda_applist : constr -> constr list -> constr +val lambda_appvect : constr -> constr array -> constr + +(** In [lambda_applist_assum n c args], [c] is supposed to have the + form [λΓ.c] with [Γ] of length [m] and possibly with let-ins; it + returns [c] with the assumptions of [Γ] instantiated by [args] and + the local definitions of [Γ] expanded. *) +val lambda_applist_assum : int -> constr -> constr list -> constr +val lambda_appvect_assum : int -> constr -> constr array -> constr + (** pseudo-reduction rule *) (** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *) val prod_appvect : constr -> constr array -> constr val prod_applist : constr -> constr list -> constr -val it_mkLambda_or_LetIn : constr -> rel_context -> constr -val it_mkProd_or_LetIn : types -> rel_context -> types +(** In [prod_appvect_assum n c args], [c] is supposed to have the + form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it + returns [c] with the assumptions of [Γ] instantiated by [args] and + the local definitions of [Γ] expanded. *) +val prod_appvect_assum : int -> constr -> constr array -> constr +val prod_applist_assum : int -> constr -> constr list -> constr (** {5 Other term destructors. } *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index cc4ea5a4a2..82168f9c4a 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -518,7 +518,7 @@ let type_case_branches_with_names env indspec p c = let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in (* Build case type *) - let conclty = Reduction.betazeta_appvect (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in + let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then (set_pattern_names env (fst ind) lbrty, conclty) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index fb5927dbf7..15abfefb15 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -112,8 +112,7 @@ let e_type_case_branches env evdref (ind,largs) pj c = let univ = e_is_correct_arity env evdref c pj ind specif params in let lc = build_branches_type ind specif params p in let n = (snd specif).Declarations.mind_nrealargs in - let ty = - whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in + let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in (lc, ty, univ) let e_judge_of_case env evdref ci pj cj lfj = -- cgit v1.2.3 From aa99912e9adc566a179b4972ff85a92b967fb134 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 7 Dec 2014 22:44:43 +0100 Subject: Removing redundant versions of generalize. --- plugins/funind/functional_principles_proofs.ml | 6 +++--- plugins/funind/invfun.ml | 10 +++++----- plugins/funind/recdef.ml | 6 +++--- tactics/extratactics.ml4 | 2 +- tactics/tacinterp.ml | 2 +- tactics/tactics.ml | 9 ++------- tactics/tactics.mli | 6 ++---- 7 files changed, 17 insertions(+), 24 deletions(-) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 5b9f82aa53..f57f12f667 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -706,7 +706,7 @@ let build_proof in tclTHENSEQ [ - Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); + generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; pattern_option [Locus.AllOccurrencesBut [1],t] None; (fun g -> observe_tac "toto" ( @@ -933,7 +933,7 @@ let generalize_non_dep hyp g = in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Simple.generalize (List.map mkVar to_revert) )) + ((* observe_tac "h_generalize" *) (generalize (List.map mkVar to_revert) )) ((* observe_tac "thin" *) (thin to_revert)) g @@ -1563,7 +1563,7 @@ let prove_principle_for_gen Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = - tclTHEN (Tactics.Simple.generalize (List.map mkVar l)) (clear l) + tclTHEN (Tactics.generalize (List.map mkVar l)) (clear l) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 363dd1b3b7..628e582e23 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -458,7 +458,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | (id,None,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.Simple.generalize [mkVar id]) (thin [id]) + (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -699,7 +699,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = }) Locusops.onConcl ; - Simple.generalize (List.map mkVar ids); + generalize (List.map mkVar ids); thin ids ] else @@ -738,7 +738,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = tclTHENSEQ [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" - (Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); + (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) @@ -921,7 +921,7 @@ let revert_graph kn post_tac hid g = let f_args,res = Array.chop (Array.length args - 1) args in tclTHENSEQ [ - Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; + generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); post_tac hid @@ -965,7 +965,7 @@ let functional_inversion kn hid fconst f_correct : tactic = in tclTHENSEQ[ pre_tac hid; - Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; + generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 6867939c26..60ff10922c 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -687,7 +687,7 @@ let mkDestructEq : to_revert_constr in pf_typel new_hyps (fun _ -> observe_tclTHENLIST (str "mkDestructEq") - [Simple.generalize new_hyps; + [generalize new_hyps; (fun g2 -> let changefun patvars = { run = fun sigma -> let sigma = Sigma.to_evar_map sigma in @@ -1115,7 +1115,7 @@ let termination_proof_header is_mes input_type ids args_id relation [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> - tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id])) + tclTHEN (Tactics.generalize [mkVar id]) (clear [id])) )) ; observe_tac (str "fix") (fix (Some hrec) (nargs+1)); @@ -1305,7 +1305,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in observe_tclTHENLIST (str "") [ - Simple.generalize [lemma]; + generalize [lemma]; Proofview.V82.of_tactic (Simple.intro hid); (fun g -> let ids = pf_ids_of_hyps g in diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 0f907b0ef7..8a4b206010 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -716,7 +716,7 @@ let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in Tacticals.New.tclTHENLIST - [Proofview.V82.tactic (Tactics.Simple.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); + [Proofview.V82.tactic (Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 850580f75d..bfe3097e2e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1932,7 +1932,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacGeneralize cl) - (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))) sigma + (Proofview.V82.tactic (Tactics.generalize_gen cl))) sigma end } | TacGeneralizeDep c -> (new_interp_constr ist c) (fun c -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index c76aeb4a88..539c2ab713 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2647,7 +2647,8 @@ let new_generalize_gen_let lconstr = end } let generalize_gen lconstr = - generalize_gen_let (List.map (fun ((occs,c),na) -> + generalize_gen_let (List.map (fun (occs_c,na) -> + let (occs,c) = Redexpr.out_with_occurrences occs_c in (occs,c,None),na) lconstr) let new_generalize_gen lconstr = @@ -4652,12 +4653,6 @@ module Simple = struct let intro x = intro_move (Some x) MoveLast - let generalize_gen cl = - generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl) - let generalize cl = - generalize_gen (List.map (fun c -> ((AllOccurrences,c),Names.Anonymous)) - cl) - let apply c = apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))] let eapply c = diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 129837d082..f06a50f79c 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -385,7 +385,8 @@ val letin_pat_tac : (bool * intro_pattern_naming) option -> (** {6 Generalize tactics. } *) val generalize : constr list -> tactic -val generalize_gen : ((occurrences * constr) * Name.t) list -> tactic +val generalize_gen : (constr Locus.with_occurrences * Name.t) list -> tactic + val new_generalize : constr list -> unit Proofview.tactic val new_generalize_gen : ((occurrences * constr) * Name.t) list -> unit Proofview.tactic @@ -417,9 +418,6 @@ module Simple : sig (** Simplified version of some of the above tactics *) val intro : Id.t -> unit Proofview.tactic - val generalize : constr list -> tactic - val generalize_gen : (constr Locus.with_occurrences * Name.t) list -> tactic - val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic val elim : constr -> unit Proofview.tactic -- cgit v1.2.3 From 6b39f9904b4e9d5260c4fd97ff10e52c489c6051 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 1 Dec 2015 16:30:41 +0100 Subject: Adding proofs on the relation between excluded-middle and minimization. In particular, a proof of the equivalence of excluded-middle and an unrestricted principle of minimization. Credits to Arnaud Spiwack for the ideas and formalizations of the proofs. --- theories/Logic/ClassicalFacts.v | 78 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index cdc3e04610..f82b00a0dd 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -34,6 +34,8 @@ Table of contents: 3 3. Independence of general premises and drinker's paradox +4. Classical logic and principle of unrestricted minimization + *) (************************************************************************) @@ -658,3 +660,79 @@ Proof. exists x; intro; exact Hx. exists x0; exact Hnot. Qed. + +(** ** Principle of unrestricted minimization *) + +Require Import Coq.Arith.PeanoNat. + +Definition Minimal (P:nat -> Prop) (n:nat) : Prop := + P n /\ forall k, P k -> n<=k. + +Definition Minimization_Property (P : nat -> Prop) : Prop := + forall n, P n -> exists m, Minimal P m. + +Section Unrestricted_minimization_entails_excluded_middle. + + Hypothesis unrestricted_minimization: forall P, Minimization_Property P. + + Theorem unrestricted_minimization_entails_excluded_middle : forall A, A\/~A. + Proof. + intros A. + pose (P := fun n:nat => n=0/\A \/ n=1). + assert (P 1) as h. + { unfold P. intuition. } + assert (P 0 <-> A) as p₀. + { split. + + intros [[_ h₀]|[=]]. assumption. + + unfold P. tauto. } + apply unrestricted_minimization in h as ([|[|m]] & hm & hmm). + + intuition. + + right. + intros /p₀/hmm/PeanoNat.Nat.nle_succ_0-HA. assumption. + + destruct hm as [([=],_) | [=] ]. + Qed. + +End Unrestricted_minimization_entails_excluded_middle. + +Require Import Wf_nat. + +Section Excluded_middle_entails_unrestricted_minimization. + + Hypothesis em : forall A, A\/~A. + + Theorem excluded_middle_entails_unrestricted_minimization : + forall P, Minimization_Property P. + Proof. + intros P n HPn. + assert (dec : forall n, P n \/ ~ P n) by auto using em. + assert (ex : exists n, P n) by (exists n; assumption). + destruct (dec_inh_nat_subset_has_unique_least_element P dec ex) as (n' & HPn' & _). + exists n'. assumption. + Qed. + +End Excluded_middle_entails_unrestricted_minimization. + +(** However, minimization for a given predicate does not necessarily imply + decidability of this predicate *) + +Section Example_of_undecidable_predicate_with_the_minimization_property. + + Variable s : nat -> bool. + + Let P n := exists k, n<=k /\ s k = true. + + Example undecidable_predicate_with_the_minimization_property : + Minimization_Property P. + Proof. + unfold Minimization_Property. + intros h hn. + exists 0. split. + + unfold P in *. destruct hn as (k&hk₁&hk₂). + exists k. split. + * rewrite <- hk₁. + apply PeanoNat.Nat.le_0_l. + * assumption. + + intros **. apply PeanoNat.Nat.le_0_l. + Qed. + +End Example_of_undecidable_predicate_with_the_minimization_property. -- cgit v1.2.3 From b7e72d0e0ca64168fc16875bf779dbc27d2a1820 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 10:21:33 +0100 Subject: Fix to previous commit (ClassicalFacts.v). --- theories/Logic/ClassicalFacts.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index f82b00a0dd..d4ebfb42fa 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -688,7 +688,7 @@ Section Unrestricted_minimization_entails_excluded_middle. apply unrestricted_minimization in h as ([|[|m]] & hm & hmm). + intuition. + right. - intros /p₀/hmm/PeanoNat.Nat.nle_succ_0-HA. assumption. + intros HA. apply p₀, hmm, PeanoNat.Nat.nle_succ_0 in HA. assumption. + destruct hm as [([=],_) | [=] ]. Qed. -- cgit v1.2.3 From 3a29016f5b73815454ce8d9a74a017857e926706 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 10:28:09 +0100 Subject: Fixing compilation of mli documentation. Using dummy comment to @raise to please ocamldoc. Please change MS or PMP, if needed. --- engine/uState.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/engine/uState.mli b/engine/uState.mli index a188a5269f..9dc96622ea 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -56,12 +56,12 @@ val context : t -> Univ.universe_context val add_constraints : t -> Univ.constraints -> t (** - @raise UniversesDiffer + @raise UniversesDiffer when universes differ *) val add_universe_constraints : t -> Universes.universe_constraints -> t (** - @raise UniversesDiffer + @raise UniversesDiffer when universes differ *) (** {5 Names} *) -- cgit v1.2.3 From 8596423ed6345495ca5ec0aedb8a9a431bee2e5d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 11:03:50 +0100 Subject: Making output of target source-doc a bit less verbose. --- Makefile.build | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/Makefile.build b/Makefile.build index a4e1587d28..f74bf17594 100644 --- a/Makefile.build +++ b/Makefile.build @@ -827,15 +827,18 @@ install-latex: source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf $(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi) - $(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ + $(SHOW)'OCAMLDOC -latex -o $@' + $(HIDE)$(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ $(DOCMLIS) -noheader -t "Coq mlis documentation" \ -intro $(OCAMLDOCDIR)/docintro -o $@.tmp - $(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp - cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@ -# rm $@.tmp + $(SHOW)'OCAMLDOC utf8 fix' + $(HIDE)$(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp + $(HIDE)cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@ + rm $@.tmp mli-doc: $(DOCMLIS:.mli=.cmi) - $(OCAMLFIND) ocamldoc -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ + $(SHOW)'OCAMLDOC -html' + $(HIDE)$(OCAMLFIND) ocamldoc -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ $(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \ -t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \ -css-style style.css @@ -872,7 +875,9 @@ tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< $(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex - (cd $(OCAMLDOCDIR) ; pdflatex $*.tex && pdflatex $*.tex) + $(SHOW)'PDFLATEX $*.tex' + $(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex) + $(HIDE)(cd doc/tools/; show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log) ########################################################################### ### Special rules -- cgit v1.2.3 From 895d34a264d9d90adfe4f0618c3bb0663dc01615 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Dec 2015 12:53:20 +0100 Subject: Leveraging GADTs to provide a better Dyn API. --- lib/cSig.mli | 2 ++ lib/dyn.ml | 31 ++++++++++++------------------- lib/dyn.mli | 10 +++++----- lib/util.ml | 1 + lib/util.mli | 2 ++ library/declaremods.ml | 2 +- library/libobject.ml | 17 ++++++++++++++--- library/libobject.mli | 1 - library/summary.ml | 22 ++++++++++++++++++++-- 9 files changed, 57 insertions(+), 31 deletions(-) diff --git a/lib/cSig.mli b/lib/cSig.mli index 4463e8d9c6..796e58cbfb 100644 --- a/lib/cSig.mli +++ b/lib/cSig.mli @@ -14,6 +14,8 @@ type ('a, 'b) union = Inl of 'a | Inr of 'b type 'a until = Stop of 'a | Cont of 'a (** Used for browsable-until structures. *) +type (_, _) eq = Refl : ('a, 'a) eq + module type SetS = sig type elt diff --git a/lib/dyn.ml b/lib/dyn.ml index 60167ef1ba..0571f3b5d6 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -11,12 +11,12 @@ open Pp module type S = sig -type t +type 'a tag +type t = Dyn : 'a tag * 'a -> t -val create : string -> ('a -> t) * (t -> 'a) -val tag : t -> string -val has_tag : t -> string -> bool -val pointer_equal : t -> t -> bool +val create : string -> 'a tag +val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option +val repr : 'a tag -> string val dump : unit -> (int * string) list end @@ -24,7 +24,9 @@ module Make(M : CSig.EmptyS) = struct (* Dynamics, programmed with DANGER !!! *) -type t = int * Obj.t +type 'a tag = int + +type t = Dyn : 'a tag * 'a -> t let dyntab = ref (Int.Map.empty : string Int.Map.t) (** Instead of working with tags as strings, which are costly, we use their @@ -41,25 +43,16 @@ let create (s : string) = anomaly ~label:"Dyn.create" msg in let () = dyntab := Int.Map.add hash s !dyntab in - let infun v = (hash, Obj.repr v) in - let outfun (nh, rv) = - if Int.equal hash nh then Obj.magic rv - else - anomaly (str "dyn_out: expected " ++ str s) - in - (infun, outfun) + hash -let has_tag (s, _) tag = - let hash = Hashtbl.hash (tag : string) in - Int.equal s hash +let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option = + fun h1 h2 -> if Int.equal h1 h2 then Some (Obj.magic CSig.Refl) else None -let tag (s,_) = +let repr s = try Int.Map.find s !dyntab with Not_found -> anomaly (str "Unknown dynamic tag " ++ int s) -let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2 - let dump () = Int.Map.bindings !dyntab end \ No newline at end of file diff --git a/lib/dyn.mli b/lib/dyn.mli index 55c4f0ce8f..28587859e1 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -10,12 +10,12 @@ module type S = sig -type t +type 'a tag +type t = Dyn : 'a tag * 'a -> t -val create : string -> ('a -> t) * (t -> 'a) -val tag : t -> string -val has_tag : t -> string -> bool -val pointer_equal : t -> t -> bool +val create : string -> 'a tag +val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option +val repr : 'a tag -> string val dump : unit -> (int * string) list end diff --git a/lib/util.ml b/lib/util.ml index a20dba0fc4..b67539918d 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -124,6 +124,7 @@ let delayed_force f = f () type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a +type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq let map_union f g = function | Inl a -> Inl (f a) diff --git a/lib/util.mli b/lib/util.mli index 1dc405fcbe..0ce6cc6603 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -111,5 +111,7 @@ val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a (** Used for browsable-until structures. *) +type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq + val open_utf8_file_in : string -> in_channel (** Open an utf-8 encoded file and skip the byte-order mark if any. *) diff --git a/library/declaremods.ml b/library/declaremods.ml index 7f607a51c9..d8c5ab5e74 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -371,7 +371,7 @@ let rec replace_module_object idl mp0 objs0 mp1 objs1 = match idl, objs0 with | _,[] -> [] | id::idl,(id',obj)::tail when Id.equal id id' -> - assert (object_has_tag obj "MODULE"); + assert (String.equal (object_tag obj) "MODULE"); let mp_id = MPdot(mp0, Label.of_id id) in let objs = match idl with | [] -> Lib.subst_objects (map_mp mp1 mp_id empty_delta_resolver) objs1 diff --git a/library/libobject.ml b/library/libobject.ml index c638759070..f0d281a2dd 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -8,6 +8,7 @@ open Libnames open Pp +open Util module Dyn = Dyn.Make(struct end) @@ -72,15 +73,25 @@ type dynamic_object_declaration = { dyn_discharge_function : object_name * obj -> obj option; dyn_rebuild_function : obj -> obj } -let object_tag = Dyn.tag -let object_has_tag = Dyn.has_tag +let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t let cache_tab = (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t) +let make_dyn (type a) (tag : a Dyn.tag) = + let infun x = Dyn.Dyn (tag, x) in + let outfun : (Dyn.t -> a) = fun dyn -> + let Dyn.Dyn (t, x) = dyn in + match Dyn.eq t tag with + | None -> assert false + | Some Refl -> x + in + (infun, outfun) + let declare_object_full odecl = let na = odecl.object_name in - let (infun,outfun) = Dyn.create na in + let tag = Dyn.create na in + let (infun, outfun) = make_dyn tag in let cacher (oname,lobj) = odecl.cache_function (oname,outfun lobj) and loader i (oname,lobj) = odecl.load_function i (oname,outfun lobj) and opener i (oname,lobj) = odecl.open_function i (oname,outfun lobj) diff --git a/library/libobject.mli b/library/libobject.mli index e49f3fd5c6..12b1a558f8 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -99,7 +99,6 @@ val declare_object : 'a object_declaration -> ('a -> obj) val object_tag : obj -> string -val object_has_tag : obj -> string -> bool val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit diff --git a/library/summary.ml b/library/summary.ml index 6ef4e131c7..a922e155dd 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -22,8 +22,19 @@ let summaries = ref Int.Map.empty let mangle id = id ^ "-SUMMARY" +let make_dyn (type a) (tag : a Dyn.tag) = + let infun x = Dyn.Dyn (tag, x) in + let outfun : (Dyn.t -> a) = fun dyn -> + let Dyn.Dyn (t, x) = dyn in + match Dyn.eq t tag with + | None -> assert false + | Some Refl -> x + in + (infun, outfun) + let internal_declare_summary hash sumname sdecl = - let (infun, outfun) = Dyn.create (mangle sumname) in + let tag = Dyn.create (mangle sumname) in + let (infun, outfun) = make_dyn tag in let dyn_freeze b = infun (sdecl.freeze_function b) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in @@ -166,8 +177,15 @@ let project_summary { summaries; ml_module } ?(complement=false) ids = List.filter (fun (id, _) -> List.mem id ids) summaries let pointer_equal l1 l2 = + let ptr_equal d1 d2 = + let Dyn.Dyn (t1, x1) = d1 in + let Dyn.Dyn (t2, x2) = d2 in + match Dyn.eq t1 t2 with + | None -> false + | Some Refl -> x1 == x2 + in CList.for_all2eq - (fun (id1,v1) (id2,v2) -> id1 = id2 && Dyn.pointer_equal v1 v2) l1 l2 + (fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2 (** All-in-one reference declaration + registration *) -- cgit v1.2.3 From 126a3c998c62bfd9f9b570f12b2e29576dd94cdd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Dec 2015 13:43:07 +0100 Subject: Factorizing unsafe code by relying on the new Dyn module. --- checker/check.mllib | 1 + dev/printers.mllib | 2 +- grammar/grammar.mllib | 1 + lib/clib.mllib | 1 + lib/dyn.ml | 10 ++++------ lib/lib.mllib | 1 - lib/pp.ml | 29 +++++++++++------------------ 7 files changed, 19 insertions(+), 26 deletions(-) diff --git a/checker/check.mllib b/checker/check.mllib index 246fe64dee..a029b0245c 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -8,6 +8,7 @@ Hashcons CSet CMap Int +Dyn HMap Option Store diff --git a/dev/printers.mllib b/dev/printers.mllib index 1a2819feb2..b498c2659d 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -8,6 +8,7 @@ Hashcons CSet CMap Int +Dyn HMap Option Store @@ -36,7 +37,6 @@ Util Ppstyle Errors Bigint -Dyn CUnix System Envars diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 7e4eea641b..b167643d3f 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -8,6 +8,7 @@ Hashcons CSet CMap Int +Dyn HMap Option Store diff --git a/lib/clib.mllib b/lib/clib.mllib index 7ff1d29359..1770df1993 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -8,6 +8,7 @@ Hashcons CSet CMap Int +Dyn HMap Option Store diff --git a/lib/dyn.ml b/lib/dyn.ml index 0571f3b5d6..826cfaf8db 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -6,9 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors -open Pp - module type S = sig type 'a tag @@ -39,8 +36,8 @@ let create (s : string) = let () = if Int.Map.mem hash !dyntab then let old = Int.Map.find hash !dyntab in - let msg = str "Dynamic tag collision: " ++ str s ++ str " vs. " ++ str old in - anomaly ~label:"Dyn.create" msg + let () = Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old in + assert false in let () = dyntab := Int.Map.add hash s !dyntab in hash @@ -51,7 +48,8 @@ let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option = let repr s = try Int.Map.find s !dyntab with Not_found -> - anomaly (str "Unknown dynamic tag " ++ int s) + let () = Printf.eprintf "Unknown dynamic tag %i\n%!" s in + assert false let dump () = Int.Map.bindings !dyntab diff --git a/lib/lib.mllib b/lib/lib.mllib index f3f6ad8fc7..a9181c51c1 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -1,6 +1,5 @@ Errors Bigint -Dyn Segmenttree Unicodetable Unicode diff --git a/lib/pp.ml b/lib/pp.ml index 146d3562dd..a1913c98f7 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -51,25 +51,18 @@ sig val prj : t -> 'a key -> 'a option end = struct - (** See module {Dyn} for more details. *) - type t = int * Obj.t - - type 'a key = int - - let dyntab = ref (Int.Map.empty : string Int.Map.t) - - let create (s : string) = - let hash = Hashtbl.hash s in - let () = assert (not (Int.Map.mem hash !dyntab)) in - let () = dyntab := Int.Map.add hash s !dyntab in - hash - - let inj x h = (h, Obj.repr x) - - let prj (nh, rv) h = - if Int.equal h nh then Some (Obj.magic rv) - else None +module Dyn = Dyn.Make(struct end) + +type t = Dyn.t +type 'a key = 'a Dyn.tag +let create = Dyn.create +let inj x k = Dyn.Dyn (k, x) +let prj : type a. t -> a key -> a option = fun dyn k -> + let Dyn.Dyn (k', x) = dyn in + match Dyn.eq k k' with + | None -> None + | Some CSig.Refl -> Some x end -- cgit v1.2.3 From 071a458681254716a83b1802d5b6a30edda37892 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Dec 2015 15:08:57 +0100 Subject: Fixing compilation with old CAMLPX versions. --- tactics/tauto.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 415bbb2908..537d10dd55 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -137,7 +137,7 @@ let tacticIn tac name = let push_ist ist args = let fold accu (id, arg) = Id.Map.add (Id.of_string id) arg accu in let lfun = List.fold_left fold ist.lfun args in - { ist with lfun } + { ist with lfun = lfun } let is_empty _ ist = if is_empty_type (assoc_var "X1" ist) then idtac else fail -- cgit v1.2.3 From 1dfb2c020fa0ed2e853539b8b398a9d91cbbeefa Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 2 Oct 2015 23:28:16 +0200 Subject: RefMan, ch. 4: Minor changes for spacing, clarity. --- doc/refman/RefMan-cic.tex | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 3fd5ae0b24..15b8fb9c8d 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -109,7 +109,7 @@ sets, namely the sorts {\Set} and {\Type$(j)$} for $jProp) : Type %a recursive argument and $(x:_P T)C$ if the argument is not recursive. \paragraph[Sort-polymorphism of inductive families.]{Sort-polymorphism of inductive families.\index{Sort-polymorphism of inductive families}} +\label{Sort-polymorphism-inductive} From {\Coq} version 8.1, inductive families declared in {\Type} are polymorphic over their arguments in {\Type}. If $A$ is an arity and $s$ a sort, we write $A_{/s}$ for the arity obtained from $A$ by replacing its sort with $s$. Especially, if $A$ -is well-typed in some environment and context, then $A_{/s}$ is typable +is well-typed in some global environment and local context, then $A_{/s}$ is typable by typability of all products in the Calculus of Inductive Constructions. The following typing rule is added to the theory. \begin{description} \item[Ind-Family] Let $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ be an inductive definition. Let $\Gamma_P = [p_1:P_1;\ldots;p_{p}:P_{p}]$ - be its context of parameters, $\Gamma_I = [I_1:\forall + be its local context of parameters, $\Gamma_I = [I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ its context of definitions and $\Gamma_C = [c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall \Gamma_P,C_n]$ its context of @@ -1105,7 +1108,7 @@ a strongly normalizing reduction, we cannot accept any sort of recursion (even terminating). So the basic idea is to restrict ourselves to primitive recursive functions and functionals. -For instance, assuming a parameter $A:\Set$ exists in the context, we +For instance, assuming a parameter $A:\Set$ exists in the local context, we want to build a function \length\ of type $\ListA\ra \nat$ which computes the length of the list, so such that $(\length~(\Nil~A)) = \nO$ and $(\length~(\cons~A~a~l)) = (\nS~(\length~l))$. We want these @@ -1364,7 +1367,7 @@ constructor have type \Prop. In that case, there is a canonical way to interpret the informative extraction on an object in that type, such that the elimination on any sort $s$ is legal. Typical examples are the conjunction of non-informative propositions and the equality. -If there is an hypothesis $h:a=b$ in the context, it can be used for +If there is an hypothesis $h:a=b$ in the local context, it can be used for rewriting not only in logical propositions but also in any type. % In that case, the term \verb!eq_rec! which was defined as an axiom, is % now a term of the calculus. @@ -1438,8 +1441,8 @@ only constructors of $I$. \paragraph{Example.} For \List\ and \Length\ the typing rules for the {\tt match} expression -are (writing just $t:M$ instead of \WTEG{t}{M}, the environment and -context being the same in all the judgments). +are (writing just $t:M$ instead of \WTEG{t}{M}, the global environment and +local context being the same in all the judgments). \[\frac{l:\ListA~~P:\ListA\ra s~~~f_1:(P~(\Nil~A))~~ f_2:\forall a:A, \forall l:\ListA, (P~(\cons~A~a~l))} -- cgit v1.2.3 From fe2776f9e0d355cccb0841495a9843351d340066 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 08:14:39 +0200 Subject: RefMan, ch. 1 and 2: avoiding using the name "constant" when "constructor" and "inductive" are meant also. --- doc/refman/RefMan-ext.tex | 10 +++++----- doc/refman/RefMan-gal.tex | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 80e12898f0..a2be25c3ba 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -1250,7 +1250,7 @@ possible, the correct argument will be automatically generated. \end{ErrMsgs} -\subsection{Declaration of implicit arguments for a constant +\subsection{Declaration of implicit arguments \comindex{Arguments}} \label{ImplicitArguments} @@ -1263,7 +1263,7 @@ a priori and a posteriori. \subsubsection{Implicit Argument Binders} In the first setting, one wants to explicitly give the implicit -arguments of a constant as part of its definition. To do this, one has +arguments of a declared object as part of its definition. To do this, one has to surround the bindings of implicit arguments by curly braces: \begin{coq_eval} Reset Initial. @@ -1300,7 +1300,7 @@ usual implicit arguments disambiguation syntax. \subsubsection{Declaring Implicit Arguments} -To set implicit arguments for a constant a posteriori, one can use the +To set implicit arguments a posteriori, one can use the command: \begin{quote} \tt Arguments {\qualid} \nelist{\possiblybracketedident}{} @@ -1379,7 +1379,7 @@ Check (fun l => map length l = map (list nat) nat length l). \Rem To know which are the implicit arguments of an object, use the command {\tt Print Implicit} (see \ref{PrintImplicit}). -\subsection{Automatic declaration of implicit arguments for a constant} +\subsection{Automatic declaration of implicit arguments} {\Coq} can also automatically detect what are the implicit arguments of a defined object. The command is just @@ -1582,7 +1582,7 @@ Implicit arguments names can be redefined using the following syntax: \end{quote} Without the {\tt rename} flag, {\tt Arguments} can be used to assert -that a given constant has the expected number of arguments and that +that a given object has the expected number of arguments and that these arguments are named as expected. \noindent {\bf Example (continued): } diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index 9b527053c3..e49c82d8fd 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -971,7 +971,7 @@ are the names of its constructors and {\type$_1$}, {\ldots}, {\type$_n$} their respective types. The types of the constructors have to satisfy a {\em positivity condition} (see Section~\ref{Positivity}) for {\ident}. This condition ensures the soundness of the inductive -definition. If this is the case, the constants {\ident}, +definition. If this is the case, the names {\ident}, {\ident$_1$}, {\ldots}, {\ident$_n$} are added to the environment with their respective types. Accordingly to the universe where the inductive type lives ({\it e.g.} its type {\sort}), {\Coq} provides a @@ -990,7 +990,7 @@ Inductive nat : Set := \end{coq_example} The type {\tt nat} is defined as the least \verb:Set: containing {\tt - O} and closed by the {\tt S} constructor. The constants {\tt nat}, + O} and closed by the {\tt S} constructor. The names {\tt nat}, {\tt O} and {\tt S} are added to the environment. Now let us have a look at the elimination principles. They are three @@ -1101,7 +1101,7 @@ Inductive list (A:Set) : Set := \end{coq_example*} Note that in the type of {\tt nil} and {\tt cons}, we write {\tt - (list A)} and not just {\tt list}.\\ The constants {\tt nil} and + (list A)} and not just {\tt list}.\\ The constructors {\tt nil} and {\tt cons} will have respectively types: \begin{coq_example} -- cgit v1.2.3 From df3a49a18c5b01984000df9244ecea9c275b30cd Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 7 Dec 2015 10:52:14 +0100 Subject: Fix some typos. --- dev/v8-syntax/syntax-v8.tex | 2 +- doc/refman/Program.tex | 4 ++-- doc/refman/RefMan-tac.tex | 8 ++++---- kernel/closure.ml | 2 +- kernel/fast_typeops.ml | 6 +++--- kernel/opaqueproof.mli | 4 ++-- plugins/extraction/extraction.ml | 4 ++-- plugins/funind/functional_principles_proofs.mli | 2 +- plugins/funind/recdef.ml | 12 ++++++------ plugins/romega/refl_omega.ml | 8 ++++---- plugins/setoid_ring/InitialRing.v | 6 +++--- plugins/setoid_ring/Ncring_initial.v | 4 ++-- tactics/tactics.ml | 6 +++--- test-suite/Makefile | 2 +- theories/FSets/FMapFacts.v | 2 +- theories/FSets/FMapPositive.v | 2 +- theories/MMaps/MMapFacts.v | 2 +- theories/MMaps/MMapPositive.v | 2 +- theories/Numbers/Integer/Abstract/ZDivEucl.v | 2 +- theories/Numbers/Integer/Abstract/ZDivFloor.v | 2 +- theories/Numbers/Integer/Abstract/ZDivTrunc.v | 2 +- theories/Numbers/NatInt/NZDiv.v | 2 +- theories/Numbers/Natural/Abstract/NDiv.v | 2 +- theories/Numbers/Natural/Abstract/NParity.v | 2 +- theories/Program/Subset.v | 2 +- theories/Structures/EqualitiesFacts.v | 2 +- theories/Structures/OrderedType.v | 2 +- theories/Structures/OrdersLists.v | 2 +- theories/ZArith/Zdiv.v | 2 +- theories/ZArith/Zpow_alt.v | 2 +- theories/ZArith/Zquot.v | 2 +- 31 files changed, 52 insertions(+), 52 deletions(-) diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex index 6630be06ab..64431ea161 100644 --- a/dev/v8-syntax/syntax-v8.tex +++ b/dev/v8-syntax/syntax-v8.tex @@ -81,7 +81,7 @@ Parenthesis are used to group regexps. Beware to distinguish this operator $\GR{~}$ from the terminals $\ETERM{( )}$, and $\mid$ from terminal \TERMbar. -Rules are optionaly annotated in the right margin with: +Rules are optionally annotated in the right margin with: \begin{itemize} \item a precedence and associativity (L for left, R for right and N for no associativity), indicating how to solve conflicts; lower levels are tighter; diff --git a/doc/refman/Program.tex b/doc/refman/Program.tex index 8e078e9814..3a99bfdd4f 100644 --- a/doc/refman/Program.tex +++ b/doc/refman/Program.tex @@ -201,7 +201,7 @@ in their context. In this case, the obligations should be transparent recursive calls can be checked by the kernel's type-checker. There is an optimization in the generation of obligations which gets rid of the hypothesis corresponding to the -functionnal when it is not necessary, so that the obligation can be +functional when it is not necessary, so that the obligation can be declared opaque (e.g. using {\tt Qed}). However, as soon as it appears in the context, the proof of the obligation is \emph{required} to be declared transparent. @@ -216,7 +216,7 @@ properties. It will generate obligations, try to solve them automatically and fail if some unsolved obligations remain. In this case, one can first define the lemma's statement using {\tt Program Definition} and use it as the goal afterwards. -Otherwise the proof will be started with the elobarted version as a goal. +Otherwise the proof will be started with the elaborated version as a goal. The {\tt Program} prefix can similarly be used as a prefix for {\tt Variable}, {\tt Hypothesis}, {\tt Axiom} etc... diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 55b5f622ff..f367f04c43 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3555,7 +3555,7 @@ The hints for \texttt{auto} and \texttt{eauto} are stored in databases. Each database maps head symbols to a list of hints. One can use the command \texttt{Print Hint \ident} to display the hints associated to the head symbol \ident{} (see \ref{PrintHint}). Each -hint has a cost that is an nonnegative integer, and an optional pattern. +hint has a cost that is a nonnegative integer, and an optional pattern. The hints with lower cost are tried first. A hint is tried by \texttt{auto} when the conclusion of the current goal matches its pattern or when it has no pattern. @@ -3772,7 +3772,7 @@ Hint Extern 4 (~(_ = _)) => discriminate. with hints with a cost less than 4. One can even use some sub-patterns of the pattern in the tactic - script. A sub-pattern is a question mark followed by an ident, like + script. A sub-pattern is a question mark followed by an identifier, like \texttt{?X1} or \texttt{?X2}. Here is an example: % Require EqDecide. @@ -3815,7 +3815,7 @@ The \texttt{emp} regexp does not match any search path while \texttt{eps} matches the empty path. During proof search, the path of successive successful hints on a search branch is recorded, as a list of identifiers for the hints (note \texttt{Hint Extern}'s do not have an -associated identitier). Before applying any hint $\ident$ the current +associated identifier). Before applying any hint $\ident$ the current path $p$ extended with $\ident$ is matched against the current cut expression $c$ associated to the hint database. If matching succeeds, the hint is \emph{not} applied. The semantics of \texttt{Hint Cut} $e$ @@ -4672,7 +4672,7 @@ Use \texttt{classical\_right} to prove the right part of the disjunction with th %% procedure for first-order intuitionistic logic implemented in {\em %% NuPRL}\cite{Kre02}. -%% Search may optionnaly be bounded by a multiplicity parameter +%% Search may optionally be bounded by a multiplicity parameter %% indicating how many (at most) copies of a formula may be used in %% the proof process, its absence may lead to non-termination of the tactic. diff --git a/kernel/closure.ml b/kernel/closure.ml index ea9b2755f2..03e70495fb 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -771,7 +771,7 @@ let drop_parameters depth n argstk = (* we know that n < stack_args_size(argstk) (if well-typed term) *) anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor") -(** [eta_expand_ind_stack env ind c s t] computes stacks correspoding +(** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments s. diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index 063c9cf126..b625478f25 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -33,7 +33,7 @@ let check_constraints cst env = if Environ.check_constraints cst env then () else error_unsatisfied_constraints env cst -(* This should be a type (a priori without intension to be an assumption) *) +(* This should be a type (a priori without intention to be an assumption) *) let type_judgment env c t = match kind_of_term(whd_betadeltaiota env t) with | Sort s -> {utj_val = c; utj_type = s } @@ -52,8 +52,8 @@ let assumption_of_judgment env t ty = error_assumption env (make_judge t ty) (************************************************) -(* Incremental typing rules: builds a typing judgement given the *) -(* judgements for the subterms. *) +(* Incremental typing rules: builds a typing judgment given the *) +(* judgments for the subterms. *) (*s Type of sorts *) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 0609c8517e..009ff82ff5 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -11,9 +11,9 @@ open Term open Mod_subst (** This module implements the handling of opaque proof terms. - Opauqe proof terms are special since: + Opaque proof terms are special since: - they can be lazily computed and substituted - - they are stoked in an optionally loaded segment of .vo files + - they are stored in an optionally loaded segment of .vo files An [opaque] proof terms holds the real data until fully discharged. In this case it is called [direct]. When it is [turn_indirect] the data is relocated to an opaque table diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6ae519ef60..1112c3b890 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -734,7 +734,7 @@ and extract_cst_app env mle mlt kn u args = if la >= ls then (* Enough args, cleanup already done in [mla], we only add the - additionnal dummy if needed. *) + additional dummy if needed. *) put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla)) else (* Partially applied function with some logical arg missing. @@ -748,7 +748,7 @@ and extract_cst_app env mle mlt kn u args = (*s Extraction of an inductive constructor applied to arguments. *) (* \begin{itemize} - \item In ML, contructor arguments are uncurryfied. + \item In ML, constructor arguments are uncurryfied. \item We managed to suppress logical parts inside inductive definitions, but they must appears outside (for partial applications for instance) \item We also suppressed all Coq parameters to the inductives, since diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 61fce267a3..34ce669672 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -8,7 +8,7 @@ val prove_princ_for_struct : val prove_principle_for_gen : - constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) + constant*constant*constant -> (* name of the function, the functional and the fixpoint equation *) constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 5d41ec7237..951bef2beb 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -203,7 +203,7 @@ let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> glob -(* Debuging mechanism *) +(* Debugging mechanism *) let debug_queue = Stack.create () let rec print_debug_queue b e = @@ -291,9 +291,9 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = -(* Travelling term. +(* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic - travelling mechanism. + traveling mechanism. *) (* [check_not_nested forbidden e] checks that [e] does not contains any variable @@ -327,7 +327,7 @@ let check_not_nested forbidden e = with UserError(_,p) -> errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) -(* ['a info] contains the local information for travelling *) +(* ['a info] contains the local information for traveling *) type 'a infos = { nb_arg : int; (* function number of arguments *) concl_tac : tactic; (* final tactic to finish proofs *) @@ -337,7 +337,7 @@ type 'a infos = f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) - func : global_reference; (* functionnal reference *) + func : global_reference; (* functional reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) @@ -357,7 +357,7 @@ type ('a,'b) journey_info_tac = 'b infos -> (* argument of the tactic *) tactic -(* journey_info : specifies the actions to do on the different term constructors during the travelling of the term +(* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 95407c5ff1..560e6a899e 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -46,7 +46,7 @@ let occ_step_eq s1 s2 = match s1, s2 with d'une liste de pas à partir de la racine de l'hypothèse *) type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} -(* \subsection{refiable formulas} *) +(* \subsection{reifiable formulas} *) type oformula = (* integer *) | Oint of Bigint.bigint @@ -55,7 +55,7 @@ type oformula = | Omult of oformula * oformula | Ominus of oformula * oformula | Oopp of oformula - (* an atome in the environment *) + (* an atom in the environment *) | Oatom of int (* weird expression that cannot be translated *) | Oufo of oformula @@ -75,7 +75,7 @@ type oproposition = | Pimp of int * oproposition * oproposition | Pprop of Term.constr -(* Les équations ou proposiitions atomiques utiles du calcul *) +(* Les équations ou propositions atomiques utiles du calcul *) and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) @@ -1266,7 +1266,7 @@ let resolution env full_reified_goal systems_list = | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in - (* PL: it seems that additionnally introduced hyps are in the way during + (* PL: it seems that additionally introduced hyps are in the way during normalization, hence this index shifting... *) if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) in diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index b92b847be5..56023bfb5c 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -155,7 +155,7 @@ Section ZMORPHISM. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. -(*morphisms are extensionaly equal*) +(*morphisms are extensionally equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;simpl; try rewrite (same_gen ARth);rrefl. @@ -246,7 +246,7 @@ Proof (SRth_ARth Nsth Nth). Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y. Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. -(**Same as above : definition of two,extensionaly equal, generic morphisms *) +(**Same as above : definition of two, extensionally equal, generic morphisms *) (**from N to any semi-ring*) Section NMORPHISM. Variable R : Type. @@ -671,7 +671,7 @@ End GEN_DIV. end. (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above - are only optimisations that directly returns the reifid constant + are only optimisations that directly returns the reified constant instead of resorting to the constant propagation of the simplification algorithm. *) Ltac inv_gen_phi rO rI cO cI t := diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v index c40e0ffbaa..c2eafcdad8 100644 --- a/plugins/setoid_ring/Ncring_initial.v +++ b/plugins/setoid_ring/Ncring_initial.v @@ -42,7 +42,7 @@ Defined. (*Instance ZEquality: @Equality Z:= (@eq Z).*) -(** Two generic morphisms from Z to (abrbitrary) rings, *) +(** Two generic morphisms from Z to (arbitrary) rings, *) (**second one is more convenient for proofs but they are ext. equal*) Section ZMORPHISM. Context {R:Type}`{Ring R}. @@ -130,7 +130,7 @@ Ltac rsimpl := simpl. Qed. -(*morphisms are extensionaly equal*) +(*morphisms are extensionally equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;rsimpl; try rewrite same_gen; reflexivity. diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 3e6cea5ddd..ce8b9b3dbd 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3205,7 +3205,7 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in - (* Abstract by equalitites *) + (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in (* Abstract by the "generalized" hypothesis. *) @@ -3216,11 +3216,11 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls = let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in - (* Then apply to the original instanciated hyp. *) + (* Then apply to the original instantiated hyp. *) let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body in (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in - (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) + (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) mkApp (appeqs, abshypt) let hyps_of_vars env sign nogen hyps = diff --git a/test-suite/Makefile b/test-suite/Makefile index 7150d1fd4f..207f25ed0b 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -352,7 +352,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v fi; \ } > "$@" -# Additionnal dependencies for module tests +# Additional dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v $(HIDE)$(coqtop) -R modules Mods -compile $< diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 8c6f4b64a7..eaeb2914b3 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -2143,7 +2143,7 @@ Module OrdProperties (M:S). Section Fold_properties. (** The following lemma has already been proved on Weak Maps, - but with one additionnal hypothesis (some [transpose] fact). *) + but with one additional hypothesis (some [transpose] fact). *) Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A), diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 3eac15b038..9e59f0c505 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -1061,7 +1061,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End PositiveMap. -(** Here come some additionnal facts about this implementation. +(** Here come some additional facts about this implementation. Most are facts that cannot be derivable from the general interface. *) diff --git a/theories/MMaps/MMapFacts.v b/theories/MMaps/MMapFacts.v index 69066a7b6d..8b356d7501 100644 --- a/theories/MMaps/MMapFacts.v +++ b/theories/MMaps/MMapFacts.v @@ -2381,7 +2381,7 @@ Module OrdProperties (M:S). Section Fold_properties. (** The following lemma has already been proved on Weak Maps, - but with one additionnal hypothesis (some [transpose] fact). *) + but with one additional hypothesis (some [transpose] fact). *) Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A), diff --git a/theories/MMaps/MMapPositive.v b/theories/MMaps/MMapPositive.v index d3aab2389d..adbec70574 100644 --- a/theories/MMaps/MMapPositive.v +++ b/theories/MMaps/MMapPositive.v @@ -641,7 +641,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End PositiveMap. -(** Here come some additionnal facts about this implementation. +(** Here come some additional facts about this implementation. Most are facts that cannot be derivable from the general interface. *) Module PositiveMapAdditionalFacts. diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v index d0df8fb4a7..ab73ebfe1d 100644 --- a/theories/Numbers/Integer/Abstract/ZDivEucl.v +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -391,7 +391,7 @@ rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, 0 a < b*q -> a/b < q. diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index d5f3f4ada7..c8260e516f 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -436,7 +436,7 @@ rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, 0 a < b*q -> a/b < q. diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index de2e99ec3a..464fe354b8 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -404,7 +404,7 @@ Proof. intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto. Qed. -(** Some additionnal inequalities about quot. *) +(** Some additional inequalities about quot. *) Theorem quot_lt_upper_bound: forall a b q, 0<=a -> 0 a < b*q -> a÷b < q. diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v index 4a127216f8..e0dfdedbd5 100644 --- a/theories/Numbers/NatInt/NZDiv.v +++ b/theories/Numbers/NatInt/NZDiv.v @@ -307,7 +307,7 @@ rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, 0<=a -> 0 a < b*q -> a/b < q. diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v index fb68c139b5..d3d3eb0fbb 100644 --- a/theories/Numbers/Natural/Abstract/NDiv.v +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -137,7 +137,7 @@ Proof. intros; apply mul_succ_div_gt; auto'. Qed. Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). Proof. intros. apply div_exact; auto'. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, b~=0 -> a < b*q -> a/b < q. diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v index b3526c9a17..80a579f19f 100644 --- a/theories/Numbers/Natural/Abstract/NParity.v +++ b/theories/Numbers/Natural/Abstract/NParity.v @@ -8,7 +8,7 @@ Require Import Bool NSub NZParity. -(** Some additionnal properties of [even], [odd]. *) +(** Some additional properties of [even], [odd]. *) Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N). diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 50b89b5c07..ce1f7768dd 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -82,7 +82,7 @@ Qed. Definition match_eq (A B : Type) (x : A) (fn : {y : A | y = x} -> B) : B := fn (exist _ x eq_refl). -(* This is what we want to be able to do: replace the originaly matched object by a new, +(* This is what we want to be able to do: replace the originally matched object by a new, propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *) Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B) diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index 8e2b2d081c..d5827d87a0 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -60,7 +60,7 @@ Module KeyDecidableType(D:DecidableType). Hint Resolve eqke_1 eqke_2 eqk_1. - (* Additionnal facts *) + (* Additional facts *) Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) : InA eqke p m -> InA eqk p m. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index cc8c2261b6..93ca383b28 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -342,7 +342,7 @@ Module KeyOrderedType(O:OrderedType). compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. Qed. - (* Additionnal facts *) + (* Additional facts *) Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. Proof. diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index 4d49ac84ed..41e65d7287 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -76,7 +76,7 @@ Module KeyOrderedType(O:OrderedType). Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt). Proof. eapply subrelation_proper; eauto with *. Qed. - (* Additionnal facts *) + (* Additional facts *) Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt). Proof. apply pair_compat. Qed. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index d0d10891a2..363b4fd03e 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -279,7 +279,7 @@ Proof. intros; rewrite Z.div_exact; auto. Qed. Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a. Proof. intros. apply Z.mod_le; auto. Qed. -(** Some additionnal inequalities about Z.div. *) +(** Some additional inequalities about Z.div. *) Theorem Zdiv_lt_upper_bound: forall a b q, 0 < b -> a < q*b -> a/b < q. diff --git a/theories/ZArith/Zpow_alt.v b/theories/ZArith/Zpow_alt.v index 8f661a9c80..c8627477be 100644 --- a/theories/ZArith/Zpow_alt.v +++ b/theories/ZArith/Zpow_alt.v @@ -11,7 +11,7 @@ Local Open Scope Z_scope. (** An alternative power function for Z *) -(** This [Zpower_alt] is extensionnaly equal to [Z.pow], +(** This [Zpower_alt] is extensionally equal to [Z.pow], but not convertible with it. The number of multiplications is logarithmic instead of linear, but these multiplications are bigger. Experimentally, it seems diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index 3ef1118986..6db92edb70 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -243,7 +243,7 @@ Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed. Theorem Zrem_le a b : 0 <= a -> 0 <= b -> Z.rem a b <= a. Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed. -(** Some additionnal inequalities about Zdiv. *) +(** Some additional inequalities about Zdiv. *) Theorem Zquot_le_upper_bound: forall a b q, 0 < b -> a <= q*b -> a÷b <= q. -- cgit v1.2.3 From 19ea51a4b7f7debbe5bdeb2b2689cddadd9876f4 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 7 Dec 2015 16:25:58 +0100 Subject: Fixing a minor problem in Makefile.build that was prevening "dev/printers.cma" to be loadable within "ocamldebug". --- Makefile.build | 6 +++--- dev/db | 2 -- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/Makefile.build b/Makefile.build index 98ef81f38c..00ff6a7a4c 100644 --- a/Makefile.build +++ b/Makefile.build @@ -133,9 +133,9 @@ SYSCMA:=$(addsuffix .cma,$(SYSMOD)) SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD)) ifeq ($(CAMLP4),camlp5) -P4CMA:=gramlib.cma +P4CMA:=gramlib.cma str.cma else -P4CMA:=dynlink.cma camlp4lib.cma +P4CMA:=dynlink.cma camlp4lib.cma str.cma endif @@ -882,7 +882,7 @@ dev/printers.cma: | dev/printers.mllib.d $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -o test-printer @rm -f test-printer $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $^ -linkall -a -o $@ + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -linkall -a -o $@ grammar/grammar.cma: | grammar/grammar.mllib.d $(SHOW)'Testing $@' diff --git a/dev/db b/dev/db index f259b50eb3..36a171af1c 100644 --- a/dev/db +++ b/dev/db @@ -1,5 +1,3 @@ -load_printer "gramlib.cma" -load_printer "str.cma" load_printer "printers.cma" install_printer Top_printers.ppfuture -- cgit v1.2.3 From 5c5b5906426f38323fc5d63f4dc634672ebd2649 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Dec 2015 23:34:38 +0100 Subject: Adding an unshelve tactical. This tactical is inspired by discussions on the Coq-club list. For now it is still undocumented, and there is room left for design issues. --- proofs/proofview.ml | 33 ++++++++++++++++++++++----------- proofs/proofview.mli | 4 ++++ proofs/proofview_monad.ml | 23 ++++++++++++++--------- proofs/proofview_monad.mli | 12 ++++++++---- tactics/extratactics.ml4 | 10 ++++++++++ 5 files changed, 58 insertions(+), 24 deletions(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 59a64658dc..5981ad32da 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -32,7 +32,7 @@ type entry = (Term.constr * Term.types) list let proofview p = p.comb , p.solution -let compact el { comb; solution } = +let compact el ({ solution } as pv) = let nf = Evarutil.nf_evar solution in let size = Evd.fold (fun _ _ i -> i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in @@ -45,7 +45,7 @@ let compact el { comb; solution } = let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); - new_el, { comb; solution = new_solution } + new_el, { pv with solution = new_solution; } (** {6 Starting and querying a proof view} *) @@ -62,13 +62,13 @@ let dependent_init = let src = (Loc.ghost,Evar_kinds.GoalEvar) in (* Main routine *) let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; } + | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } | TCons (env, sigma, typ, t) -> let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = gl :: comb; } + entry, { solution = sol; comb = gl :: comb; shelf = [] } in fun t -> let entry, v = aux t in @@ -232,6 +232,9 @@ let apply env t sp = match ans with | Nil (e, info) -> iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> + let (status, gaveup) = status in + let status = (status, state.shelf, gaveup) in + let state = { state with shelf = [] } in r, state, status, Trace.to_tree info @@ -578,7 +581,7 @@ let shelve = Comb.get >>= fun initial -> Comb.set [] >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> - Shelf.put initial + Shelf.modify (fun gls -> gls @ initial) (** [contained_in_info e evi] checks whether the evar [e] appears in @@ -617,7 +620,7 @@ let shelve_unifiable = let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> - Shelf.put u + Shelf.modify (fun gls -> gls @ u) (** [guard_no_unifiable] fails with error [UnresolvedBindings] if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) @@ -639,6 +642,14 @@ let unshelve l p = let l = undefined p.solution l in { p with comb = p.comb@l } +let with_shelf tac = + let open Proof in + Shelf.get >>= fun shelf -> + Shelf.set [] >> + tac >>= fun ans -> + Shelf.get >>= fun gls -> + Shelf.set shelf >> + tclUNIT (gls, ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) @@ -867,7 +878,7 @@ module Unsafe = struct let tclSETGOALS = Comb.set let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { solution = evd; comb = undefined evd ps.comb }) + Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) @@ -1085,7 +1096,7 @@ struct let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in let open Proof in InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> - Pv.set { solution = sigma; comb; } + Pv.modify (fun ps -> { ps with solution = sigma; comb; }) end (** Useful definitions *) @@ -1164,7 +1175,7 @@ module V82 = struct let sgs = CList.flatten goalss in let sgs = undefined evd sgs in InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> - Pv.set { solution = evd; comb = sgs; } + Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = Errors.push e in tclZERO ~info e @@ -1176,7 +1187,7 @@ module V82 = struct Pv.modify begin fun ps -> let map g s = GoalV82.nf_evar s g in let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in - { solution = evd; comb = goals; } + { ps with solution = evd; comb = goals; } end let has_unresolved_evar pv = @@ -1221,7 +1232,7 @@ module V82 = struct let of_tactic t gls = try - let init = { solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in + let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = final.comb } with Logic_monad.TacticFailure e as src -> diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 927df33a0c..659b783cb2 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -303,6 +303,10 @@ val guard_no_unifiable : unit tactic goals of p *) val unshelve : Goal.goal list -> proofview -> proofview +(** [with_shelf tac] executes [tac] and returns its result together with the set + of goals shelved by [tac]. The current shelf is unchanged. *) +val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic + (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] is negative, then it puts the [n] last goals first.*) val cycle : int -> unit tactic diff --git a/proofs/proofview_monad.ml b/proofs/proofview_monad.ml index 6e68cd2e45..a9faf0a833 100644 --- a/proofs/proofview_monad.ml +++ b/proofs/proofview_monad.ml @@ -157,8 +157,11 @@ end (** Type of proof views: current [evar_map] together with the list of focused goals. *) -type proofview = { solution : Evd.evar_map; comb : Goal.goal list } - +type proofview = { + solution : Evd.evar_map; + comb : Goal.goal list; + shelf : Goal.goal list; +} (** {6 Instantiation of the logic monad} *) @@ -171,10 +174,10 @@ module P = struct type e = bool (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * Evar.t list * Evar.t list + type w = bool * Evar.t list - let wunit = true , [] , [] - let wprod (b1,s1,g1) (b2,s2,g2) = b1 && b2 , s1@s2 , g1@g2 + let wunit = true , [] + let wprod (b1, g1) (b2, g2) = b1 && b2 , g1@g2 type u = Info.state @@ -226,19 +229,21 @@ module Env : State with type t := Environ.env = struct end module Status : Writer with type t := bool = struct - let put s = Logical.put (s,[],[]) + let put s = Logical.put (s, []) end -module Shelf : Writer with type t = Evar.t list = struct +module Shelf : State with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list - let put sh = Logical.put (true,sh,[]) + let get = Logical.map (fun {shelf} -> shelf) Pv.get + let set c = Pv.modify (fun pv -> { pv with shelf = c }) + let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf }) end module Giveup : Writer with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list - let put gs = Logical.put (true,[],gs) + let put gs = Logical.put (true, gs) end (** Lens and utilies pertaining to the info trace *) diff --git a/proofs/proofview_monad.mli b/proofs/proofview_monad.mli index d2a2e55fb1..a172259170 100644 --- a/proofs/proofview_monad.mli +++ b/proofs/proofview_monad.mli @@ -68,15 +68,19 @@ end (** Type of proof views: current [evar_map] together with the list of focused goals. *) -type proofview = { solution : Evd.evar_map; comb : Goal.goal list } +type proofview = { + solution : Evd.evar_map; + comb : Goal.goal list; + shelf : Goal.goal list; +} (** {6 Instantiation of the logic monad} *) module P : sig type s = proofview * Environ.env - (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * Evar.t list * Evar.t list + (** Status (safe/unsafe) * given up *) + type w = bool * Evar.t list val wunit : w val wprod : w -> w -> w @@ -123,7 +127,7 @@ module Status : Writer with type t := bool (** Lens to the list of goals which have been shelved during the execution of the tactic. *) -module Shelf : Writer with type t = Evar.t list +module Shelf : State with type t = Evar.t list (** Lens to the list of goals which were given up during the execution of the tactic. *) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 9ffcd2dcff..1355499e48 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -21,6 +21,7 @@ open Util open Evd open Equality open Misctypes +open Proofview.Notations DECLARE PLUGIN "extratactics" @@ -864,6 +865,15 @@ TACTIC EXTEND shelve_unifiable [ Proofview.shelve_unifiable ] END +(* Unshelves the goal shelved by the tactic. *) +TACTIC EXTEND unshelve +| [ "unshelve" tactic(t) ] -> + [ + Proofview.with_shelf (Tacinterp.eval_tactic t) >>= fun (gls, ()) -> + Proofview.Unsafe.tclNEWGOALS gls + ] +END + (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve [ "Unshelve" ] -- cgit v1.2.3 From 8ea758fbb392e270e6a8d2287dbb5b0455d99368 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 9 Dec 2015 11:56:52 +0100 Subject: Fixing parsing of the unshelve tactical. Now [unshelve tac1; tac2] is parsed as [(unshelve tac1); tac2]. --- tactics/extratactics.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 1355499e48..827d2e25a6 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -867,7 +867,7 @@ END (* Unshelves the goal shelved by the tactic. *) TACTIC EXTEND unshelve -| [ "unshelve" tactic(t) ] -> +| [ "unshelve" tactic0(t) ] -> [ Proofview.with_shelf (Tacinterp.eval_tactic t) >>= fun (gls, ()) -> Proofview.Unsafe.tclNEWGOALS gls -- cgit v1.2.3 From 11eedd379d4b27e73a1999c0aacc2056311e8ba9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 9 Dec 2015 12:01:32 +0100 Subject: The unshelve tactical now takes future goals into account. --- proofs/proofview.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 5981ad32da..452f27ff2b 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -644,12 +644,18 @@ let unshelve l p = let with_shelf tac = let open Proof in - Shelf.get >>= fun shelf -> - Shelf.set [] >> + Pv.get >>= fun pv -> + let { shelf; solution } = pv in + Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> tac >>= fun ans -> - Shelf.get >>= fun gls -> - Shelf.set shelf >> - tclUNIT (gls, ans) + Pv.get >>= fun npv -> + let { shelf = gls; solution = sigma } = npv in + let gls' = Evd.future_goals sigma in + let fgoals = Evd.future_goals solution in + let pgoal = Evd.principal_future_goal solution in + let sigma = Evd.restore_future_goals sigma fgoals pgoal in + Pv.set { npv with shelf; solution = sigma } >> + tclUNIT (CList.rev_append gls' gls, ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) -- cgit v1.2.3 From 8e7803224eeb32e83600905c2c855e32e7bf8ffb Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 9 Nov 2015 16:22:18 -0800 Subject: bug fixes to vm computation + test cases. --- kernel/cbytegen.ml | 2 +- kernel/vm.mli | 3 + test-suite/kernel/vm-univ.v | 145 -------------------------------- test-suite/success/vm_univ_poly.v | 141 +++++++++++++++++++++++++++++++ test-suite/success/vm_univ_poly_match.v | 28 ++++++ 5 files changed, 173 insertions(+), 146 deletions(-) delete mode 100644 test-suite/kernel/vm-univ.v create mode 100644 test-suite/success/vm_univ_poly.v create mode 100644 test-suite/success/vm_univ_poly_match.v diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 1f7cc3c7a6..67745d887b 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -175,7 +175,7 @@ let comp_env_cofix ndef arity rfv = let push_param n sz r = { r with nb_stack = r.nb_stack + n; - in_stack = add_param n (sz - r.nb_uni_stack) r.in_stack } + in_stack = add_param n sz r.in_stack } (* [push_local sz r] add a new variable on the stack at position [sz] *) let push_local sz r = diff --git a/kernel/vm.mli b/kernel/vm.mli index 43a42eb9c4..6e9579aa46 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -48,8 +48,11 @@ type whd = | Vatom_stk of atom * stack | Vuniv_level of Univ.universe_level +(** For debugging purposes only *) + val pr_atom : atom -> Pp.std_ppcmds val pr_whd : whd -> Pp.std_ppcmds +val pr_stack : stack -> Pp.std_ppcmds (** Constructors *) diff --git a/test-suite/kernel/vm-univ.v b/test-suite/kernel/vm-univ.v deleted file mode 100644 index 1bdba3c68d..0000000000 --- a/test-suite/kernel/vm-univ.v +++ /dev/null @@ -1,145 +0,0 @@ -(* Basic tests *) -Polymorphic Definition pid {T : Type} (x : T) : T := x. -(* -Definition _1 : pid true = true := - @eq_refl _ true <: pid true = true. - -Polymorphic Definition a_type := Type. - -Definition _2 : a_type@{i} = Type@{i} := - @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. - -Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := - forall x : T, P x. - -Polymorphic Axiom todo : forall {T:Type}, T -> T. - -Polymorphic Definition todo' (T : Type) := @todo T. - -Definition _3 : @todo'@{Set} = @todo@{Set} := - @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. -*) - -(* Inductive Types *) -Inductive sumbool (A B : Prop) : Set := -| left : A -> sumbool A B -| right : B -> sumbool A B. - -Definition x : sumbool True False := left _ _ I. - -Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := - match H with - | left _ _ x => left _ _ x - | right _ _ x => right _ _ x - end. - -Definition _4 : sumbool_copy x = x := - @eq_refl _ x <: sumbool_copy x = x. - -(* Polymorphic Inductive Types *) -Polymorphic Inductive poption (T : Type@{i}) : Type@{i} := -| PSome : T -> poption@{i} T -| PNone : poption@{i} T. - -Polymorphic Definition poption_default {T : Type@{i}} (p : poption@{i} T) (x : T) : T := - match p with - | @PSome _ y => y - | @PNone _ => x - end. - -Polymorphic Inductive plist (T : Type@{i}) : Type@{i} := -| pnil -| pcons : T -> plist@{i} T -> plist@{i} T. - -Arguments pnil {_}. -Arguments pcons {_} _ _. - -Section pmap. - Context {T : Type@{i}} {U : Type@{j}} (f : T -> U). - - Polymorphic Fixpoint pmap (ls : plist@{i} T) : plist@{j} U := - match ls with - | @pnil _ => @pnil _ - | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) - end. -End pmap. - -Universe Ubool. -Inductive tbool : Type@{Ubool} := ttrue | tfalse. - - -Eval vm_compute in pmap pid (pcons true (pcons false pnil)). -Eval vm_compute in pmap (fun x => match x with - | pnil => true - | pcons _ _ => false - end) (pcons pnil (pcons (pcons false pnil) pnil)). -Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). - -Polymorphic Inductive Tree (T : Type@{i}) : Type@{i} := -| Empty -| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. - -Section pfold. - Context {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U). - - Polymorphic Fixpoint pfold (acc : U) (ls : plist@{i} T) : U := - match ls with - | pnil => acc - | pcons a b => pfold (f a acc) b - end. -End pfold. - -Polymorphic Inductive nat : Type@{i} := -| O -| S : nat -> nat. - -Fixpoint nat_max (a b : nat) : nat := - match a , b with - | O , b => b - | a , O => a - | S a , S b => S (nat_max a b) - end. - -Polymorphic Fixpoint height {T : Type@{i}} (t : Tree@{i} T) : nat := - match t with - | Empty _ => O - | Branch _ ls => S (pfold nat_max O (pmap height ls)) - end. - -Polymorphic Fixpoint repeat {T : Type@{i}} (n : nat) (v : T) : plist@{i} T := - match n with - | O => pnil - | S n => pcons v (repeat n v) - end. - -Polymorphic Fixpoint big_tree (n : nat) : Tree@{i} nat := - match n with - | O => @Empty nat - | S n' => Branch _ (repeat n' (big_tree n')) - end. - -Eval compute in height (big_tree (S (S (S O)))). - -Let big := S (S (S (S (S O)))). -Polymorphic Definition really_big := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). - -Time Definition _5 : height (@Empty nat) = O := - @eq_refl nat O <: height (@Empty nat) = O. - -Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := - @eq_refl nat@{Set} (S@{Set} O@{Set}) <: height@{Set} (@Branch nat pnil) = S O. - -Time Definition _7 : height (big_tree big) = big := - @eq_refl nat big <: height (big_tree big) = big. - -Time Definition _8 : height (big_tree really_big) = really_big := - @eq_refl nat@{Set} (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) - <: - @eq nat@{Set} - (@height nat@{Set} (big_tree really_big@{Set})) - really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly.v b/test-suite/success/vm_univ_poly.v new file mode 100644 index 0000000000..58fa39743d --- /dev/null +++ b/test-suite/success/vm_univ_poly.v @@ -0,0 +1,141 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption@{i} (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist@{i} (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Polymorphic Definition pmap@{i j} + {T : Type@{i}} {U : Type@{j}} (f : T -> U) := + fix pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) + end. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree@{i} (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Polymorphic Definition pfold@{i u} + {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U) := + fix pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. + +Polymorphic Inductive nat@{i} : Type@{i} := +| O +| S : nat -> nat. + +Polymorphic Fixpoint nat_max@{i} (a b : nat@{i}) : nat@{i} := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height@{i} {T : Type@{i}} (t : Tree@{i} T) : nat@{i} := + match t return nat@{i} with + | Empty _ => O + | Branch _ ls => S@{i} (pfold@{i i} nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat@{i} {T : Type@{i}} (n : nat@{i}) (v : T) : plist@{i} T := + match n return plist@{i} T with + | O => pnil + | S n => pcons@{i} v (repeat n v) + end. + +Polymorphic Fixpoint big_tree@{i} (n : nat@{i}) : Tree@{i} nat@{i} := + match n with + | O => @Empty nat@{i} + | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree@{i} n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big@{i} := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: @eq nat@{Set} (height@{Set} (@Branch@{Set} nat@{Set} (@pnil@{Set} (Tree@{Set} nat@{Set})))) (S@{Set} O@{Set}). + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly_match.v b/test-suite/success/vm_univ_poly_match.v new file mode 100644 index 0000000000..abe6d0fe07 --- /dev/null +++ b/test-suite/success/vm_univ_poly_match.v @@ -0,0 +1,28 @@ +Set Dump Bytecode. +Set Printing Universes. +Set Printing All. + +Polymorphic Class Applicative@{d c} (T : Type@{d} -> Type@{c}) := +{ pure : forall {A : Type@{d}}, A -> T A + ; ap : forall {A B : Type@{d}}, T (A -> B) -> T A -> T B +}. + +Universes Uo Ua. + +Eval compute in @pure@{Uo Ua}. + +Global Instance Applicative_option : Applicative@{Uo Ua} option := +{| pure := @Some + ; ap := fun _ _ f x => + match f , x with + | Some f , Some x => Some (f x) + | _ , _ => None + end +|}. + +Definition foo := ap (ap (pure plus) (pure 1)) (pure 1). + +Print foo. + + +Eval vm_compute in foo. -- cgit v1.2.3 From 36cbe8fa3bd20469b45b299f66e88e03768a81af Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Fri, 27 Nov 2015 16:40:34 -0800 Subject: a few edits to the universe polymorphism section of the manual --- doc/refman/Universes.tex | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index f47973601b..ea3cca77ed 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -11,8 +11,8 @@ \end{flushleft} This section describes the universe polymorphic extension of Coq. -Universe polymorphism allows writing generic definitions making use of -universes and reuse them at different and sometimes incompatible levels. +Universe polymorphism makes it possible to write generic definitions making use of +universes and reuse them at different and sometimes incompatible universe levels. A standard example of the difference between universe \emph{polymorphic} and \emph{monomorphic} definitions is given by the identity function: @@ -64,10 +64,10 @@ the application it is instantiated at \texttt{Top.3} while in the argument position it is instantiated at \texttt{Top.4}. This definition is only valid as long as \texttt{Top.4} is strictly smaller than \texttt{Top.3}, as show by the constraints. Note that this definition is -monomorphic (not universe polymorphic), so in turn the two universes are -actually global levels. +monomorphic (not universe polymorphic), so the two universes +(in this case \texttt{Top.3} and \texttt{Top.4}) are actually global levels. -Inductive types can also be declared universes polymorphic, on universes +Inductive types can also be declared universes polymorphic on universes appearing in their parameters or fields. A typical example is given by monoids: @@ -79,7 +79,7 @@ Print Monoid. The \texttt{Monoid}'s carrier universe is polymorphic, hence it is possible to instantiate it for example with \texttt{Monoid} itself. -First we build the trivial unit monoid, in \texttt{Set}: +First we build the trivial unit monoid in \texttt{Set}: \begin{coq_example} Definition unit_monoid : Monoid := {| mon_car := unit; mon_unit := tt; mon_op x y := tt |}. @@ -197,7 +197,7 @@ universes and explicitly instantiate polymorphic definitions. \comindex{Universe} \label{UniverseCmd}} -In the monorphic case, this command declare a new global universe named +In the monorphic case, this command declares a new global universe named {\ident}. It supports the polymorphic flag only in sections, meaning the universe quantification will be discharged on each section definition independently. @@ -206,7 +206,7 @@ independently. \comindex{Constraint} \label{ConstraintCmd}} -This command declare a new constraint between named universes. +This command declares a new constraint between named universes. The order relation can be one of $<$, $\le$ or $=$. If consistent, the constraint is then enforced in the global environment. Like \texttt{Universe}, it can be used with the \texttt{Polymorphic} prefix -- cgit v1.2.3 From ce9e7c2a842d7ec7734b58af64de9283de963e37 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Fri, 4 Dec 2015 19:25:08 +0100 Subject: Replace Unix.readdir by Sys.readdir in dir cache. This makes the function sightly more portable. --- lib/system.ml | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index 2e35a98f7f..91b2f5afaf 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -67,16 +67,8 @@ module StrSet = Set.Make(StrMod) let dirmap = ref StrMap.empty let make_dir_table dir = - let b = ref StrSet.empty in - let a = Unix.opendir dir in - (try - while true do - let s = Unix.readdir a in - if s.[0] != '.' then b := StrSet.add s !b - done - with - | End_of_file -> ()); - Unix.closedir a; !b + let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in + Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) let exists_in_dir_respecting_case dir bf = let contents, cached = -- cgit v1.2.3 From 9d45d45f3a8718581a001af4576ca87feb741073 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 9 Dec 2015 14:56:17 +0100 Subject: Remove remaining occurrences of Unix.readdir. --- lib/system.ml | 30 ++++++++++-------------------- 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index 91b2f5afaf..f860bd2f7e 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -11,12 +11,11 @@ open Pp open Errors open Util -open Unix (* All subdirectories, recursively *) let exists_dir dir = - try let _ = closedir (opendir dir) in true with Unix_error _ -> false + try Sys.is_directory dir with Sys_error _ -> false let skipped_dirnames = ref ["CVS"; "_darcs"] @@ -31,24 +30,15 @@ let all_subdirs ~unix_path:root = let l = ref [] in let add f rel = l := (f, rel) :: !l in let rec traverse dir rel = - let dirh = opendir dir in - try - while true do - let f = readdir dirh in - if ok_dirname f then - let file = Filename.concat dir f in - try - begin match (stat file).st_kind with - | S_DIR -> - let newrel = rel @ [f] in - add file newrel; - traverse file newrel - | _ -> () - end - with Unix_error (e,s1,s2) -> () - done - with End_of_file -> - closedir dirh + Array.iter (fun f -> + if ok_dirname f then + let file = Filename.concat dir f in + if Sys.is_directory file then begin + let newrel = rel @ [f] in + add file newrel; + traverse file newrel + end) + (Sys.readdir dir) in if exists_dir root then traverse root []; List.rev !l -- cgit v1.2.3 From 38e70af82d33de8e977b9b7e347ff501fcd5c2d8 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 9 Dec 2015 15:14:10 +0100 Subject: Print Assumptions: improve detection of case on an axiom of False The name in the return clause has no semantic meaning, we must not look at it. --- toplevel/assumptions.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index a6bd968efc..a71588fe05 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -158,7 +158,7 @@ let rec traverse current ctx accu t = match kind_of_term t with | Case (_,oty,c,[||]) -> (* non dependent match on an inductive with no constructors *) begin match Constr.(kind oty, kind c) with - | Lambda(Anonymous,_,oty), Const (kn, _) + | Lambda(_,_,oty), Const (kn, _) when Vars.noccurn 1 oty && not (Declareops.constant_has_body (lookup_constant kn)) -> let body () = Global.body_of_constant_body (lookup_constant kn) in -- cgit v1.2.3 From 5cdf3cfc8ddfb9854534fadc1a08019e9c472590 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 08:16:54 +0200 Subject: RefMan, ch. 4: Fixing the definition of terms considered in the section. --- doc/refman/RefMan-cic.tex | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 9d79f7cac3..ef7b99d6a8 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -176,9 +176,11 @@ in a theory where inductive objects are represented by terms. \subsection{Terms} -Terms are built from variables, constants, constructors, -abstraction, application, local declarations bindings (``let-in'' -expressions) and product. +Terms are built from sorts, variables, constant, +%constructors, inductive types, +abstraction, application, local definitions, +%case analysis, fixpoints, cofixpoints +and products. From a syntactic point of view, types cannot be distinguished from terms, except that they cannot start by an abstraction, and that if a term is @@ -188,9 +190,11 @@ More precisely the language of the {\em Calculus of Inductive Constructions} is built from the following rules: \begin{enumerate} -\item the sorts {\sf Set, Prop, Type} are terms. -\item names for global constants of the environment are terms. -\item variables are terms. +\item the sorts {\Set}, {\Prop}, ${\Type(i)}$ are terms. +\item variables are terms +\item constants are terms. +%\item constructors are terms. +%\item inductive types are terms. \item if $x$ is a variable and $T$, $U$ are terms then $\forall~x:T,U$ ($\kw{forall}~x:T,U$ in \Coq{} concrete syntax) is a term. If $x$ occurs in $U$, $\forall~x:T,U$ reads as {\it ``for all x of type T, @@ -212,6 +216,9 @@ More precisely the language of the {\em Calculus of Inductive term which denotes the term $U$ where the variable $x$ is locally bound to $T$. This stands for the common ``let-in'' construction of functional programs such as ML or Scheme. +%\item case ... +%\item fixpoint ... +%\item cofixpoint ... \end{enumerate} \paragraph{Notations.} Application associates to the left such that -- cgit v1.2.3 From 5f156b28c84a86a978ab150ab5bbac5ad928ada5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 08:19:43 +0200 Subject: RefMan, ch. 4: Consistently using "constant" for names assumed or defined in global environment and "variable" for names assumed or defined in local context. --- doc/refman/RefMan-cic.tex | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ef7b99d6a8..ca3a6135d8 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -250,7 +250,8 @@ a global environment (see below) and a local context. \paragraph{Local context.} A {\em local context} is an ordered list of -declarations of variables. The declaration of some variable $x$ is +declarations of names which we call {\em variables}. +The declaration of some variable $x$ is either a local assumption, written $x:T$ ($T$ is a type) or a local definition, written $x:=t:T$. We use brackets to write local contexts. A typical example is $[x:T;y:=u:U;z:V]$. Notice that the variables @@ -289,11 +290,11 @@ definitions, but also declarations of inductive objects. Inductive objects thems (see Section~\ref{Cic-inductive-definitions}). A global assumption will be represented in the global environment as -\Assum{\Gamma}{c}{T} which means that $c$ is assumed of some type $T$ -well-defined in some local context $\Gamma$. A global definition will -be represented in the global environment as \Def{\Gamma}{c}{t}{T} which means -that $c$ is a constant which is valid in some local context $\Gamma$ whose -value is $t$ and type is $T$. +\Assum{\Gamma}{c}{T} which assumes the name $c$ to be of some type $T$ +valid in some local context $\Gamma$. A global definition will +be represented in the global environment as \Def{\Gamma}{c}{t}{T} which defines +the name $c$ to have value $t$ and type $T$, both valid in $\Gamma$. +We shall call such names {\em constants}. The rules for inductive definitions (see section \ref{Cic-inductive-definitions}) have to be considered as assumption @@ -405,7 +406,7 @@ called $\iota$-reduction and is more precisely studied in \paragraph[$\delta$-reduction.]{$\delta$-reduction.\label{delta}\index{delta-reduction@$\delta$-reduction}} -We may have defined variables in local contexts or constants in the global +We may have variables defined in local contexts or constants defined in the global environment. It is legal to identify such a reference with its value, that is to expand (or unfold) it into its value. This reduction is called $\delta$-reduction and shows as follows. -- cgit v1.2.3 From ef7264aa6106d0257e1a34f4ecf765279d9b602e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 08:22:47 +0200 Subject: RefMan, ch. 4: Removing confusing paragraph "Constants": in it, constants are yet given another definition; the reference to other presentation is more confusing than helpful to me. --- doc/refman/RefMan-cic.tex | 52 ++++++++++++++++++++++++----------------------- 1 file changed, 27 insertions(+), 25 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ca3a6135d8..3b8a8fee11 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -148,31 +148,33 @@ constraints must remain acyclic. Typing expressions that violate the acyclicity of the graph of constraints results in a \errindex{Universe inconsistency} error (see also Section~\ref{PrintingUniverses}). -\subsection{Constants} - -Constants refers to -objects in the global environment. These constants may denote previously -defined objects, but also objects related to inductive definitions -(either the type itself or one of its constructors or destructors). - -\medskip\noindent {\bf Remark. } In other presentations of \CIC, -the inductive objects are not seen as -external declarations but as first-class terms. Usually the -definitions are also completely ignored. This is a nice theoretical -point of view but not so practical. An inductive definition is -specified by a possibly huge set of declarations, clearly we want to -share this specification among the various inductive objects and not -to duplicate it. So the specification should exist somewhere and the -various objects should refer to it. We choose one more level of -indirection where the objects are just represented as constants and -the environment gives the information on the kind of object the -constant refers to. - -\medskip -Our inductive objects will be manipulated as constants declared in the -environment. This roughly corresponds to the way they are actually -implemented in the \Coq\ system. It is simple to map this presentation -in a theory where inductive objects are represented by terms. +%% HH: This looks to me more like source of confusion than helpful + +%% \subsection{Constants} + +%% Constants refers to +%% objects in the global environment. These constants may denote previously +%% defined objects, but also objects related to inductive definitions +%% (either the type itself or one of its constructors or destructors). + +%% \medskip\noindent {\bf Remark. } In other presentations of \CIC, +%% the inductive objects are not seen as +%% external declarations but as first-class terms. Usually the +%% definitions are also completely ignored. This is a nice theoretical +%% point of view but not so practical. An inductive definition is +%% specified by a possibly huge set of declarations, clearly we want to +%% share this specification among the various inductive objects and not +%% to duplicate it. So the specification should exist somewhere and the +%% various objects should refer to it. We choose one more level of +%% indirection where the objects are just represented as constants and +%% the environment gives the information on the kind of object the +%% constant refers to. + +%% \medskip +%% Our inductive objects will be manipulated as constants declared in the +%% environment. This roughly corresponds to the way they are actually +%% implemented in the \Coq\ system. It is simple to map this presentation +%% in a theory where inductive objects are represented by terms. \subsection{Terms} -- cgit v1.2.3 From cd31e372c6fb25769c26879f2f65f1937d098b87 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 08:43:19 +0200 Subject: RefMan, ch. 4: Unify capitalization of "calculus of inductive constructions". --- doc/refman/RefMan-ext.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index a2be25c3ba..a718a26ea5 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -289,7 +289,7 @@ To deactivate the printing of projections, use The option {\tt Set Primitive Projections} turns on the use of primitive projections when defining subsequent records. Primitive projections -extended the calculus of inductive constructions with a new binary term +extended the Calculus of Inductive Constructions with a new binary term constructor {\tt r.(p)} representing a primitive projection p applied to a record object {\tt r} (i.e., primitive projections are always applied). Even if the record type has parameters, these do not appear at -- cgit v1.2.3 From 75896eaaf60ce947e1fbc5a795ca5969bb1e4fae Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 08:47:15 +0200 Subject: RefMan, ch. 4: Dropping the "Co" which noone uses in "(Co)Inductive". --- doc/refman/RefMan-cic.tex | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 3b8a8fee11..2bf5bb357e 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -2,20 +2,22 @@ \label{Cic} \index{Cic@\textsc{CIC}} \index{pCic@p\textsc{CIC}} -\index{Calculus of (Co)Inductive Constructions}} +\index{Calculus of Inductive Constructions}} The underlying formal language of {\Coq} is a {\em Calculus of - Constructions} with {\em Inductive Definitions}. It is presented in -this chapter. + Constructions} with {\em Inductive Definitions}, also featuring a +universe hierarchy and coinductive types. Its inference rules are +presented in this chapter. + For {\Coq} version V7, this Calculus was known as the -{\em Calculus of (Co)Inductive Constructions}\index{Calculus of - (Co)Inductive Constructions} (\iCIC\ in short). +{\em Calculus of Inductive Constructions}\index{Calculus of + Inductive Constructions} (\iCIC\ in short). The underlying calculus of {\Coq} version V8.0 and up is a weaker calculus where the sort \Set{} satisfies predicative rules. We call this calculus the -{\em Predicative Calculus of (Co)Inductive +{\em Predicative Calculus of Inductive Constructions}\index{Predicative Calculus of - (Co)Inductive Constructions} (\pCIC\ in short). + Inductive Constructions} (\pCIC\ in short). In Section~\ref{impredicativity} we give the extra-rules for \iCIC. A compiling option of \Coq{} allows type-checking theories in this extended system. -- cgit v1.2.3 From 650ed1278160c2d6dae7914703c8755ab54e095c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 21:16:17 +0200 Subject: RefMan, ch. 4: Reformulating introduction of the chapter on CIC, being clearer that the version depends on the version of Coq. Also renouncing to the "Predicative" and "(Co)" in the name, since after all, usage seems to continue calling the language of Coq Calculus of Inductive Constructions and to consider the Set predicative vs Set impredicative, as well as the presence of coinduction, as flavors of the CIC. --- doc/common/macros.tex | 3 +-- doc/refman/RefMan-cic.tex | 65 +++++++++++++++++++++++++---------------------- doc/refman/biblio.bib | 25 +++++++++++++++--- 3 files changed, 57 insertions(+), 36 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 0e820008ed..573c3c812e 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -97,8 +97,7 @@ \newcommand{\camlpppp}{\textsc{Camlp4}} \newcommand{\emacs}{\textsc{GNU Emacs}} \newcommand{\ProofGeneral}{\textsc{Proof General}} -\newcommand{\CIC}{\pCIC} -\newcommand{\pCIC}{p\textsc{Cic}} +\newcommand{\CIC}{\textsc{Cic}} \newcommand{\iCIC}{\textsc{Cic}} \newcommand{\FW}{\ensuremath{F_{\omega}}} \newcommand{\Program}{\textsc{Program}} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2bf5bb357e..a06e7acbad 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -5,22 +5,29 @@ \index{Calculus of Inductive Constructions}} The underlying formal language of {\Coq} is a {\em Calculus of - Constructions} with {\em Inductive Definitions}, also featuring a -universe hierarchy and coinductive types. Its inference rules are -presented in this chapter. - -For {\Coq} version V7, this Calculus was known as the -{\em Calculus of Inductive Constructions}\index{Calculus of - Inductive Constructions} (\iCIC\ in short). -The underlying calculus of {\Coq} version V8.0 and up is a weaker - calculus where the sort \Set{} satisfies predicative rules. -We call this calculus the -{\em Predicative Calculus of Inductive - Constructions}\index{Predicative Calculus of - Inductive Constructions} (\pCIC\ in short). -In Section~\ref{impredicativity} we give the extra-rules for \iCIC. A - compiling option of \Coq{} allows type-checking theories in this - extended system. + Inductive Constructions} (\CIC) whose inference rules are presented in +this chapter. + +The {\CIC} implemented in {\Coq} +takes its name from Coquand and Paulin's {\em Calculus of + Inductive Constructions}~\cite{CoPa89} which itself extends +Coquand-Huet's {\em Calculus of + Constructions}~\cite{CoHu85a,CoHu85b,CoHu86,Coq85} with a universe +hierarchy~\cite{Coq86,Luo90,Hue88b} and a generic presentation of +inductive types à la Martin-L\"of~\cite{MaL84,Dyb91}. First implemented in +{\Coq} version 5.0, it incorporated coinductive +types~\cite{Coquand93,Gim96} from {\Coq} version 5.10. It +progressively extended with various new features such as local +definitions (since {\Coq} version 7.0), universe polymorphism (since +{\Coq} version 8.1 for inductive types and version 8.5 for full +polymorphism), recursively non-uniform parameters (since {\Coq} version 8.1), +some $\eta$-rules (for dependent product in {\Coq} +version 8.4, for record types in {\Coq} version 8.5), and other +refinements in the expressiveness of fixpoints and inductive types. +Up to version 7.4, the {\CIC} implemented in {\Coq} +had an impredicative sort {\Set}. Since {\Coq} version 8.0, the sort +{\Set} is predicative by default, with an option to make it +impredicative (see Section~\ref{impredicativity}). In \CIC\, all objects have a {\em type}. There are types for functions (or programs), there are atomic types (especially datatypes)... but also @@ -28,29 +35,25 @@ types for proofs and types for the types themselves. Especially, any object handled in the formalism must belong to a type. For instance, the statement {\it ``for all x, P''} is not allowed in type theory; you must say instead: {\it ``for all x -belonging to T, P''}. The expression {\it ``x belonging to T''} is -written {\it ``x:T''}. One also says: {\it ``x has type T''}. +of type T, P''}. The expression {\it ``x of type T''} is +written {\it ``x:T''}. Informally, {\it ``x:T''} can be thought as +{\it ``x belongs to T''}. The terms of {\CIC} are detailed in Section~\ref{Terms}. -In \CIC\, there is an internal reduction mechanism. In particular, it +In \CIC, there is an internal reduction mechanism. In particular, it can decide if two programs are {\em intentionally} equal (one says {\em convertible}). Convertibility is presented in section \ref{convertibility}. -The remaining sections are concerned with the type-checking of terms. -The beginner can skip them. - The reader seeking a background on the Calculus of Inductive -Constructions may read several papers. Giménez and Castéran~\cite{GimCas05} +Constructions may read several papers. In addition to the references given above, Giménez and Castéran~\cite{GimCas05} provide an introduction to inductive and co-inductive definitions in Coq. In -their book~\cite{CoqArt}, Bertot and Castéran give a precise +their book~\cite{CoqArt}, Bertot and Castéran give a description of the \CIC{} based on numerous practical examples. Barras~\cite{Bar99}, Werner~\cite{Wer94} and -Paulin-Mohring~\cite{Moh97} are the most recent theses dealing with -Inductive Definitions. Coquand-Huet~\cite{CoHu85a,CoHu85b,CoHu86} -introduces the Calculus of Constructions. Coquand-Paulin~\cite{CoPa89} -extended this calculus to inductive definitions. The {\CIC} is a +Paulin-Mohring~\cite{Moh97} are dealing with +Inductive Definitions. The {\CIC} is a formulation of type theory including the possibility of inductive constructions, Barendregt~\cite{Bar91} studies the modern form of type theory. @@ -1701,11 +1704,11 @@ More information on co-inductive definitions can be found in~\cite{Gimenez95b,Gim98,GimCas05}. %They are described in Chapter~\ref{Co-inductives}. -\section[\iCIC : the Calculus of Inductive Construction with - impredicative \Set]{\iCIC : the Calculus of Inductive Construction with +\section[The Calculus of Inductive Construction with + impredicative \Set]{The Calculus of Inductive Construction with impredicative \Set\label{impredicativity}} -\Coq{} can be used as a type-checker for \iCIC{}, the original +\Coq{} can be used as a type-checker for the Calculus of Inductive Constructions with an impredicative sort \Set{} by using the compiler option \texttt{-impredicative-set}. diff --git a/doc/refman/biblio.bib b/doc/refman/biblio.bib index d78ce4f2c6..6f789b081c 100644 --- a/doc/refman/biblio.bib +++ b/doc/refman/biblio.bib @@ -288,9 +288,14 @@ s}, @InProceedings{Coquand93, author = {Th. Coquand}, - title = {{Infinite Objects in Type Theory}}, + booktitle = {Types for Proofs and Programs}, + editor = {H. Barendregt and T. Nipokow}, + publisher = SV, + series = LNCS, + title = {{Infinite objects in Type Theory}}, + volume = {806}, year = {1993}, - crossref = {Nijmegen93} + pages = {62-78} } @inproceedings{Corbineau08types, @@ -540,6 +545,13 @@ s}, year = {1994} } +@PhDThesis{Gim96, + author = {E. Gim\'enez}, + title = {Un calcul des constructions infinies et son application \'a la v\'erification de syst\`emes communicants}, + school = {\'Ecole Normale Sup\'erieure de Lyon}, + year = {1996} +} + @TechReport{Gim98, author = {E. Gim\'enez}, title = {A Tutorial on Recursive Types in Coq}, @@ -660,6 +672,13 @@ s}, year = {1989} } +@Unpublished{Hue88b, + author = {G. Huet}, + title = {Extending the Calculus of Constructions with Type:Type}, + year = 1988, + note = {Unpublished} +} + @Book{Hue89, editor = {G. Huet}, publisher = {Addison-Wesley}, @@ -1366,4 +1385,4 @@ Languages}, timestamp = {Thu, 17 Nov 2011 13:33:48 +0100}, biburl = {http://dblp.uni-trier.de/rec/bib/conf/cpp/BoespflugDG11}, bibsource = {dblp computer science bibliography, http://dblp.org} -} \ No newline at end of file +} -- cgit v1.2.3 From e7c38a5516246b751b89535594075f6f95a243fd Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 4 Oct 2015 22:17:46 +0200 Subject: RefMan, ch. 4: In chapter 4 about CIC, renounced to keep a local context for discharge in global declarations. Discharge now done on a global declaration. Hence removed Def and Assum which were only partially used (e.g. in rules Def and Assum but not in delta-conversion, nor in rule Const). Added discharge rule over definitions using let-in. It replaces the "substitution" rule since about 7.0. --- doc/common/macros.tex | 1 + doc/refman/RefMan-cic.tex | 92 ++++++++++++++++++++++++----------------------- 2 files changed, 49 insertions(+), 44 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 573c3c812e..f785a85bbc 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -412,6 +412,7 @@ \newcommand{\Fix}[2]{\mbox{\tt Fix}~#1\{#2\}} \newcommand{\CoFix}[2]{\mbox{\tt CoFix}~#1\{#2\}} \newcommand{\With}[2]{\mbox{\tt ~with~}} +\newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} \newcommand{\subst}[3]{#1\{#2/#3\}} \newcommand{\substs}[4]{#1\{(#2/#3)_{#4}\}} \newcommand{\Sort}{\mbox{$\cal S$}} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index a06e7acbad..52003dc34f 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -297,10 +297,10 @@ definitions, but also declarations of inductive objects. Inductive objects thems (see Section~\ref{Cic-inductive-definitions}). A global assumption will be represented in the global environment as -\Assum{\Gamma}{c}{T} which assumes the name $c$ to be of some type $T$ -valid in some local context $\Gamma$. A global definition will -be represented in the global environment as \Def{\Gamma}{c}{t}{T} which defines -the name $c$ to have value $t$ and type $T$, both valid in $\Gamma$. +$(c:T)$ which assumes the name $c$ to be of some type $T$. +A global definition will +be represented in the global environment as $c:=t:T$ which defines +the name $c$ to have value $t$ and type $T$. We shall call such names {\em constants}. The rules for inductive definitions (see section @@ -342,10 +342,10 @@ be derived from the following rules. \frac{\WTEG{t}{T}~~~~x \not\in \Gamma % \cup E }{\WFE{\Gamma::(x:=t:T)}}} -\item[Def] \inference{\frac{\WTEG{t}{T}~~~c \notin E \cup \Gamma} - {\WF{E;\Def{\Gamma}{c}{t}{T}}{\Gamma}}} -\item[Assum] \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~c \notin E \cup \Gamma} - {\WF{E;\Assum{\Gamma}{c}{T}}{\Gamma}}} +\item[Def] \inference{\frac{\WTE{}{t}{T}~~~c \notin E} + {\WF{E;c:=t:T}{}}} + \item[Assum] \inference{\frac{\WTE{}{T}{s}~~~~s \in \Sort~~~~c \notin E} + {\WF{E;c:T}{}}} \item[Ax] \index{Typing rules!Ax} \inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(p)}}~~~~~ \frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(q)}}} @@ -372,7 +372,7 @@ be derived from the following rules. {\WTEG{(t\ u)}{\subst{T}{x}{u}}}} \item[Let]\index{Typing rules!Let} \inference{\frac{\WTEG{t}{T}~~~~ \WTE{\Gamma::(x:=t:T)}{u}{U}} - {\WTEG{\kw{let}~x:=t~\kw{in}~u}{\subst{U}{x}{t}}}} + {\WTEG{\letin{x}{t:T}{u}}{\subst{U}{x}{t}}}} \end{description} \Rem We may have $\kw{let}~x:=t~\kw{in}~u$ @@ -528,51 +528,55 @@ Because these rules correspond to elementary operations in the \Coq\ engine used in the discharge mechanism at the end of a section, we state them explicitly. -\paragraph{Mechanism of substitution.} +% This is obsolete: Abstraction over defined constants actually uses a +% let-in since there are let-ins in Coq -One rule which can be proved valid, is to replace a term $c$ by its -value in the global environment. As we defined the substitution of a term for -a variable in a term, one can define the substitution of a term for a -constant. One easily extends this substitution to local contexts and global -environments. +%% \paragraph{Mechanism of substitution.} -\paragraph{Substitution Property:} -\inference{\frac{\WF{E;\Def{\Gamma}{c}{t}{T}; F}{\Delta}} - {\WF{E; \subst{F}{c}{t}}{\subst{\Delta}{c}{t}}}} +%% One rule which can be proved valid, is to replace a term $c$ by its +%% value in the global environment. As we defined the substitution of a term for +%% a variable in a term, one can define the substitution of a term for a +%% constant. One easily extends this substitution to local contexts and global +%% environments. +%% \paragraph{Substitution Property:} +%% \inference{\frac{\WF{E;c:=t:T; E'}{\Gamma}} +%% {\WF{E; \subst{E'}{c}{t}}{\subst{\Gamma}{c}{t}}}} \paragraph{Abstraction.} -One can modify the local context of definition of a constant $c$ by -abstracting a constant with respect to the last variable $x$ of its -defining local context. For doing that, we need to check that the constants -appearing in the body of the declaration do not depend on $x$, we need -also to modify the reference to the constant $c$ in the global environment -and local context by explicitly applying this constant to the variable $x$. -Because of the rules for building global environments and terms we know the -variable $x$ is available at each stage where $c$ is mentioned. - -\paragraph{Abstracting property:} - \inference{\frac{\WF{E; \Def{\Gamma::(x:U)}{c}{t}{T}; - F}{\Delta}~~~~\WFE{\Gamma}} - {\WF{E;\Def{\Gamma}{c}{\lb x:U\mto t}{\forall~x:U,T}; - \subst{F}{c}{(c~x)}}{\subst{\Delta}{c}{(c~x)}}}} +One can modify the definition of a constant $c$ by generalizing it +over a previously assumed constant $c'$. For doing that, we need +to modify the reference to $c$ in the subsequent global environment +and local context by explicitly applying this constant to the constant $c'$. -\paragraph{Pruning the local context.} -We said the judgment \WFE{\Gamma} means that the defining local contexts of -constants in $E$ are included in $\Gamma$. If one abstracts or -substitutes the constants with the above rules then it may happen -that the local context $\Gamma$ is now bigger than the one needed for -defining the constants in $E$. Because defining local contexts are growing -in $E$, the minimum local context needed for defining the constants in $E$ -is the same as the one for the last constant. One can consequently -derive the following property. +\paragraph{First abstracting property:} + \inference{\frac{\WF{E;c':U;E';c:=t:T;E''}{\Gamma}} + {\WF{E;c':U;E';c:=\lb x:U\mto \subst{t}{c'}{x}:\forall~x:U,\subst{T}{c'}{x}; + \subst{E''}{c}{(c~c')}}{\subst{\Gamma}{c}{(c~c')}}}} -\paragraph{Pruning property:} -\inference{\frac{\WF{E; \Def{\Delta}{c}{t}{T}}{\Gamma}} - {\WF{E;\Def{\Delta}{c}{t}{T}}{\Delta}}} +One can similarly modify the definition of a constant $c$ by generalizing it +over a previously defined constant $c'$. +\paragraph{Second abstracting property:} + \inference{\frac{\WF{E;c':=u:U;E';c:=t:T;E''}{\Gamma}} + {\WF{E;c':=u:U;E';c:=(\letin{x}{u:U}{\subst{t}{c'}{x}}):\subst{T}{c'}{u}; + E''}{\Gamma}}} +\paragraph{Pruning the local context.} +If one abstracts or substitutes constants with the above rules then it +may happen that some declared or defined constant does not occur any +more in the subsequent global environment and in the local context. One can +consequently derive the following property. + +\paragraph{First pruning property:} +\inference{\frac{\WF{E;c:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} + {\WF{E;E'}{\Gamma}}} + +\paragraph{Second pruning property:} +\inference{\frac{\WF{E;c:=u:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} + {\WF{E;E'}{\Gamma}}} + \section[Inductive Definitions]{Inductive Definitions\label{Cic-inductive-definitions}} A (possibly mutual) inductive definition is specified by giving the -- cgit v1.2.3 From 779c314c28abbff3d9fc1fca9a2c75dc7e103a1c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 6 Oct 2015 11:45:02 +0200 Subject: RefMan, ch. 4: Reference Manual: more on the "in pattern" clause and "@qualid pattern". --- doc/refman/Cases.tex | 4 +++- doc/refman/RefMan-gal.tex | 21 ++++++++++++--------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index 4238bf6a57..a95d8114ff 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -521,6 +521,8 @@ I have a copy of {\tt b} in type {\tt listn 0} resp {\tt listn (S n')}. % \end{coq_example} \paragraph{Patterns in {\tt in}} +\label{match-in-patterns} + If the type of the matched term is more precise than an inductive applied to variables, arguments of the inductive in the {\tt in} branch can be more complicated patterns than a variable. @@ -530,7 +532,7 @@ become impossible branches. In an impossible branch, you can answer anything but {\tt False\_rect unit} has the advantage to be subterm of anything. % ??? -To be concrete: the tail function can be written: +To be concrete: the {\tt tail} function can be written: \begin{coq_example} Definition tail n (v: listn (S n)) := match v in listn (S m) return listn m with diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index e49c82d8fd..f631c3717c 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -311,7 +311,7 @@ called \CIC). The formal presentation of {\CIC} is given in Chapter {\annotation} & ::= & {\tt \{ struct} {\ident} {\tt \}} \\ &&\\ {\caseitem} & ::= & {\term} \zeroone{{\tt as} \name} - \zeroone{{\tt in} \pattern} \\ + \zeroone{{\tt in} \qualid \sequence{\pattern}{}} \\ &&\\ {\ifitem} & ::= & \zeroone{{\tt as} {\name}} {\returntype} \\ &&\\ @@ -322,7 +322,7 @@ called \CIC). The formal presentation of {\CIC} is given in Chapter {\multpattern} & ::= & \nelist{\pattern}{\tt ,}\\ &&\\ {\pattern} & ::= & {\qualid} \nelist{\pattern}{} \\ - & $|$ & {\tt @} {\qualid} \sequence{\pattern}{} \\ + & $|$ & {\tt @} {\qualid} \nelist{\pattern}{} \\ & $|$ & {\pattern} {\tt as} {\ident} \\ & $|$ & {\pattern} {\tt \%} {\ident} \\ @@ -609,17 +609,20 @@ the type of each branch can depend on the type dependencies specific to the branch and the whole pattern-matching expression has a type determined by the specific dependencies in the type of the term being matched. This dependency of the return type in the annotations of the -inductive type is expressed using a {\tt -``in~I~\_~$\ldots$~\_~\ident$_1$~$\ldots$~\ident$_n$}'' clause, where +inductive type is expressed using a + ``in~I~\_~$\ldots$~\_~\pattern$_1$~$\ldots$~\pattern$_n$'' clause, where \begin{itemize} \item $I$ is the inductive type of the term being matched; -\item the names \ident$_i$'s correspond to the arguments of the -inductive type that carry the annotations: the return type is dependent -on them; - -\item the {\_}'s denote the family parameters of the inductive type: +\item the {\_}'s are matching the parameters of the inductive type: the return type is not dependent on them. + +\item the \pattern$_i$'s are matching the annotations of the inductive + type: the return type is dependent on them + +\item in the basic case which we describe below, each \pattern$_i$ is a + name \ident$_i$; see \ref{match-in-patterns} for the general case + \end{itemize} For instance, in the following example: -- cgit v1.2.3 From ba00ffda884142fdd1b4d8b0888d3c9a35457c99 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 6 Oct 2015 19:45:38 +0200 Subject: RefMan, ch. 4: a few clarifications, thanks to Matej. There is still something buggy in explaining the interpretation of "match" as "case": we need typing to reconstruct the types of the x and y1..yn from the "as x in I ... y1..yn" clause. --- doc/refman/RefMan-cic.tex | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 52003dc34f..aa4483759e 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -497,7 +497,7 @@ The conversion rule is now exactly: \paragraph[Normal form.]{Normal form.\index{Normal form}\label{Normal-form}\label{Head-normal-form}\index{Head normal form}} A term which cannot be any more reduced is said to be in {\em normal form}. There are several ways (or strategies) to apply the reduction -rule. Among them, we have to mention the {\em head reduction} which +rules. Among them, we have to mention the {\em head reduction} which will play an important role (see Chapter~\ref{Tactics}). Any term can be written as $\lb x_1:T_1\mto \ldots \lb x_k:T_k \mto (t_0\ t_1\ldots t_n)$ where @@ -967,7 +967,7 @@ Inductive exType (P:Type->Prop) : Type From {\Coq} version 8.1, inductive families declared in {\Type} are polymorphic over their arguments in {\Type}. -If $A$ is an arity and $s$ a sort, we write $A_{/s}$ for the arity +If $A$ is an arity of some sort and $s$ is a sort, we write $A_{/s}$ for the arity obtained from $A$ by replacing its sort with $s$. Especially, if $A$ is well-typed in some global environment and local context, then $A_{/s}$ is typable by typability of all products in the Calculus of Inductive Constructions. @@ -1260,13 +1260,13 @@ compact notation: \paragraph[Allowed elimination sorts.]{Allowed elimination sorts.\index{Elimination sorts}} An important question for building the typing rule for \kw{match} is -what can be the type of $P$ with respect to the type of the inductive +what can be the type of $\lb a x \mto P$ with respect to the type of the inductive definitions. We define now a relation \compat{I:A}{B} between an inductive definition $I$ of type $A$ and an arity $B$. This relation states that an object in the inductive definition $I$ can be eliminated for -proving a property $P$ of type $B$. +proving a property $\lb a x \mto P$ of type $B$. The case of inductive definitions in sorts \Set\ or \Type{} is simple. There is no restriction on the sort of the predicate to be -- cgit v1.2.3 From 19a3cb9cf627e593026a675ff7201bb1dc8e3574 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 6 Oct 2015 19:49:57 +0200 Subject: RefMan, ch. 4: Avoiding using "inductive family" which is not defined. Using consistently "inductive types". --- doc/refman/RefMan-cic.tex | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index aa4483759e..174f318fed 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -631,7 +631,7 @@ the value over the parameter. In the case of inductive definitions we have to handle the abstraction over several objects. One possible way to do that would be to define the type \List\ -inductively as being an inductive family of type $\Set\ra\Set$: +inductively as being an inductive type of type $\Set\ra\Set$: \[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set,\List~A), \cons : (\forall A:\Set, A \ra \List~A \ra \List~A)}\] There are drawbacks to this point of view. The @@ -961,10 +961,10 @@ Inductive exType (P:Type->Prop) : Type %is recursive or not. We shall write the type $(x:_R T)C$ if it is %a recursive argument and $(x:_P T)C$ if the argument is not recursive. -\paragraph[Sort-polymorphism of inductive families.]{Sort-polymorphism of inductive families.\index{Sort-polymorphism of inductive families}} +\paragraph[Sort-polymorphism of inductive types.]{Sort-polymorphism of inductive types.\index{Sort-polymorphism of inductive types}} \label{Sort-polymorphism-inductive} -From {\Coq} version 8.1, inductive families declared in {\Type} are +From {\Coq} version 8.1, inductive types declared in {\Type} are polymorphic over their arguments in {\Type}. If $A$ is an arity of some sort and $s$ is a sort, we write $A_{/s}$ for the arity @@ -1057,7 +1057,7 @@ predicative {\Set}. More precisely, an empty or small singleton inductive definition (i.e. an inductive definition of which all inductive types are singleton -- see paragraph~\ref{singleton}) is set in -{\Prop}, a small non-singleton inductive family is set in {\Set} (even +{\Prop}, a small non-singleton inductive type is set in {\Set} (even in case {\Set} is impredicative -- see Section~\ref{impredicativity}), and otherwise in the {\Type} hierarchy. % TODO: clarify the case of a partial application ?? -- cgit v1.2.3 From 6beb39ff5e8e52692cc008e4b43ee28ecf792f8a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 9 Oct 2015 14:45:23 +0200 Subject: RefMan, ch. 4: Moving section on discharge after inductive types. --- doc/refman/RefMan-cic.tex | 116 +++++++++++++++++++++++----------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 174f318fed..3b0a204e3b 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -375,7 +375,7 @@ be derived from the following rules. {\WTEG{\letin{x}{t:T}{u}}{\subst{U}{x}{t}}}} \end{description} -\Rem We may have $\kw{let}~x:=t~\kw{in}~u$ +\Rem We may have $\letin{x}{t:T}{u}$ well-typed without having $((\lb x:T\mto u)~t)$ well-typed (where $T$ is a type of $t$). This is because the value $t$ associated to $x$ may be used in a conversion rule (see Section~\ref{conv-rules}). @@ -520,63 +520,6 @@ $u_i$ can be reducible. Similar notions of head-normal forms involving $\delta$, $\iota$ and $\zeta$ reductions or any combination of those can also be defined. -\section{Derived rules for global environments} - -From the original rules of the type system, one can derive new rules -which change the local context of definition of objects in the global environment. -Because these rules correspond to elementary operations in the \Coq\ -engine used in the discharge mechanism at the end of a section, we -state them explicitly. - -% This is obsolete: Abstraction over defined constants actually uses a -% let-in since there are let-ins in Coq - -%% \paragraph{Mechanism of substitution.} - -%% One rule which can be proved valid, is to replace a term $c$ by its -%% value in the global environment. As we defined the substitution of a term for -%% a variable in a term, one can define the substitution of a term for a -%% constant. One easily extends this substitution to local contexts and global -%% environments. - -%% \paragraph{Substitution Property:} -%% \inference{\frac{\WF{E;c:=t:T; E'}{\Gamma}} -%% {\WF{E; \subst{E'}{c}{t}}{\subst{\Gamma}{c}{t}}}} - -\paragraph{Abstraction.} - -One can modify the definition of a constant $c$ by generalizing it -over a previously assumed constant $c'$. For doing that, we need -to modify the reference to $c$ in the subsequent global environment -and local context by explicitly applying this constant to the constant $c'$. - -\paragraph{First abstracting property:} - \inference{\frac{\WF{E;c':U;E';c:=t:T;E''}{\Gamma}} - {\WF{E;c':U;E';c:=\lb x:U\mto \subst{t}{c'}{x}:\forall~x:U,\subst{T}{c'}{x}; - \subst{E''}{c}{(c~c')}}{\subst{\Gamma}{c}{(c~c')}}}} - -One can similarly modify the definition of a constant $c$ by generalizing it -over a previously defined constant $c'$. - -\paragraph{Second abstracting property:} - \inference{\frac{\WF{E;c':=u:U;E';c:=t:T;E''}{\Gamma}} - {\WF{E;c':=u:U;E';c:=(\letin{x}{u:U}{\subst{t}{c'}{x}}):\subst{T}{c'}{u}; - E''}{\Gamma}}} - -\paragraph{Pruning the local context.} -If one abstracts or substitutes constants with the above rules then it -may happen that some declared or defined constant does not occur any -more in the subsequent global environment and in the local context. One can -consequently derive the following property. - -\paragraph{First pruning property:} -\inference{\frac{\WF{E;c:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} - {\WF{E;E'}{\Gamma}}} - -\paragraph{Second pruning property:} -\inference{\frac{\WF{E;c:=u:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} - {\WF{E;E'}{\Gamma}}} - \section[Inductive Definitions]{Inductive Definitions\label{Cic-inductive-definitions}} A (possibly mutual) inductive definition is specified by giving the @@ -1701,6 +1644,63 @@ Abort. The principles of mutual induction can be automatically generated using the {\tt Scheme} command described in Section~\ref{Scheme}. +\section{Derived rules for global environments} + +From the original rules of the type system, one can derive new rules +which change the local context of definition of objects in the global environment. +Because these rules correspond to elementary operations in the \Coq\ +engine used in the discharge mechanism at the end of a section, we +state them explicitly. + +% This is obsolete: Abstraction over defined constants actually uses a +% let-in since there are let-ins in Coq + +%% \paragraph{Mechanism of substitution.} + +%% One rule which can be proved valid, is to replace a term $c$ by its +%% value in the global environment. As we defined the substitution of a term for +%% a variable in a term, one can define the substitution of a term for a +%% constant. One easily extends this substitution to local contexts and global +%% environments. + +%% \paragraph{Substitution Property:} +%% \inference{\frac{\WF{E;c:=t:T; E'}{\Gamma}} +%% {\WF{E; \subst{E'}{c}{t}}{\subst{\Gamma}{c}{t}}}} + +\paragraph{Abstraction.} + +One can modify the definition of a constant $c$ by generalizing it +over a previously assumed constant $c'$. For doing that, we need +to modify the reference to $c$ in the subsequent global environment +and local context by explicitly applying this constant to the constant $c'$. + +\paragraph{First abstracting property:} + \inference{\frac{\WF{E;c':U;E';c:=t:T;E''}{\Gamma}} + {\WF{E;c':U;E';c:=\lb x:U\mto \subst{t}{c'}{x}:\forall~x:U,\subst{T}{c'}{x}; + \subst{E''}{c}{(c~c')}}{\subst{\Gamma}{c}{(c~c')}}}} + +One can similarly modify the definition of a constant $c$ by generalizing it +over a previously defined constant $c'$. + +\paragraph{Second abstracting property:} + \inference{\frac{\WF{E;c':=u:U;E';c:=t:T;E''}{\Gamma}} + {\WF{E;c':=u:U;E';c:=(\letin{x}{u:U}{\subst{t}{c'}{x}}):\subst{T}{c'}{u}; + E''}{\Gamma}}} + +\paragraph{Pruning the local context.} +If one abstracts or substitutes constants with the above rules then it +may happen that some declared or defined constant does not occur any +more in the subsequent global environment and in the local context. One can +consequently derive the following property. + +\paragraph{First pruning property:} +\inference{\frac{\WF{E;c:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} + {\WF{E;E'}{\Gamma}}} + +\paragraph{Second pruning property:} +\inference{\frac{\WF{E;c:=u:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} + {\WF{E;E'}{\Gamma}}} + \section{Co-inductive types} The implementation contains also co-inductive definitions, which are types inhabited by infinite objects. -- cgit v1.2.3 From 8654b03544f0efe4b418a0afdc871ff84784ff83 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 9 Oct 2015 15:57:52 +0200 Subject: RefMan, ch. 4: Adding discharging of inductive types. --- doc/common/macros.tex | 1 + doc/refman/RefMan-cic.tex | 60 +++++++++++++++++++++++++++++++++-------------- 2 files changed, 43 insertions(+), 18 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index f785a85bbc..88770affbc 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -363,6 +363,7 @@ \newcommand{\myifthenelse}[3]{\kw{if} ~ #1 ~\kw{then} ~ #2 ~ \kw{else} ~ #3} \newcommand{\fun}[2]{\item[]{\tt {#1}}. \quad\\ #2} \newcommand{\WF}[2]{\ensuremath{{\cal W\!F}(#1)[#2]}} +\newcommand{\WFTWOLINES}[2]{\ensuremath{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}}} \newcommand{\WFE}[1]{\WF{E}{#1}} \newcommand{\WT}[4]{\ensuremath{#1[#2] \vdash #3 : #4}} \newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 3b0a204e3b..6b75fa5216 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1644,13 +1644,12 @@ Abort. The principles of mutual induction can be automatically generated using the {\tt Scheme} command described in Section~\ref{Scheme}. -\section{Derived rules for global environments} +\section{Admissible rules for global environments} -From the original rules of the type system, one can derive new rules -which change the local context of definition of objects in the global environment. -Because these rules correspond to elementary operations in the \Coq\ -engine used in the discharge mechanism at the end of a section, we -state them explicitly. +From the original rules of the type system, one can show the +admissibility of rules which change the local context of definition of +objects in the global environment. We show here the admissible rules +that are used used in the discharge mechanism at the end of a section. % This is obsolete: Abstraction over defined constants actually uses a % let-in since there are let-ins in Coq @@ -1669,23 +1668,48 @@ state them explicitly. \paragraph{Abstraction.} -One can modify the definition of a constant $c$ by generalizing it -over a previously assumed constant $c'$. For doing that, we need -to modify the reference to $c$ in the subsequent global environment -and local context by explicitly applying this constant to the constant $c'$. +One can modify a global declaration by generalizing it over a +previously assumed constant $c$. For doing that, we need to modify the +reference to the global declaration in the subsequent global +environment and local context by explicitly applying this constant to +the constant $c'$. + +Below, if $\Gamma$ is a context of the form +$[y_1:A_1;\ldots;y_n:A_n]$, we write $\forall +x:U,\subst{\Gamma}{c}{x}$ to mean +$[y_1:\forall~x:U,\subst{A_1}{c}{x};\ldots;y_n:\forall~x:U,\subst{A_n}{c}{x}]$ +and +$\subst{E}{|\Gamma|}{|\Gamma|c}$. +to mean the parallel substitution +$\subst{\subst{E}{y_1}{(y_1~c)}\ldots}{y_n}{(y_n~c)}$. \paragraph{First abstracting property:} - \inference{\frac{\WF{E;c':U;E';c:=t:T;E''}{\Gamma}} - {\WF{E;c':U;E';c:=\lb x:U\mto \subst{t}{c'}{x}:\forall~x:U,\subst{T}{c'}{x}; - \subst{E''}{c}{(c~c')}}{\subst{\Gamma}{c}{(c~c')}}}} + \inference{\frac{\WF{E;c:U;E';c':=t:T;E''}{\Gamma}} + {\WF{E;c:U;E';c':=\lb x:U\mto \subst{t}{c}{x}:\forall~x:U,\subst{T}{c}{x}; + \subst{E''}{c'}{(c'~c)}}{\subst{\Gamma}{c}{(c~c')}}}} -One can similarly modify the definition of a constant $c$ by generalizing it -over a previously defined constant $c'$. + \inference{\frac{\WF{E;c:U;E';c':T;E''}{\Gamma}} + {\WF{E;c:U;E';c':\forall~x:U,\subst{T}{c}{x}; + \subst{E''}{c'}{(c'~c)}}{\subst{\Gamma}{c}{(c~c')}}}} + + \inference{\frac{\WF{E;c:U;E';\Ind{}{p}{\Gamma_I}{\Gamma_C};E''}{\Gamma}} + {\WFTWOLINES{E;c:U;E';\Ind{}{p+1}{\forall x:U,\subst{\Gamma_I}{c}{x}}{\forall x:U,\subst{\Gamma_C}{c}{x}};\subst{E''}{|\Gamma_I,\Gamma_C|}{|\Gamma_I,\Gamma_C|~c}}{\subst{\Gamma}{|\Gamma_I,\Gamma_C|}{|\Gamma_I,\Gamma_C|~c}}}} + +One can similarly modify a global declaration by generalizing it over +a previously defined constant~$c'$. Below, if $\Gamma$ is a context +of the form $[y_1:A_1;\ldots;y_n:A_n]$, we write $ +\subst{\Gamma}{c}{u}$ to mean +$[y_1:\subst{A_1}{c}{u};\ldots;y_n:\subst{A_n}{c}{u}]$. \paragraph{Second abstracting property:} - \inference{\frac{\WF{E;c':=u:U;E';c:=t:T;E''}{\Gamma}} - {\WF{E;c':=u:U;E';c:=(\letin{x}{u:U}{\subst{t}{c'}{x}}):\subst{T}{c'}{u}; - E''}{\Gamma}}} + \inference{\frac{\WF{E;c:=u:U;E';c':=t:T;E''}{\Gamma}} + {\WF{E;c:=u:U;E';c':=(\letin{x}{u:U}{\subst{t}{c}{x}}):\subst{T}{c}{u};E''}{\Gamma}}} + + \inference{\frac{\WF{E;c:=u:U;E';c':T;E''}{\Gamma}} + {\WF{E;c:=u:U;E';c':\subst{T}{c}{u};E''}{\Gamma}}} + + \inference{\frac{\WF{E;c:=u:U;E';\Ind{}{p}{\Gamma_I}{\Gamma_C};E''}{\Gamma}} + {\WF{E;c:=u:U;E';\Ind{}{p}{\subst{\Gamma_I}{c}{u}}{\subst{\Gamma_C}{c}{u}};E''}{\Gamma}}} \paragraph{Pruning the local context.} If one abstracts or substitutes constants with the above rules then it -- cgit v1.2.3 From b94bdd32024675b546642c710539f8d583df4e94 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 18 Oct 2015 21:07:27 +0200 Subject: RefMan, ch. 4: Removing the local context of inductive definitions. --- doc/common/macros.tex | 4 +- doc/refman/RefMan-cic.tex | 101 +++++++++++++++++++++++----------------------- 2 files changed, 52 insertions(+), 53 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 88770affbc..ff13ec4557 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -393,9 +393,9 @@ \newcommand{\CIPI}[1]{\CIP{#1}{I}{P}} \newcommand{\CIF}[1]{\mbox{$\{#1\}_{f_1.. f_n}$}} %BEGIN LATEX -\newcommand{\NInd}[3]{\mbox{{\sf Ind}$(#1)(\begin{array}[t]{@{}l}#2:=#3 +\newcommand{\NInd}[3]{\mbox{{\sf Ind}$(\begin{array}[t]{@{}l}#2:=#3 \,)\end{array}$}} -\newcommand{\Ind}[4]{\mbox{{\sf Ind}$(#1)[#2](\begin{array}[t]{@{}l@{}}#3:=#4 +\newcommand{\Ind}[4]{\mbox{{\sf Ind}$[#2](\begin{array}[t]{@{}l@{}}#3:=#4 \,)\end{array}$}} %END LATEX %HEVEA \newcommand{\NInd}[3]{\mbox{{\sf Ind}$(#1)(#2:=#3\,)$}} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 6b75fa5216..a41e1f398b 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -531,7 +531,7 @@ definitions, one for constructors). Stating the rules for inductive definitions in their general form needs quite tedious definitions. We shall try to give a concrete -understanding of the rules by precising them on running examples. We +understanding of the rules by illustrating them on running examples. We take as examples the type of natural numbers, the type of parameterized lists over a type $A$, the relation which states that a list has some given length and the mutual inductive definition of trees and @@ -539,36 +539,38 @@ forests. \subsection{Representing an inductive definition} \subsubsection{Inductive definitions without parameters} -As for constants, inductive definitions can be defined in a non-empty +As for constants, inductive definitions must be defined in a non-empty local context. \\ -We write \NInd{\Gamma}{\Gamma_I}{\Gamma_C} an inductive -definition valid in a local context $\Gamma$, a +We write \NInd{}{\Gamma_I}{\Gamma_C} for an inductive +definition with a context of type definitions $\Gamma_I$ and a context of constructors $\Gamma_C$. \paragraph{Examples.} The inductive declaration for the type of natural numbers will be: \[\NInd{}{\nat:\Set}{\nO:\nat,\nS:\nat\ra\nat}\] -In a local context with a variable $A:\Set$, the lists of elements in $A$ are +In a context with assumption $A:\Set$, the lists of elements in $A$ are represented by: -\[\NInd{A:\Set}{\List:\Set}{\Nil:\List,\cons : A \ra \List \ra +\[\NInd{}{\List:\Set}{\Nil:\List,\cons : A \ra \List \ra \List}\] - Assuming - $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is - $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are, - for $1\leq j\leq k$ and $1\leq i\leq n$: +%% Assuming +%% $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is +%% $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are, +%% for $1\leq j\leq k$ and $1\leq i\leq n$: -\bigskip -\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}} +%% \bigskip -\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}} +%% \item[Ind] \index{Typing rules!Ind} +%% \inference{\frac{\NInd{}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}} +%% \item[Constr] \index{Typing rules!Constr} + +%% \inference{\frac{\NInd{}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}} \subsubsection{Inductive definitions with parameters} -We have to slightly complicate the representation above in order to handle -the delicate problem of parameters. +We have refine the representation above in order to handle parameters. Let us explain that on the example of \List. With the above definition, the type \List\ can only be used in a global environment where we -have a variable $A:\Set$. Generally one want to consider lists of +have a variable $A:\Set$. Generally one wants to consider lists of elements in different types. For constants this is easily done by abstracting the value over the parameter. In the case of inductive definitions we have to handle the abstraction over several objects. @@ -648,22 +650,22 @@ parameters. Formally the representation of an inductive declaration will be -\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} for an inductive -definition valid in a local context $\Gamma$ with $p$ parameters, a +\Ind{}{p}{\Gamma_I}{\Gamma_C} for an inductive +definition with $p$ parameters, a context of definitions $\Gamma_I$ and a context of constructors $\Gamma_C$. -The definition \Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} will be -well-formed exactly when \NInd{\Gamma}{\Gamma_I}{\Gamma_C} is and +The definition \Ind{}{p}{\Gamma_I}{\Gamma_C} will be +well-formed exactly when \NInd{}{\Gamma_I}{\Gamma_C} is and when $p$ is (less or equal than) the number of parameters in -\NInd{\Gamma}{\Gamma_I}{\Gamma_C}. +\NInd{}{\Gamma_I}{\Gamma_C}. \paragraph{Examples} The declaration for parameterized lists is: \[\Ind{}{1}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set,\List~A),\cons : (\forall A:\Set, A \ra \List~A \ra \List~A)}\] -The declaration for the length of lists is: +The declaration for an inductive type specifying the length of lists is: \[\Ind{}{1}{\Length:\forall A:\Set, (\List~A)\ra \nat\ra\Prop} {\LNil:\forall A:\Set, \Length~A~(\Nil~A)~\nO,\\ \LCons :\forall A:\Set,\forall a:A, \forall l:(\List~A),\forall n:\nat, (\Length~A~l~n)\ra (\Length~A~(\cons~A~a~l)~(\nS~n))}\] @@ -674,7 +676,7 @@ The declaration for a mutual inductive definition of forests and trees is: \emptyf:\forest,\consf:\tree \ra \forest \ra \forest\-}\] These representations are the ones obtained as the result of the \Coq\ -declaration: +declarations: \begin{coq_example*} Inductive nat : Set := | O : nat @@ -731,16 +733,13 @@ We have to give the type of constants in a global environment $E$ which contains an inductive declaration. \begin{description} -\item[Ind-Const] Assuming - $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is - $[c_1:C_1;\ldots;c_n:C_n]$, - -\inference{\frac{\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E - ~~j=1\ldots k}{(I_j:A_j) \in E}} - -\inference{\frac{\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E - ~~~~i=1.. n} - {(c_i:C_i) \in E}} +\item[Ind] \index{Typing rules!Ind} +\inference{\frac{\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}} +\inference{\frac{\WFE{\Gamma}~~~~\NInd{}{\Gamma_I}{\Gamma_C} \in E}{\WTEG{I_j}{A_j}}} +\item[Constr] \index{Typing rules!Constr} + +\inference{\frac{\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}} +\inference{\frac{\WFE{\Gamma}~~~~\NInd{}{\Gamma_I}{\Gamma_C} \in E}{\WTEG{c_i}{C_i}}} \end{description} \paragraph{Example.} @@ -846,20 +845,20 @@ inductive definition. \begin{description} \item[W-Ind] Let $E$ be a global environment and - $\Gamma,\Gamma_P,\Gamma_I,\Gamma_C$ are contexts such that + $\Gamma_P,\Gamma_I,\Gamma_C$ are contexts such that $\Gamma_I$ is $[I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ and $\Gamma_C$ is $[c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall \Gamma_P,C_n]$. \inference{ \frac{ - (\WTE{\Gamma;\Gamma_P}{A_j}{s'_j})_{j=1\ldots k} - ~~ (\WTE{\Gamma;\Gamma_I;\Gamma_P}{C_i}{s_{q_i}})_{i=1\ldots n} + (\WTE{\Gamma_P}{A_j}{s'_j})_{j=1\ldots k} + ~~ (\WTE{\Gamma_I;\Gamma_P}{C_i}{s_{q_i}})_{i=1\ldots n} } - {\WF{E;\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}}{\Gamma}}} + {\WF{E;\Ind{}{p}{\Gamma_I}{\Gamma_C}}{\Gamma}}} provided that the following side conditions hold: \begin{itemize} \item $k>0$ and all of $I_j$ and $c_i$ are distinct names for $j=1\ldots k$ and $i=1\ldots n$, -\item $p$ is the number of parameters of \NInd{\Gamma}{\Gamma_I}{\Gamma_C} +\item $p$ is the number of parameters of \NInd{}{\Gamma_I}{\Gamma_C} and $\Gamma_P$ is the context of parameters, \item for $j=1\ldots k$ we have that $A_j$ is an arity of sort $s_j$ and $I_j \notin \Gamma \cup E$, @@ -871,7 +870,7 @@ provided that the following side conditions hold: One can remark that there is a constraint between the sort of the arity of the inductive type and the sort of the type of its constructors which will always be satisfied for the impredicative sort -(\Prop) but may fail to define inductive definition +{\Prop} but may fail to define inductive definition on sort \Set{} and generate constraints between universes for inductive definitions in the {\Type} hierarchy. @@ -917,7 +916,7 @@ by typability of all products in the Calculus of Inductive Constructions. The following typing rule is added to the theory. \begin{description} -\item[Ind-Family] Let $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ be an +\item[Ind-Family] Let $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ be an inductive definition. Let $\Gamma_P = [p_1:P_1;\ldots;p_{p}:P_{p}]$ be its local context of parameters, $\Gamma_I = [I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ its context of @@ -937,13 +936,13 @@ The following typing rule is added to the theory. \inference{\frac {\left\{\begin{array}{l} -\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E\\ -(E[\Gamma] \vdash q_l : P'_l)_{l=1\ldots r}\\ +\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\\ +(E[] \vdash q_l : P'_l)_{l=1\ldots r}\\ (\WTEGLECONV{P'_l}{\subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}})_{l=1\ldots r}\\ 1 \leq j \leq k \end{array} \right.} -{E[\Gamma] \vdash (I_j\,q_1\,\ldots\,q_r:\forall [p_{r+1}:P_{r+1};\ldots;p_{p}:P_{p}], (A_j)_{/s_j})} +{E[] \vdash (I_j\,q_1\,\ldots\,q_r:\forall [p_{r+1}:P_{r+1};\ldots;p_{p}:P_{p}], (A_j)_{/s_j})} } provided that the following side conditions hold: @@ -955,7 +954,7 @@ $P_l$ arity implies $P'_l$ arity since $\WTEGLECONV{P'_l}{ \subst{P_l}{p_u}{q_u} \item there are sorts $s_i$, for $1 \leq i \leq k$ such that, for $\Gamma_{I'} = [I_1:\forall \Gamma_{P'},(A_1)_{/s_1};\ldots;I_k:\forall \Gamma_{P'},(A_k)_{/s_k}]$ -we have $(\WTE{\Gamma;\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; +we have $(\WTE{\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; \item the sorts are such that all eliminations, to {\Prop}, {\Set} and $\Type(j)$, are allowed (see section~\ref{elimdep}). \end{itemize} @@ -965,12 +964,12 @@ Notice that if $I_j\,q_1\,\ldots\,q_r$ is typable using the rules {\bf Ind-Const} and {\bf App}, then it is typable using the rule {\bf Ind-Family}. Conversely, the extended theory is not stronger than the theory without {\bf Ind-Family}. We get an equiconsistency result by -mapping each $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ occurring into a +mapping each $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ occurring into a given derivation into as many different inductive types and constructors as the number of different (partial) replacements of sorts, needed for this derivation, in the parameters that are arities (this is possible -because $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ well-formed implies -that $\Ind{\Gamma}{p}{\Gamma_{I'}}{\Gamma_{C'}}$ is well-formed and +because $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ well-formed implies +that $\Ind{}{p}{\Gamma_{I'}}{\Gamma_{C'}}$ is well-formed and has the same allowed eliminations, where $\Gamma_{I'}$ is defined as above and $\Gamma_{C'} = [c_1:\forall \Gamma_{P'},C_1;\ldots;c_n:\forall \Gamma_{P'},C_n]$). That is, @@ -980,7 +979,7 @@ sorts among the types of parameters, and to each signature is associated a new inductive definition with fresh names. Conversion is preserved as any (partial) instance $I_j\,q_1\,\ldots\,q_r$ or $C_i\,q_1\,\ldots\,q_r$ is mapped to the names chosen in the specific -instance of $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$. +instance of $\Ind{}{p}{\Gamma_I}{\Gamma_C}$. \newcommand{\Single}{\mbox{\textsf{Set}}} @@ -1396,7 +1395,7 @@ following typing rule {\WTEG{\Case{P}{c}{f_1|\ldots |f_l}}{(P\ t_1\ldots t_s\ c)}}}%\\[3mm] provided $I$ is an inductive type in a declaration -\Ind{\Delta}{r}{\Gamma_I}{\Gamma_C} with +\Ind{}{r}{\Gamma_I}{\Gamma_C} with $\Gamma_C = [c_1:C_1;\ldots;c_n:C_n]$ and $c_{p_1}\ldots c_{p_l}$ are the only constructors of $I$. \end{description} @@ -1511,7 +1510,7 @@ syntactically recognized as structurally smaller than $y_{k_i}$ The definition of being structurally smaller is a bit technical. One needs first to define the notion of {\em recursive arguments of a constructor}\index{Recursive arguments}. -For an inductive definition \Ind{\Gamma}{r}{\Gamma_I}{\Gamma_C}, +For an inductive definition \Ind{}{r}{\Gamma_I}{\Gamma_C}, the type of a constructor $c$ has the form $\forall p_1:P_1,\ldots \forall p_r:P_r, \forall x_1:T_1, \ldots \forall x_r:T_r, (I_j~p_1\ldots @@ -1522,7 +1521,7 @@ which one of the $I_l$ occurs. The main rules for being structurally smaller are the following:\\ Given a variable $y$ of type an inductive definition in a declaration -\Ind{\Gamma}{r}{\Gamma_I}{\Gamma_C} +\Ind{}{r}{\Gamma_I}{\Gamma_C} where $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is $[c_1:C_1;\ldots;c_n:C_n]$. The terms structurally smaller than $y$ are: -- cgit v1.2.3 From a9fd632cfa7377aebdcb03ee015384d09ba6bd98 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 19 Oct 2015 16:27:53 +0200 Subject: RefMan, ch. 4: Misc. local improvements and typesetting. --- doc/refman/RefMan-cic.tex | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index a41e1f398b..baef635933 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -48,7 +48,7 @@ says {\em convertible}). Convertibility is presented in section The reader seeking a background on the Calculus of Inductive Constructions may read several papers. In addition to the references given above, Giménez and Castéran~\cite{GimCas05} provide -an introduction to inductive and co-inductive definitions in Coq. In +an introduction to inductive and co-inductive definitions in {\Coq}. In their book~\cite{CoqArt}, Bertot and Castéran give a description of the \CIC{} based on numerous practical examples. Barras~\cite{Bar99}, Werner~\cite{Wer94} and @@ -120,15 +120,15 @@ Formally, we call {\Sort} the set of sorts which is defined by: \index{Set@{\Set}} The sorts enjoy the following properties\footnote{In the Reference - Manual of versions of Coq prior to 8.4, the level of {\Type} typing - {\Prop} and {\Set} was numbered $0$. From Coq 8.4, it started to be + Manual of versions of {\Coq} prior to 8.4, the level of {\Type} typing + {\Prop} and {\Set} was numbered $0$. From {\Coq} 8.4, it started to be numbered $1$ so as to be able to leave room for re-interpreting {\Set} in the hierarchy as {\Type$(0)$}. This change also put the reference manual in accordance with the internal conventions adopted in the implementation.}: {\Prop:\Type$(1)$}, {\Set:\Type$(1)$} and {\Type$(i)$:\Type$(i+1)$}. -The user will never mention explicitly the index $i$ when referring to +The user does not have to mention explicitly the index $i$ when referring to the universe \Type$(i)$. One only writes \Type. The system itself generates for each instance of \Type\ a new index for the universe and checks that the constraints between these @@ -203,14 +203,14 @@ More precisely the language of the {\em Calculus of Inductive %\item constructors are terms. %\item inductive types are terms. \item if $x$ is a variable and $T$, $U$ are terms then $\forall~x:T,U$ - ($\kw{forall}~x:T,U$ in \Coq{} concrete syntax) is a term. If $x$ + ($\kw{forall}~x:T,~U$ in \Coq{} concrete syntax) is a term. If $x$ occurs in $U$, $\forall~x:T,U$ reads as {\it ``for all x of type T, U''}. As $U$ depends on $x$, one says that $\forall~x:T,U$ is a {\em dependent product}. If $x$ doesn't occurs in $U$ then $\forall~x:T,U$ reads as {\it ``if T then U''}. A non dependent product can be written: $T \rightarrow U$. \item if $x$ is a variable and $T$, $U$ are terms then $\lb x:T \mto U$ - ($\kw{fun}~x:T\Ra U$ in \Coq{} concrete syntax) is a term. This is a + ($\kw{fun}~x:T~ {\tt =>}~ U$ in \Coq{} concrete syntax) is a term. This is a notation for the $\lambda$-abstraction of $\lambda$-calculus\index{lambda-calculus@$\lambda$-calculus} \cite{Bar81}. The term $\lb x:T \mto U$ is a function which maps @@ -249,11 +249,11 @@ variable $x$ in a term $u$ is defined as usual. The resulting term is written $\subst{u}{x}{t}$. -\section[Typed terms]{Typed terms\label{Typed-terms}} +\section[Typing rules]{Typing rules\label{Typed-terms}} As objects of type theory, terms are subjected to {\em type discipline}. The well typing of a term depends on -a global environment (see below) and a local context. +a global environment and a local context. \paragraph{Local context.} A {\em local context} is an ordered list of @@ -375,7 +375,7 @@ be derived from the following rules. {\WTEG{\letin{x}{t:T}{u}}{\subst{U}{x}{t}}}} \end{description} -\Rem We may have $\letin{x}{t:T}{u}$ +\Rem We may have $\kw{let}~x:=t~\kw{in}~u$ well-typed without having $((\lb x:T\mto u)~t)$ well-typed (where $T$ is a type of $t$). This is because the value $t$ associated to $x$ may be used in a conversion rule (see Section~\ref{conv-rules}). @@ -628,7 +628,7 @@ But the following definition has $0$ parameters: %$\NInd{}{\List:\Set\ra\Set}{\Nil:(A:\Set)(\List~A),\cons : (A:\Set)A % \ra (\List~A\ra A) \ra (\List~A)}$.} \paragraph{Concrete syntax.} -In the Coq system, the local context of parameters is given explicitly +In the {\Coq} system, the local context of parameters is given explicitly after the name of the inductive definitions and is shared between the arities and the type of constructors. % The vernacular declaration of polymorphic trees and forests will be:\\ @@ -906,7 +906,7 @@ Inductive exType (P:Type->Prop) : Type \paragraph[Sort-polymorphism of inductive types.]{Sort-polymorphism of inductive types.\index{Sort-polymorphism of inductive types}} \label{Sort-polymorphism-inductive} -From {\Coq} version 8.1, inductive types declared in {\Type} are +Inductive types declared in {\Type} are polymorphic over their arguments in {\Type}. If $A$ is an arity of some sort and $s$ is a sort, we write $A_{/s}$ for the arity @@ -1113,7 +1113,7 @@ at the computational level it implements a generic operator for doing primitive recursion over the structure. But this operator is rather tedious to implement and use. We choose in -this version of Coq to factorize the operator for primitive recursion +this version of {\Coq} to factorize the operator for primitive recursion into two more primitive operations as was first suggested by Th. Coquand in~\cite{Coq92}. One is the definition by pattern-matching. The second one is a definition by guarded fixpoints. -- cgit v1.2.3 From c033eb2624b5b25ddf4c2c35d700c46eba86e27d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 18 Oct 2015 22:09:07 +0200 Subject: RefMan, ch. 4: Rephrasing and moving paragraph on the double reading proof/program of the syntax. --- doc/refman/RefMan-cic.tex | 46 +++++++++++++++++++++++++++++++--------------- doc/refman/biblio.bib | 9 +++++++++ 2 files changed, 40 insertions(+), 15 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index baef635933..b09367a2a9 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -68,21 +68,6 @@ a mutual recursive way and also because similar constructions can be applied to both terms and types and consequently can share the same syntactic structure. -Consider for instance the $\ra$ constructor and assume \nat\ is the -type of natural numbers. Then $\ra$ is used both to denote -$\nat\ra\nat$ which is the type of functions from \nat\ to \nat, and -to denote $\nat \ra \Prop$ which is the type of unary predicates over -the natural numbers. Consider abstraction which builds functions. It -serves to build ``ordinary'' functions as $\kw{fun}~x:\nat \Ra ({\tt mult} ~x~x)$ (assuming {\tt mult} is already defined) but may build also -predicates over the natural numbers. For instance $\kw{fun}~x:\nat \Ra -(x=x)$ will -represent a predicate $P$, informally written in mathematics -$P(x)\equiv x=x$. If $P$ has type $\nat \ra \Prop$, $(P~x)$ is a -proposition, furthermore $\kw{forall}~x:\nat,(P~x)$ will represent the type of -functions which associate to each natural number $n$ an object of -type $(P~n)$ and consequently represent proofs of the formula -``$\forall x.P(x)$''. - \subsection[Sorts]{Sorts\label{Sorts} \index{Sorts}} When manipulated as terms, types have themselves a type which is called a sort. @@ -248,6 +233,37 @@ The notion of substituting a term $t$ to free occurrences of a variable $x$ in a term $u$ is defined as usual. The resulting term is written $\subst{u}{x}{t}$. +\paragraph[The logical vs programming readings.]{The logical vs programming readings.} + +The constructions of the {\CIC} can be used to express both logical +and programming notions, accordingly to the Curry-Howard +correspondence between proofs and programs, and between propositions +and types~\cite{Cur58,How80,Bru72}. + +For instance, let us assume that \nat\ is the type of natural numbers +with zero element written $0$ and that ${\tt True}$ is the always true +proposition. Then $\ra$ is used both to denote $\nat\ra\nat$ which is +the type of functions from \nat\ to \nat, to denote ${\tt True}\ra{\tt + True}$ which is an implicative proposition, to denote $\nat \ra +\Prop$ which is the type of unary predicates over the natural numbers, +etc. + +Let us assume that ${\tt mult}$ is a function of type $\nat\ra\nat\ra +\nat$ and ${\tt eqnat}$ a predicate of type $\nat\ra\nat\ra \Prop$. +The $\lambda$-abstraction can serve to build ``ordinary'' functions as +in $\lambda x:\nat.({\tt mult}~x~x)$ (i.e. $\kw{fun}~x:\nat ~{\tt =>}~ +{\tt mult} ~x~x$ in {\Coq} notation) but may build also predicates +over the natural numbers. For instance $\lambda x:\nat.({\tt eqnat}~ +x~0)$ (i.e. $\kw{fun}~x:\nat ~{\tt =>}~ {\tt eqnat}~ x~0$ in {\Coq} +notation) will represent the predicate of one variable $x$ which +asserts the equality of $x$ with $0$. This predicate has type $\nat +\ra \Prop$ and it can be applied to any expression of type ${\nat}$, +say $t$, to give an object $P~t$ of type \Prop, namely a proposition. + +Furthermore $\kw{forall}~x:\nat,\,P\;x$ will represent the type of +functions which associate to each natural number $n$ an object of type +$(P~n)$ and consequently represent the type of proofs of the formula +``$\forall x.\,P(x)$''. \section[Typing rules]{Typing rules\label{Typed-terms}} diff --git a/doc/refman/biblio.bib b/doc/refman/biblio.bib index 6f789b081c..70ee1f41f0 100644 --- a/doc/refman/biblio.bib +++ b/doc/refman/biblio.bib @@ -328,6 +328,15 @@ s}, year = {1994} } +@book{Cur58, + author = {Haskell B. Curry and Robert Feys and William Craig}, + title = {Combinatory Logic}, + volume = 1, + publisher = "North-Holland", + year = 1958, + note = {{\S{9E}}}, +} + @InProceedings{Del99, author = {Delahaye, D.}, title = {Information Retrieval in a Coq Proof Library using -- cgit v1.2.3 From 08857b1f4455e942aeba456affdb0f61eaa4266a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 22 Oct 2015 16:22:34 +0200 Subject: Smoothing the introduction and section Terms. --- doc/refman/RefMan-cic.tex | 66 +++++++++++++++++++++-------------------------- 1 file changed, 30 insertions(+), 36 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index b09367a2a9..a97fce8700 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -29,22 +29,6 @@ had an impredicative sort {\Set}. Since {\Coq} version 8.0, the sort {\Set} is predicative by default, with an option to make it impredicative (see Section~\ref{impredicativity}). -In \CIC\, all objects have a {\em type}. There are types for functions (or -programs), there are atomic types (especially datatypes)... but also -types for proofs and types for the types themselves. -Especially, any object handled in the formalism must belong to a -type. For instance, the statement {\it ``for all x, P''} is not -allowed in type theory; you must say instead: {\it ``for all x -of type T, P''}. The expression {\it ``x of type T''} is -written {\it ``x:T''}. Informally, {\it ``x:T''} can be thought as -{\it ``x belongs to T''}. -The terms of {\CIC} are detailed in Section~\ref{Terms}. - -In \CIC, there is an internal reduction mechanism. In particular, it -can decide if two programs are {\em intentionally} equal (one -says {\em convertible}). Convertibility is presented in section -\ref{convertibility}. - The reader seeking a background on the Calculus of Inductive Constructions may read several papers. In addition to the references given above, Giménez and Castéran~\cite{GimCas05} provide @@ -60,20 +44,26 @@ theory. \section[The terms]{The terms\label{Terms}} -In most type theories, one usually makes a syntactic distinction -between types and terms. This is not the case for \CIC\ which defines -both types and terms in the same syntactical structure. This is -because the type-theory itself forces terms and types to be defined in -a mutual recursive way and also because similar constructions can be -applied to both terms and types and consequently can share the same -syntactic structure. +The expressions of the {\CIC} are {\em terms} and all terms have a {\em type}. +There are types for functions (or +programs), there are atomic types (especially datatypes)... but also +types for proofs and types for the types themselves. +Especially, any object handled in the formalism must belong to a +type. For instance, universal quantification is relative to a type and +takes the form {\it ``for all x +of type T, P''}. The expression {\it ``x of type T''} is +written {\it ``x:T''}. Informally, {\it ``x:T''} can be thought as +{\it ``x belongs to T''}. + +The types of types are {\em sorts}. Types and sorts are themselves +terms so that terms, types and sorts are all components of a common +syntactic language of terms which is described in +Section~\label{cic:terms} but, first, we describe sorts. \subsection[Sorts]{Sorts\label{Sorts} \index{Sorts}} -When manipulated as terms, types have themselves a type which is called a sort. - -There is an infinite well-founded typing hierarchy of sorts whose base -sorts are {\Prop} and {\Set}. +All sorts have a type and there is an infinite well-founded +typing hierarchy of sorts whose base sorts are {\Prop} and {\Set}. The sort {\Prop} intends to be the type of logical propositions. If $M$ is a logical proposition then it denotes the class of terms @@ -167,6 +157,7 @@ inconsistency} error (see also Section~\ref{PrintingUniverses}). %% in a theory where inductive objects are represented by terms. \subsection{Terms} +\label{cic:terms} Terms are built from sorts, variables, constant, %constructors, inductive types, @@ -175,23 +166,22 @@ abstraction, application, local definitions, and products. From a syntactic point of view, types cannot be distinguished from terms, -except that they cannot start by an abstraction, and that if a term is -a sort or a product, it should be a type. +except that they cannot start by an abstraction or a constructor. More precisely the language of the {\em Calculus of Inductive - Constructions} is built from the following rules: + Constructions} is built from the following rules. \begin{enumerate} \item the sorts {\Set}, {\Prop}, ${\Type(i)}$ are terms. -\item variables are terms -\item constants are terms. -%\item constructors are terms. -%\item inductive types are terms. +\item variables, hereafter ranged over by letters $x$, $y$, etc., are terms +\item constants, hereafter ranged over by letters $c$, $d$, etc., are terms. +%\item constructors, hereafter ranged over by letter $C$, are terms. +%\item inductive types, hereafter ranged over by letter $I$, are terms. \item if $x$ is a variable and $T$, $U$ are terms then $\forall~x:T,U$ ($\kw{forall}~x:T,~U$ in \Coq{} concrete syntax) is a term. If $x$ occurs in $U$, $\forall~x:T,U$ reads as {\it ``for all x of type T, U''}. As $U$ depends on $x$, one says that $\forall~x:T,U$ is a - {\em dependent product}. If $x$ doesn't occurs in $U$ then + {\em dependent product}. If $x$ does not occur in $U$ then $\forall~x:T,U$ reads as {\it ``if T then U''}. A non dependent product can be written: $T \rightarrow U$. \item if $x$ is a variable and $T$, $U$ are terms then $\lb x:T \mto U$ @@ -199,7 +189,7 @@ More precisely the language of the {\em Calculus of Inductive notation for the $\lambda$-abstraction of $\lambda$-calculus\index{lambda-calculus@$\lambda$-calculus} \cite{Bar81}. The term $\lb x:T \mto U$ is a function which maps - elements of $T$ to $U$. + elements of $T$ to the expression $U$. \item if $T$ and $U$ are terms then $(T\ U)$ is a term ($T~U$ in \Coq{} concrete syntax). The term $(T\ U)$ reads as {\it ``T applied to U''}. @@ -400,6 +390,10 @@ may be used in a conversion rule (see Section~\ref{conv-rules}). \label{conv-rules}} \paragraph[$\beta$-reduction.]{$\beta$-reduction.\label{beta}\index{beta-reduction@$\beta$-reduction}} +In \CIC, there is an internal reduction mechanism. In particular, it +can decide if two programs are {\em intentionally} equal (one +says {\em convertible}). Convertibility is described in this section. + We want to be able to identify some terms as we can identify the application of a function to a given argument with its result. For instance the identity function over a given type $T$ can be written -- cgit v1.2.3 From f1f19693f16a914b167ebcb18e96aac25a582920 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 23 Oct 2015 17:56:15 +0200 Subject: fix --- doc/refman/RefMan-cic.tex | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index a97fce8700..f0046ffe6a 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -388,12 +388,13 @@ may be used in a conversion rule (see Section~\ref{conv-rules}). \section[Conversion rules]{Conversion rules\index{Conversion rules} \label{conv-rules}} -\paragraph[$\beta$-reduction.]{$\beta$-reduction.\label{beta}\index{beta-reduction@$\beta$-reduction}} In \CIC, there is an internal reduction mechanism. In particular, it can decide if two programs are {\em intentionally} equal (one says {\em convertible}). Convertibility is described in this section. +\paragraph[$\beta$-reduction.]{$\beta$-reduction.\label{beta}\index{beta-reduction@$\beta$-reduction}} + We want to be able to identify some terms as we can identify the application of a function to a given argument with its result. For instance the identity function over a given type $T$ can be written -- cgit v1.2.3 From da46d24c2645add913e187ebfc76590140ecd6ff Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 22 Oct 2015 16:43:33 +0200 Subject: Reformulating subtyping in a way closer to implementation. --- doc/refman/RefMan-cic.tex | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index f0046ffe6a..ac62abbe55 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -353,9 +353,9 @@ be derived from the following rules. \item[Assum] \inference{\frac{\WTE{}{T}{s}~~~~s \in \Sort~~~~c \notin E} {\WF{E;c:T}{}}} \item[Ax] \index{Typing rules!Ax} -\inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(p)}}~~~~~ -\frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(q)}}} -\inference{\frac{\WFE{\Gamma}~~~~i}~ U$ in \Coq{} concrete syntax) is a term. This is a +\item if $x$ is a variable and $T$, $u$ are terms then $\lb x:T \mto u$ + ($\kw{fun}~x:T~ {\tt =>}~ u$ in \Coq{} concrete syntax) is a term. This is a notation for the $\lambda$-abstraction of $\lambda$-calculus\index{lambda-calculus@$\lambda$-calculus} - \cite{Bar81}. The term $\lb x:T \mto U$ is a function which maps - elements of $T$ to the expression $U$. -\item if $T$ and $U$ are terms then $(T\ U)$ is a term - ($T~U$ in \Coq{} concrete syntax). The term $(T\ - U)$ reads as {\it ``T applied to U''}. -\item if $x$ is a variable, and $T$, $U$ are terms then - $\kw{let}~x:=T~\kw{in}~U$ is a - term which denotes the term $U$ where the variable $x$ is locally - bound to $T$. This stands for the common ``let-in'' construction of - functional programs such as ML or Scheme. + \cite{Bar81}. The term $\lb x:T \mto u$ is a function which maps + elements of $T$ to the expression $u$. +\item if $t$ and $u$ are terms then $(t\ u)$ is a term + ($t~u$ in \Coq{} concrete syntax). The term $(t\ + u)$ reads as {\it ``t applied to u''}. +\item if $x$ is a variable, and $t$, $T$ and $u$ are terms then + $\kw{let}~x:=t:T~\kw{in}~u$ is a + term which denotes the term $u$ where the variable $x$ is locally + bound to $t$ of type $T$. This stands for the common ``let-in'' + construction of functional programs such as ML or Scheme. %\item case ... %\item fixpoint ... %\item cofixpoint ... @@ -208,9 +208,9 @@ $(t\;t_1\;t_2\ldots t_n)$ represents $(\ldots ((t\;t_1)\;t_2)\ldots t_n)$. The products and arrows associate to the right such that $\forall~x:A,B\ra C\ra D$ represents $\forall~x:A,(B\ra (C\ra D))$. One uses sometimes $\forall~x~y:A,B$ or -$\lb x~y:A\mto B$ to denote the abstraction or product of several variables +$\lb x~y:A\mto t$ to denote the abstraction or product of several variables of the same type. The equivalent formulation is $\forall~x:A, \forall y:A,B$ or -$\lb x:A \mto \lb y:A \mto B$ +$\lb x:A \mto \lb y:A \mto t$ \paragraph{Free variables.} The notion of free variables is defined as usual. In the expressions @@ -379,7 +379,7 @@ be derived from the following rules. {\WTEG{\letin{x}{t:T}{u}}{\subst{U}{x}{t}}}} \end{description} -\Rem We may have $\kw{let}~x:=t~\kw{in}~u$ +\Rem We may have $\kw{let}~x:=t:T~\kw{in}~u$ well-typed without having $((\lb x:T\mto u)~t)$ well-typed (where $T$ is a type of $t$). This is because the value $t$ associated to $x$ may be used in a conversion rule (see Section~\ref{conv-rules}). -- cgit v1.2.3 From 899b701462fa056a22f997ae22c5ef7c1d247673 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 22 Oct 2015 21:01:29 +0200 Subject: Starting revising inductive types session --- doc/refman/RefMan-cic.tex | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 8e1a1766e5..5002b905c7 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -534,11 +534,11 @@ reductions or any combination of those can also be defined. \section[Inductive Definitions]{Inductive Definitions\label{Cic-inductive-definitions}} A (possibly mutual) inductive definition is specified by giving the -names and the type of the inductive sets or families to be -defined and the names and types of the constructors of the inductive -predicates. An inductive declaration in the global environment can -consequently be represented with two local contexts (one for inductive -definitions, one for constructors). +names and types of the inductive types to be +defined and the names and types of the constructors of the inductive types. +An inductive declaration in the global environment can +consequently be represented with two local contexts, one for the types +one for the constructors. Stating the rules for inductive definitions in their general form needs quite tedious definitions. We shall try to give a concrete -- cgit v1.2.3 From 5330263aaccb3ba9e7fcb8fada0737491fd99645 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 23 Oct 2015 17:51:06 +0200 Subject: Removing note on shifting the hierarchy by 1 in 8.4, which makes things more complicated than needed. --- doc/refman/RefMan-cic.tex | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 5002b905c7..08e962ebe2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -94,13 +94,14 @@ Formally, we call {\Sort} the set of sorts which is defined by: \index{Prop@{\Prop}} \index{Set@{\Set}} -The sorts enjoy the following properties\footnote{In the Reference +The sorts enjoy the following properties%\footnote{In the Reference Manual of versions of {\Coq} prior to 8.4, the level of {\Type} typing {\Prop} and {\Set} was numbered $0$. From {\Coq} 8.4, it started to be numbered $1$ so as to be able to leave room for re-interpreting {\Set} in the hierarchy as {\Type$(0)$}. This change also put the reference manual in accordance with the internal conventions adopted - in the implementation.}: {\Prop:\Type$(1)$}, {\Set:\Type$(1)$} and + in the implementation.}% +: {\Prop:\Type$(1)$}, {\Set:\Type$(1)$} and {\Type$(i)$:\Type$(i+1)$}. The user does not have to mention explicitly the index $i$ when referring to -- cgit v1.2.3 From 17ca1e516bee3148ea7e3f272a443836c4949fc5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 23 Oct 2015 17:54:48 +0200 Subject: Changing representation of prod over two Type: since the rule needs subtyping anyway to manage the Set and Prop cases, why not to simplify it by using subtyping also for managing Type. --- doc/refman/RefMan-cic.tex | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 08e962ebe2..7986648fb9 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -95,12 +95,12 @@ Formally, we call {\Sort} the set of sorts which is defined by: \index{Set@{\Set}} The sorts enjoy the following properties%\footnote{In the Reference - Manual of versions of {\Coq} prior to 8.4, the level of {\Type} typing - {\Prop} and {\Set} was numbered $0$. From {\Coq} 8.4, it started to be - numbered $1$ so as to be able to leave room for re-interpreting - {\Set} in the hierarchy as {\Type$(0)$}. This change also put the - reference manual in accordance with the internal conventions adopted - in the implementation.}% + %% Manual of versions of {\Coq} prior to 8.4, the level of {\Type} typing + %% {\Prop} and {\Set} was numbered $0$. From {\Coq} 8.4, it started to be + %% numbered $1$ so as to be able to leave room for re-interpreting + %% {\Set} in the hierarchy as {\Type$(0)$}. This change also put the + %% reference manual in accordance with the internal conventions adopted + %% in the implementation.} : {\Prop:\Type$(1)$}, {\Set:\Type$(1)$} and {\Type$(i)$:\Type$(i+1)$}. @@ -366,9 +366,9 @@ be derived from the following rules. \inference{\frac{\WTEG{T}{s}~~~~s \in\{\Prop, \Set\}~~~~~~ \WTE{\Gamma::(x:T)}{U}{\Set}} { \WTEG{\forall~x:T,U}{\Set}}} -\inference{\frac{\WTEG{T}{\Type(i)}~~~~i\leq k~~~ - \WTE{\Gamma::(x:T)}{U}{\Type(j)}~~~j \leq k} - {\WTEG{\forall~x:T,U}{\Type(k)}}} +\inference{\frac{\WTEG{T}{\Type(i)}~~~~ + \WTE{\Gamma::(x:T)}{U}{\Type(i)}} + {\WTEG{\forall~x:T,U}{\Type(i)}}} \item[Lam]\index{Typing rules!Lam} \inference{\frac{\WTEG{\forall~x:T,U}{s}~~~~ \WTE{\Gamma::(x:T)}{t}{U}} {\WTEG{\lb x:T\mto t}{\forall x:T, U}}} -- cgit v1.2.3 From 41061d0dc42afe19b520059f36a98d4ec870825f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 09:05:48 +0100 Subject: CLEANUP PROPOSITION: Duplicate information was removed and replaced with a reference to the corresponding chapter. --- doc/refman/RefMan-cic.tex | 39 +++------------------------------------ 1 file changed, 3 insertions(+), 36 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 7986648fb9..c481b3adba 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -5,42 +5,9 @@ \index{Calculus of Inductive Constructions}} The underlying formal language of {\Coq} is a {\em Calculus of - Inductive Constructions} (\CIC) whose inference rules are presented in -this chapter. - -The {\CIC} implemented in {\Coq} -takes its name from Coquand and Paulin's {\em Calculus of - Inductive Constructions}~\cite{CoPa89} which itself extends -Coquand-Huet's {\em Calculus of - Constructions}~\cite{CoHu85a,CoHu85b,CoHu86,Coq85} with a universe -hierarchy~\cite{Coq86,Luo90,Hue88b} and a generic presentation of -inductive types à la Martin-L\"of~\cite{MaL84,Dyb91}. First implemented in -{\Coq} version 5.0, it incorporated coinductive -types~\cite{Coquand93,Gim96} from {\Coq} version 5.10. It -progressively extended with various new features such as local -definitions (since {\Coq} version 7.0), universe polymorphism (since -{\Coq} version 8.1 for inductive types and version 8.5 for full -polymorphism), recursively non-uniform parameters (since {\Coq} version 8.1), -some $\eta$-rules (for dependent product in {\Coq} -version 8.4, for record types in {\Coq} version 8.5), and other -refinements in the expressiveness of fixpoints and inductive types. -Up to version 7.4, the {\CIC} implemented in {\Coq} -had an impredicative sort {\Set}. Since {\Coq} version 8.0, the sort -{\Set} is predicative by default, with an option to make it -impredicative (see Section~\ref{impredicativity}). - -The reader seeking a background on the Calculus of Inductive -Constructions may read several papers. In addition to the references given above, Giménez and Castéran~\cite{GimCas05} -provide -an introduction to inductive and co-inductive definitions in {\Coq}. In -their book~\cite{CoqArt}, Bertot and Castéran give a -description of the \CIC{} based on numerous practical examples. -Barras~\cite{Bar99}, Werner~\cite{Wer94} and -Paulin-Mohring~\cite{Moh97} are dealing with -Inductive Definitions. The {\CIC} is a -formulation of type theory including the possibility of inductive -constructions, Barendregt~\cite{Bar91} studies the modern form of type -theory. +Inductive Constructions} (\CIC) whose inference rules are presented in +this chapter. The history of this formalism as well as pointers to related work +are provided in a separate chapter; see {\em Credits}. \section[The terms]{The terms\label{Terms}} -- cgit v1.2.3 From b23331eb03f2640e85bd65277c15a4bcc692b90c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 09:50:11 +0100 Subject: ENH: citation --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index c481b3adba..2c0f155388 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -44,7 +44,7 @@ function types over these data types. {\Prop} and {\Set} themselves can be manipulated as ordinary terms. Consequently they also have a type. Because assuming simply -that {\Set} has type {\Set} leads to an inconsistent theory, the +that {\Set} has type {\Set} leads to an inconsistent theory~\cite{Coq86}, the language of {\CIC} has infinitely many sorts. There are, in addition to {\Set} and {\Prop} a hierarchy of universes {\Type$(i)$} for any integer $i$. -- cgit v1.2.3 From e9db7237481e529f796d603f98965ca01e439386 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 09:52:53 +0100 Subject: CLEANUP PROPOSITION: Duplicate information was removed and replaced with a reference to the corresponding section. --- doc/refman/RefMan-cic.tex | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2c0f155388..834c8273a5 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -60,16 +60,7 @@ Formally, we call {\Sort} the set of sorts which is defined by: \index{Type@{\Type}} \index{Prop@{\Prop}} \index{Set@{\Set}} - -The sorts enjoy the following properties%\footnote{In the Reference - %% Manual of versions of {\Coq} prior to 8.4, the level of {\Type} typing - %% {\Prop} and {\Set} was numbered $0$. From {\Coq} 8.4, it started to be - %% numbered $1$ so as to be able to leave room for re-interpreting - %% {\Set} in the hierarchy as {\Type$(0)$}. This change also put the - %% reference manual in accordance with the internal conventions adopted - %% in the implementation.} -: {\Prop:\Type$(1)$}, {\Set:\Type$(1)$} and -{\Type$(i)$:\Type$(i+1)$}. +Their properties are defined in Section~\ref{subtyping-rules}. The user does not have to mention explicitly the index $i$ when referring to the universe \Type$(i)$. One only writes \Type. The -- cgit v1.2.3 From 0117f54f3e3678f348f8ed84c8444dc614ce8298 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 10:03:30 +0100 Subject: COMMENT: to do --- doc/refman/RefMan-cic.tex | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 834c8273a5..505587988c 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -62,6 +62,11 @@ Formally, we call {\Sort} the set of sorts which is defined by: \index{Set@{\Set}} Their properties are defined in Section~\ref{subtyping-rules}. +% TODO: Somewhere in the document we should explain: +% - what concrete actions (in *.v files) cause creation of new universes +% - different kinds of relationships between universes (i.e. "max" and "succ") +% - what are all the actions (in *.v files) from which those relationships arise + The user does not have to mention explicitly the index $i$ when referring to the universe \Type$(i)$. One only writes \Type. The system itself generates for each instance of \Type\ a new -- cgit v1.2.3 From 950dace27c3233f740b2031c9d99cb3f155aefbf Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 10:22:37 +0100 Subject: ENH: Index anchor repositioning. Originally, when user clicked in index on "Type", he landed on an incorrect page (immediatelly following the page which actually contains the definition of "Type"). --- doc/refman/RefMan-cic.tex | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 505587988c..702adc2326 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -56,10 +56,10 @@ sets, namely the sorts {\Set} and {\Type$(j)$} for $j}~ u$ in \Coq{} concrete syntax) is a term. This is a notation for the $\lambda$-abstraction of diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index f631c3717c..0e758bcab6 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -468,8 +468,8 @@ proposition $B$ or the functional dependent product from $A$ to $B$ (a construction usually written $\Pi_{x:A}.B$ in set theory). Non dependent product types have a special notation: ``$A$ {\tt ->} -$B$'' stands for ``{\tt forall \_:}$A${\tt ,}~$B$''. The non dependent -product is used both to denote the propositional implication and +$B$'' stands for ``{\tt forall \_:}$A${\tt ,}~$B$''. The {\em non dependent +product} is used both to denote the propositional implication and function types. \subsection{Applications -- cgit v1.2.3 From 8f96f8194608c99ad8efa201c24b527dbc530537 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 12:08:49 +0100 Subject: CLEANUP PROPOSITION: The removed paragraph is not essential for this chapter. That kind of information is more appropriate for Section 1.2. --- doc/refman/RefMan-cic.tex | 9 --------- 1 file changed, 9 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index b1becba3f5..ed7889e480 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -178,15 +178,6 @@ More precisely the language of the {\em Calculus of Inductive %\item cofixpoint ... \end{enumerate} -\paragraph{Notations.} Application associates to the left such that -$(t\;t_1\;t_2\ldots t_n)$ represents $(\ldots ((t\;t_1)\;t_2)\ldots t_n)$. The -products and arrows associate to the right such that $\forall~x:A,B\ra C\ra -D$ represents $\forall~x:A,(B\ra (C\ra D))$. One uses sometimes -$\forall~x~y:A,B$ or -$\lb x~y:A\mto t$ to denote the abstraction or product of several variables -of the same type. The equivalent formulation is $\forall~x:A, \forall y:A,B$ or -$\lb x:A \mto \lb y:A \mto t$ - \paragraph{Free variables.} The notion of free variables is defined as usual. In the expressions $\lb x:T\mto U$ and $\forall x:T, U$ the occurrences of $x$ in $U$ -- cgit v1.2.3 From 1372e075c52aa2dad547a42eaf9aba1f83a7abb1 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 13:47:27 +0100 Subject: CLEANUP PROPOSITION: this sentence does not help us to better understand the semantics of the language --- doc/refman/RefMan-cic.tex | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ed7889e480..fb6a5bff83 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -181,8 +181,7 @@ More precisely the language of the {\em Calculus of Inductive \paragraph{Free variables.} The notion of free variables is defined as usual. In the expressions $\lb x:T\mto U$ and $\forall x:T, U$ the occurrences of $x$ in $U$ -are bound. They are represented by de Bruijn indexes in the internal -structure of terms. +are bound. \paragraph[Substitution.]{Substitution.\index{Substitution}} The notion of substituting a term $t$ to free occurrences of a -- cgit v1.2.3 From 3cebb15d999e6e26a98339ecb6fa7e62fdcf6a88 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 13:59:14 +0100 Subject: CLEANUP PROPOSITION: 'declaration' --> 'local declaration' If, below, we speak about 'global declarations', here it makes sense to speak about 'local declaration'. --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index fb6a5bff83..04df208ee2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -228,7 +228,7 @@ a global environment and a local context. \paragraph{Local context.} A {\em local context} is an ordered list of -declarations of names which we call {\em variables}. +local declarations of names which we call {\em variables}. The declaration of some variable $x$ is either a local assumption, written $x:T$ ($T$ is a type) or a local definition, written $x:=t:T$. We use brackets to write local contexts. A -- cgit v1.2.3 From cdd31465cee9ea8bef2a253280ee8a9647ecc01d Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 14:05:50 +0100 Subject: SILENT: the anchor for the 'Local context' was moved to a more appropriate place. --- doc/refman/RefMan-cic.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 04df208ee2..690bdad950 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -226,7 +226,7 @@ As objects of type theory, terms are subjected to {\em type discipline}. The well typing of a term depends on a global environment and a local context. -\paragraph{Local context.} +\paragraph{Local context.\index{Local context}} A {\em local context} is an ordered list of local declarations of names which we call {\em variables}. The declaration of some variable $x$ is @@ -241,7 +241,7 @@ $x:=t:T$, we also write $(x:=t:T) \in \Gamma$. For the rest of the chapter, the notation $\Gamma::(y:T)$ (resp. $\Gamma::(y:=t:T)$) denotes the local context $\Gamma$ enriched with the declaration $y:T$ (resp. $y:=t:T$). The -notation $[]$ denotes the empty local context. \index{Local context} +notation $[]$ denotes the empty local context. % Does not seem to be used further... % Si dans l'explication WF(E)[Gamma] concernant les constantes -- cgit v1.2.3 From 0a5ee78c32b5f48d8f90de1ff073e250db5033d6 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 14:39:31 +0100 Subject: ENH: 'Global Index' was enriched. These notions: - local assumption - local definition - global assumption - global definition are now indexed. --- doc/refman/RefMan-cic.tex | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 690bdad950..b0205b7e9e 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -228,9 +228,9 @@ a global environment and a local context. \paragraph{Local context.\index{Local context}} A {\em local context} is an ordered list of -local declarations of names which we call {\em variables}. +{\em local declarations\index{declaration!local}} of names which we call {\em variables\index{variable}}. The declaration of some variable $x$ is -either a local assumption, written $x:T$ ($T$ is a type) or a local definition, +either a {\em local assumption\index{assumption!local}}, written $x:T$ ($T$ is a type) or a {\em local definition\index{definition!local}}, written $x:=t:T$. We use brackets to write local contexts. A typical example is $[x:T;y:=u:U;z:V]$. Notice that the variables declared in a local context must be distinct. If $\Gamma$ declares some $x$, @@ -262,9 +262,9 @@ declaration $y:T$ such that $x$ is free in $T$. %Because we are manipulating global declarations (global constants and global %assumptions), we also need to consider a global environment $E$. -A {\em global environment} is an ordered list of global declarations. -Global declarations are either global assumptions or global -definitions, but also declarations of inductive objects. Inductive objects themselves declares both inductive or coinductive types and constructors +A {\em global environment} is an ordered list of {\em global declarations\index{declaration!global}}. +Global declarations are either {\em global assumptions\index{assumption!global}} or {\em global +definitions\index{definition!global}}, but also declarations of inductive objects. Inductive objects themselves declares both inductive or coinductive types and constructors (see Section~\ref{Cic-inductive-definitions}). A global assumption will be represented in the global environment as -- cgit v1.2.3 From 9f6ca170331a4f883cae20531bdced9eee663c59 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 14:42:15 +0100 Subject: CLEANUP PROPOSITION: removal of a definition of a concept that is not used further in the text --- doc/refman/RefMan-cic.tex | 3 --- 1 file changed, 3 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index b0205b7e9e..73fd4a1182 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -255,9 +255,6 @@ notation $[]$ denotes the empty local context. % $|\Delta|$ for the length of the context $\Delta$, that is for the number % of declarations (assumptions or definitions) in $\Delta$. -A variable $x$ is said to be free in $\Gamma$ if $\Gamma$ contains a -declaration $y:T$ such that $x$ is free in $T$. - \paragraph[Global environment.]{Global environment.\index{Global environment}} %Because we are manipulating global declarations (global constants and global %assumptions), we also need to consider a global environment $E$. -- cgit v1.2.3 From 84d2f601da36e002cf752e9099244499c13bfa73 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 14:45:34 +0100 Subject: GRAMMAR --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 73fd4a1182..89c771238c 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -261,7 +261,7 @@ notation $[]$ denotes the empty local context. A {\em global environment} is an ordered list of {\em global declarations\index{declaration!global}}. Global declarations are either {\em global assumptions\index{assumption!global}} or {\em global -definitions\index{definition!global}}, but also declarations of inductive objects. Inductive objects themselves declares both inductive or coinductive types and constructors +definitions\index{definition!global}}, but also declarations of inductive objects. Inductive objects themselves declare both inductive or coinductive types and constructors (see Section~\ref{Cic-inductive-definitions}). A global assumption will be represented in the global environment as -- cgit v1.2.3 From 13ebbb8ab04036298d288b47a4664379173e6e3c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 14:48:37 +0100 Subject: TYPOGRAPHY --- doc/refman/RefMan-cic.tex | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 89c771238c..1804ebd9ce 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -264,14 +264,14 @@ Global declarations are either {\em global assumptions\index{assumption!global}} definitions\index{definition!global}}, but also declarations of inductive objects. Inductive objects themselves declare both inductive or coinductive types and constructors (see Section~\ref{Cic-inductive-definitions}). -A global assumption will be represented in the global environment as +A {\em global assumption} will be represented in the global environment as $(c:T)$ which assumes the name $c$ to be of some type $T$. -A global definition will +A {\em global definition} will be represented in the global environment as $c:=t:T$ which defines the name $c$ to have value $t$ and type $T$. We shall call such names {\em constants}. -The rules for inductive definitions (see section +The rules for inductive definitions (see Section \ref{Cic-inductive-definitions}) have to be considered as assumption rules to which the following definitions apply: if the name $c$ is declared in $E$, we write $c \in E$ and if $c:T$ or $c:=t:T$ is -- cgit v1.2.3 From 678f41f598f38c9c0ef7c587f7b876437a6d06d8 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 15:02:04 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 1804ebd9ce..56e9a27790 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -312,6 +312,7 @@ be derived from the following rules. {\WF{E;c:T}{}}} \item[W-Global-Def] \inference{\frac{\WTE{}{t}{T}~~~c \notin E} {\WF{E;c:=t:T}{}}} +% QUESTION: Why, in case of W-Local-Assum and W-Global-Assum we need s ∈ S hypothesis. \item[Ax] \index{Typing rules!Ax} \inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(1)}}~~~~~ \frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(1)}}} -- cgit v1.2.3 From e13fed125d22e58e39487a3aa227416e1f2ba329 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 15:13:25 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 56e9a27790..22cec45cc2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -313,6 +313,10 @@ be derived from the following rules. \item[W-Global-Def] \inference{\frac{\WTE{}{t}{T}~~~c \notin E} {\WF{E;c:=t:T}{}}} % QUESTION: Why, in case of W-Local-Assum and W-Global-Assum we need s ∈ S hypothesis. +% QUESTION: At the moment, enrichment of a local context is denoted with ∷ +% whereas enrichment of the global environment is denoted with ; +% Is it necessary to use two different notations? +% Couldn't we use ∷ also for enrichment of the global context? \item[Ax] \index{Typing rules!Ax} \inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(1)}}~~~~~ \frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(1)}}} -- cgit v1.2.3 From e31bc1fc036969454a5577758444b91174209b5c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 15:44:25 +0100 Subject: TYPOGRAPHY: Each of the three 'Ax' and 'Prod' rules now has a unique name. --- doc/refman/RefMan-cic.tex | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 22cec45cc2..db26568c5a 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -317,21 +317,25 @@ be derived from the following rules. % whereas enrichment of the global environment is denoted with ; % Is it necessary to use two different notations? % Couldn't we use ∷ also for enrichment of the global context? -\item[Ax] \index{Typing rules!Ax} -\inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(1)}}~~~~~ -\frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(1)}}} +\item[Ax-Prop] \index{Typing rules!Ax-Prop} +\inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(1)}}} +\item[Ax-Set] \index{Typing rules!Ax-Set} +\inference{\frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(1)}}} +\item[Ax-Type] \index{Typing rules!Ax-Type} \inference{\frac{\WFE{\Gamma}}{\WTEG{\Type(i)}{\Type(i+1)}}} \item[Var]\index{Typing rules!Var} \inference{\frac{ \WFE{\Gamma}~~~~~(x:T) \in \Gamma~~\mbox{or}~~(x:=t:T) \in \Gamma~\mbox{for some $t$}}{\WTEG{x}{T}}} \item[Const] \index{Typing rules!Const} \inference{\frac{\WFE{\Gamma}~~~~(c:T) \in E~~\mbox{or}~~(c:=t:T) \in E~\mbox{for some $t$} }{\WTEG{c}{T}}} -\item[Prod] \index{Typing rules!Prod} +\item[Prod-Prop] \index{Typing rules!Prod-Prop} \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~ \WTE{\Gamma::(x:T)}{U}{\Prop}} { \WTEG{\forall~x:T,U}{\Prop}}} +\item[Prod-Set] \index{Typing rules!Prod-Set} \inference{\frac{\WTEG{T}{s}~~~~s \in\{\Prop, \Set\}~~~~~~ \WTE{\Gamma::(x:T)}{U}{\Set}} { \WTEG{\forall~x:T,U}{\Set}}} +\item[Prod-Type] \index{Typing rules!Prod-Type} \inference{\frac{\WTEG{T}{\Type(i)}~~~~ \WTE{\Gamma::(x:T)}{U}{\Type(i)}} {\WTEG{\forall~x:T,U}{\Type(i)}}} -- cgit v1.2.3 From 4beb1ee596afaf4ab4ebea9a89bb3ade7bbbe13d Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 17:32:36 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index db26568c5a..fe32cb7266 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -354,6 +354,7 @@ be derived from the following rules. well-typed without having $((\lb x:T\mto u)~t)$ well-typed (where $T$ is a type of $t$). This is because the value $t$ associated to $x$ may be used in a conversion rule (see Section~\ref{conv-rules}). +% QUESTION: I do not understand. How would that be possible? \section[Conversion rules]{Conversion rules\index{Conversion rules} \label{conv-rules}} -- cgit v1.2.3 From c56035c2850fe09fc5ef6389e58de28109ad5a93 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 17:33:54 +0100 Subject: TYPOGRAPHY: getting rid of an extra space --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index fe32cb7266..a008bd19a5 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -411,7 +411,7 @@ called $\zeta$-reduction and shows as follows. $$\WTEGRED{\kw{let}~x:=u~\kw{in}~t}{\triangleright_{\zeta}}{\subst{t}{x}{u}}$$ -\paragraph{$\eta$-conversion. +\paragraph{$\eta$-conversion.% \label{eta} \index{eta-conversion@$\eta$-conversion} %\index{eta-reduction@$\eta$-reduction} -- cgit v1.2.3 From a388e5401c2f83f4068314087e67d751acb59d17 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 29 Oct 2015 17:34:05 +0100 Subject: GRAMMAR --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index a008bd19a5..b7bbf7125f 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -416,7 +416,7 @@ $$\WTEGRED{\kw{let}~x:=u~\kw{in}~t}{\triangleright_{\zeta}}{\subst{t}{x}{u}}$$ \index{eta-conversion@$\eta$-conversion} %\index{eta-reduction@$\eta$-reduction} } -An other important concept is $\eta$-conversion. It is to identify any +Another important concept is $\eta$-conversion. It is to identify any term $t$ of functional type $\forall x:T, U$ with its so-called $\eta$-expansion $\lb x:T\mto (t\ x)$ for $x$ an arbitrary variable name fresh in $t$. -- cgit v1.2.3 From 32d7eb310f348bf4fcc6222de75bc5b423c9787e Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 30 Oct 2015 12:52:05 +0100 Subject: CLEANUP: the explanation of why eta-reduction is a bad idea was rephrased --- doc/refman/RefMan-cic.tex | 30 +++++++++++++++++------------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index b7bbf7125f..229c01b5d2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -411,24 +411,28 @@ called $\zeta$-reduction and shows as follows. $$\WTEGRED{\kw{let}~x:=u~\kw{in}~t}{\triangleright_{\zeta}}{\subst{t}{x}{u}}$$ -\paragraph{$\eta$-conversion.% -\label{eta} -\index{eta-conversion@$\eta$-conversion} +\paragraph{$\eta$-expansion.% +\label{eta}% +\index{eta-expansion@$\eta$-expansion}% %\index{eta-reduction@$\eta$-reduction} -} -Another important concept is $\eta$-conversion. It is to identify any +}% +Another important concept is $\eta$-expansion. It is legal to identify any term $t$ of functional type $\forall x:T, U$ with its so-called $\eta$-expansion $\lb x:T\mto (t\ x)$ for $x$ an arbitrary variable name fresh in $t$. -The notion of $\eta$-reduction ${\lb x:T\mto (t\ x)}{\;\triangleright\;}{t}$ -(for $x$ not occurring in $t$) is not type-sound because of subtyping -(think about $\lb x:\Type(1)\mto (f x)$ of type $\forall -x:\Type(1), \Type(1)$ for $f$ of type $\forall x:\Type(2), -\Type(1)$). On the other side, $\eta$-expansion requires to know $T$ -and hence requires types. Hence, neither $\eta$-expansion nor -$\eta$-reduction can be type-safely considered on terms we do not know -the type. However, $\eta$ can be used as a conversion rule. +\Rem We deliberately do not define $\eta$-reduction: +\def\noeta{\hskip-.1em\not\triangleright_\eta} +$$\lb x:T\mto (t\ x)\hskip.1em\noeta\hskip.3em t$$ +This is because, in general, the type of $t$ need not to be convertible to the type of $\lb x:T\mto (t\ x)$. +E.g., if we take $f$ such that: +$$f\hskip.5em:\hskip.5em\forall x:Type(2),Type(1)$$ +then +$$\lb x:Type(1),(f\, x)\hskip.5em:\hskip.5em\forall x:Type(1),Type(1)$$ +We could not allow +$$\lb x:Type(1),(f\,x)\hskip.5em\noeta\hskip.6em f$$ +because the type of the reduced term $\forall x:Type(2),Type(1)$ +would not be convertible to the type of the original term $\forall x:Type(1),Type(1)$. \paragraph[Convertibility.]{Convertibility.\label{convertibility} \index{beta-reduction@$\beta$-reduction}\index{iota-reduction@$\iota$-reduction}\index{delta-reduction@$\delta$-reduction}\index{zeta-reduction@$\zeta$-reduction}} -- cgit v1.2.3 From 73985c85792da06857199311834962f6a417e71c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 30 Oct 2015 16:31:42 +0100 Subject: ENH: a small remark about Prod1 and Prod2 typing-rules was added --- doc/refman/RefMan-cic.tex | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 229c01b5d2..764f1189ba 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -349,7 +349,14 @@ be derived from the following rules. \inference{\frac{\WTEG{t}{T}~~~~ \WTE{\Gamma::(x:=t:T)}{u}{U}} {\WTEG{\letin{x}{t:T}{u}}{\subst{U}{x}{t}}}} \end{description} - + +\Rem Prod$_1$ and Prod$_2$ typing-rules make sense if we consider the semantic +difference between {\Prop} and {\Set}: +\begin{itemize} + \item All values of a type that has a sort {\Set} are extractable. + \item No values of a type that has a sort {\Prop} are extractable. +\end{itemize} + \Rem We may have $\kw{let}~x:=t:T~\kw{in}~u$ well-typed without having $((\lb x:T\mto u)~t)$ well-typed (where $T$ is a type of $t$). This is because the value $t$ associated to $x$ -- cgit v1.2.3 From c5b3e7ff66e1675aaec7be5e0ee6772e88250991 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 30 Oct 2015 16:50:00 +0100 Subject: ENH: the concept of 'inductive declaration' was added to the 'Global Index' --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 764f1189ba..7fd5b23039 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -519,7 +519,7 @@ reductions or any combination of those can also be defined. A (possibly mutual) inductive definition is specified by giving the names and types of the inductive types to be defined and the names and types of the constructors of the inductive types. -An inductive declaration in the global environment can +An {\em inductive declaration\index{declaration!inductive}} in the global environment can consequently be represented with two local contexts, one for the types one for the constructors. -- cgit v1.2.3 From 47377fa44143d409331dd7d0c662e6ebb34d9f4f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 14:41:37 +0100 Subject: ENH: The beginning of Section 4.5 (Inductive declarations) was changed in order to make it more concrete and more comprehensible. This ver --- doc/common/macros.tex | 2 +- doc/refman/RefMan-cic.tex | 380 ++++++++++++++++++++++------------------------ 2 files changed, 185 insertions(+), 197 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index ff13ec4557..fb9190a162 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -260,7 +260,7 @@ \newcommand{\Length}{\mbox{\textsf{Length}}} \newcommand{\length}{\mbox{\textsf{length}}} \newcommand{\LengthA}{\mbox {\textsf{Length\_A}}} -\newcommand{\List}{\mbox{\textsf{List}}} +\newcommand{\List}{\mbox{\textsf{list}}} \newcommand{\ListA}{\mbox{\textsf{List\_A}}} \newcommand{\LNil}{\mbox{\textsf{Lnil}}} \newcommand{\LCons}{\mbox{\textsf{Lcons}}} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 7fd5b23039..f4d107ed8a 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -514,213 +514,201 @@ $u_i$ can be reducible. Similar notions of head-normal forms involving $\delta$, $\iota$ and $\zeta$ reductions or any combination of those can also be defined. -\section[Inductive Definitions]{Inductive Definitions\label{Cic-inductive-definitions}} - -A (possibly mutual) inductive definition is specified by giving the -names and types of the inductive types to be -defined and the names and types of the constructors of the inductive types. -An {\em inductive declaration\index{declaration!inductive}} in the global environment can -consequently be represented with two local contexts, one for the types -one for the constructors. - -Stating the rules for inductive definitions in their general form -needs quite tedious definitions. We shall try to give a concrete -understanding of the rules by illustrating them on running examples. We -take as examples the type of natural numbers, the type of -parameterized lists over a type $A$, the relation which states that -a list has some given length and the mutual inductive definition of trees and -forests. - -\subsection{Representing an inductive definition} -\subsubsection{Inductive definitions without parameters} -As for constants, inductive definitions must be defined in a non-empty -local context. \\ -We write \NInd{}{\Gamma_I}{\Gamma_C} for an inductive -definition with a -context of type definitions $\Gamma_I$ and a context of constructors -$\Gamma_C$. -\paragraph{Examples.} -The inductive declaration for the type of natural numbers will be: -\[\NInd{}{\nat:\Set}{\nO:\nat,\nS:\nat\ra\nat}\] -In a context with assumption $A:\Set$, the lists of elements in $A$ are -represented by: -\[\NInd{}{\List:\Set}{\Nil:\List,\cons : A \ra \List \ra - \List}\] -%% Assuming -%% $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is -%% $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are, -%% for $1\leq j\leq k$ and $1\leq i\leq n$: - -%% \bigskip - -%% \item[Ind] \index{Typing rules!Ind} -%% \inference{\frac{\NInd{}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}} -%% \item[Constr] \index{Typing rules!Constr} - -%% \inference{\frac{\NInd{}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}} - -\subsubsection{Inductive definitions with parameters} - -We have refine the representation above in order to handle parameters. -Let us explain that on the example of \List. With the above definition, -the type \List\ can only be used in a global environment where we -have a variable $A:\Set$. Generally one wants to consider lists of -elements in different types. For constants this is easily done by abstracting -the value over the parameter. In the case of inductive definitions we -have to handle the abstraction over several objects. - -One possible way to do that would be to define the type \List\ -inductively as being an inductive type of type $\Set\ra\Set$: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set,\List~A), - \cons : (\forall A:\Set, A \ra \List~A \ra \List~A)}\] -There are drawbacks to this point of view. The -information which says that for any $A$, $(\List~A)$ is an inductively defined -\Set\ has been lost. -So we introduce two important definitions. - -\paragraph{Inductive parameters, real arguments.} -An inductive definition $\NInd{\Gamma}{\Gamma_I}{\Gamma_C}$ admits -$r$ inductive parameters if each type of constructors $(c:C)$ in -$\Gamma_C$ is such that -\[C\equiv \forall -p_1:P_1,\ldots,\forall p_r:P_r,\forall a_1:A_1, \ldots \forall a_n:A_n, -(I~p_1~\ldots p_r~t_1\ldots t_q)\] -with $I$ one of the inductive definitions in $\Gamma_I$. -We say that $q$ is the number of real arguments of the constructor -$c$. -\paragraph{Context of parameters.} -If an inductive definition $\NInd{\Gamma}{\Gamma_I}{\Gamma_C}$ admits -$r$ inductive parameters, then there exists a local context $\Gamma_P$ of -size $r$, such that $\Gamma_P=[p_1:P_1;\ldots;p_r:P_r]$ and -if $(t:A) \in \Gamma_I,\Gamma_C$ then $A$ can be written as -$\forall p_1:P_1,\ldots \forall p_r:P_r,A'$. -We call $\Gamma_P$ the local context of parameters of the inductive -definition and use the notation $\forall \Gamma_P,A'$ for the term $A$. -\paragraph{Remark.} -If we have a term $t$ in an instance of an -inductive definition $I$ which starts with a constructor $c$, then the -$r$ first arguments of $c$ (the parameters) can be deduced from the -type $T$ of $t$: these are exactly the $r$ first arguments of $I$ in -the head normal form of $T$. -\paragraph{Examples.} -The \List{} definition has $1$ parameter: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set, \List~A), - \cons : (\forall A:\Set, A \ra \List~A \ra \List~A)}\] -This is also the case for this more complex definition where there is -a recursive argument on a different instance of \List: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set, \List~A), - \cons : (\forall A:\Set, A \ra \List~(A \ra A) \ra \List~A)}\] -But the following definition has $0$ parameters: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set, \List~A), - \cons : (\forall A:\Set, A \ra \List~A \ra \List~(A*A))}\] - -%\footnote{ -%The interested reader may compare the above definition with the two -%following ones which have very different logical meaning:\\ -%$\NInd{}{\List:\Set}{\Nil:\List,\cons : (A:\Set)A -% \ra \List \ra \List}$ \\ -%$\NInd{}{\List:\Set\ra\Set}{\Nil:(A:\Set)(\List~A),\cons : (A:\Set)A -% \ra (\List~A\ra A) \ra (\List~A)}$.} -\paragraph{Concrete syntax.} -In the {\Coq} system, the local context of parameters is given explicitly -after the name of the inductive definitions and is shared between the -arities and the type of constructors. -% The vernacular declaration of polymorphic trees and forests will be:\\ -% \begin{coq_example*} -% Inductive Tree (A:Set) : Set := -% Node : A -> Forest A -> Tree A -% with Forest (A : Set) : Set := -% Empty : Forest A -% | Cons : Tree A -> Forest A -> Forest A -% \end{coq_example*} -% will correspond in our formalism to: -% \[\NInd{}{{\tt Tree}:\Set\ra\Set;{\tt Forest}:\Set\ra \Set} -% {{\tt Node} : \forall A:\Set, A \ra {\tt Forest}~A \ra {\tt Tree}~A, -% {\tt Empty} : \forall A:\Set, {\tt Forest}~A, -% {\tt Cons} : \forall A:\Set, {\tt Tree}~A \ra {\tt Forest}~A \ra -% {\tt Forest}~A}\] -We keep track in the syntax of the number of -parameters. - -Formally the representation of an inductive declaration -will be -\Ind{}{p}{\Gamma_I}{\Gamma_C} for an inductive -definition with $p$ parameters, a -context of definitions $\Gamma_I$ and a context of constructors -$\Gamma_C$. - -The definition \Ind{}{p}{\Gamma_I}{\Gamma_C} will be -well-formed exactly when \NInd{}{\Gamma_I}{\Gamma_C} is and -when $p$ is (less or equal than) the number of parameters in -\NInd{}{\Gamma_I}{\Gamma_C}. - -\paragraph{Examples} -The declaration for parameterized lists is: -\[\Ind{}{1}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set,\List~A),\cons : - (\forall A:\Set, A \ra \List~A \ra \List~A)}\] - -The declaration for an inductive type specifying the length of lists is: -\[\Ind{}{1}{\Length:\forall A:\Set, (\List~A)\ra \nat\ra\Prop} - {\LNil:\forall A:\Set, \Length~A~(\Nil~A)~\nO,\\ - \LCons :\forall A:\Set,\forall a:A, \forall l:(\List~A),\forall n:\nat, (\Length~A~l~n)\ra (\Length~A~(\cons~A~a~l)~(\nS~n))}\] - -The declaration for a mutual inductive definition of forests and trees is: -\[\NInd{}{\tree:\Set,\forest:\Set} - {\\~~\node:\forest \ra \tree, - \emptyf:\forest,\consf:\tree \ra \forest \ra \forest\-}\] - -These representations are the ones obtained as the result of the \Coq\ -declarations: -\begin{coq_example*} +\section[Inductive definitions]{Inductive Definitions\label{Cic-inductive-definitions}} + +% Here we assume that the reader knows what is an inductive definition. + +Formally, we can represent any {\em inductive definition\index{definition!inductive}} as \Ind{}{p}{\Gamma_I}{\Gamma_C} where: +\begin{itemize} + \item $\Gamma_I$ determines the names and types of inductive types; + \item $\Gamma_C$ determines the names and types of constructors of these inductive types; + \item $p$ determines the number of parameters of these inductive types. +\end{itemize} +These inductive definitions, together with global assumptions and global definitions, then form the global environment. +\vskip.5em +\noindent Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ +such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: +$\forall\Gamma_P, T^\prime$. +\vskip.5em +\noindent $\Gamma_P$ is called {\em context of parameters\index{context of parameters}}. + +\subsection*{Examples} + +If we take the following inductive definition (denoted in concrete syntax): +\begin{coq_example} +Inductive bool : Set := + | true : bool + | false : bool. +\end{coq_example} +then: +\def\colon{@{\hskip.5em:\hskip.5em}} +\def\GammaI{\left[\begin{array}{r \colon l} + \bool & \Set + \end{array} + \right]} +\def\GammaC{\left[\begin{array}{r \colon l} + \true & \bool\\ + \false & \bool + \end{array} + \right]} +\newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em + \begin{array}{r @{\mathrm{~:=~}} l} + #2 & #3 \\ + \end{array} + \hskip-.4em + \right)$} +\begin{itemize} + \item $p = 0$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ +\end{itemize} +and thus it enriches the global environment with the following entry: +\vskip.5em +\ind{p}{\Gamma_I}{\Gamma_C} +\vskip.5em +\noindent that is: +\vskip.5em +\ind{0}{\GammaI}{\GammaC} +\vskip.5em +\noindent In this case, $\Gamma_P=[\,]$. + +\vskip1em\hrule\vskip1em + +\noindent If we take the followig inductive definition: +\begin{coq_example} Inductive nat : Set := | O : nat | S : nat -> nat. -Inductive list (A:Set) : Set := +\end{coq_example} +then: +\def\GammaI{\left[\begin{array}{r \colon l} + \nat & \Set + \end{array} + \right]} +\def\GammaC{\left[\begin{array}{r \colon l} + \nO & \nat\\ + \nS & \nat\rightarrow\nat + \end{array} + \right]} +\begin{itemize} + \item $p = 0$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ +\end{itemize} +and thus it enriches the global environment with the following entry: +\vskip.5em +\ind{p}{\Gamma_I}{\Gamma_C} +\vskip.5em +\noindent that is: +\vskip.5em +\ind{0}{\GammaI}{\GammaC} +\vskip.5em +\noindent In this case, $\Gamma_P=[\,]$. + +\vskip1em\hrule\vskip1em + +\noindent If we take the following inductive definition: +\begin{coq_example} +Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. -\end{coq_example*} -\begin{coq_example*} -Inductive Length (A:Set) : list A -> nat -> Prop := +\end{coq_example} +then: +\def\GammaI{\left[\begin{array}{r \colon l} + \List & \Type\rightarrow\Type + \end{array} + \right]} +\def\GammaC{\left[\begin{array}{r \colon l} + \Nil & \forall~A\!:\!\Type,~\List~A\\ + \cons & \forall~A\!:\!\Type,~A\rightarrow\List~A\rightarrow\List~A + \end{array} + \right]} +\begin{itemize} + \item $p = 1$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ +\end{itemize} +and thus it enriches the global environment with the following entry: +\vskip.5em +\ind{p}{\Gamma_I}{\Gamma_C} +\vskip.5em +\noindent that is: +\vskip.5em +\ind{1}{\GammaI}{\GammaC} +\vskip.5em +\noindent In this case, $\Gamma_P=[A:\Type]$. + +\vskip1em\hrule\vskip1em + +\noindent If we take the following inductive definition: +\begin{coq_example} +Inductive Length (A : Type) : list A -> nat -> Prop := | Lnil : Length A (nil A) O - | Lcons : - forall (a:A) (l:list A) (n:nat), - Length A l n -> Length A (cons A a l) (S n). + | Lcons : forall (a:A) (l:list A) (n:nat), + Length A l n -> Length A (cons A a l) (S n). +\end{coq_example} +then: +\def\GammaI{\left[\begin{array}{r \colon l} + \Length & \forall~A\!:\!\Type,~\List~A\rightarrow\nat\rightarrow\Prop + \end{array} + \right]} +\def\GammaC{\left[\begin{array}{r c l} + \LNil & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\Length~A~(\Nil~A)~\nO\\ + \LCons & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ + & & \Length~A~l~n\rightarrow \Length~A~(\cons~A~a~l)~(\nS~n) + \end{array} + \right]} +\begin{itemize} + \item $p = 1$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ +\end{itemize} +and thus it enriches the global environment with the following entry: +\vskip.5em +\ind{p}{\Gamma_I}{\Gamma_C} +%\vskip.5em +%\noindent that is: +%\vskip.5em +%\ind{1}{\GammaI}{\GammaC} +\vskip.5em +\noindent In this case, $\Gamma_P=[A:\Type]$. + +\vskip1em\hrule\vskip1em + +\noindent If we take the following inductive definition: +\begin{coq_example} Inductive tree : Set := - node : forest -> tree + | node : forest -> tree with forest : Set := | emptyf : forest | consf : tree -> forest -> forest. -\end{coq_example*} -% The inductive declaration in \Coq\ is slightly different from the one -% we described theoretically. The difference is that in the type of -% constructors the inductive definition is explicitly applied to the -% parameters variables. -The \Coq\ type-checker verifies that all -parameters are applied in the correct manner in the conclusion of the -type of each constructors: - -In particular, the following definition will not be accepted because -there is an occurrence of \List\ which is not applied to the parameter -variable in the conclusion of the type of {\tt cons'}: -\begin{coq_eval} -Set Printing Depth 50. -\end{coq_eval} -% (********** The following is not correct and should produce **********) -% (********* Error: The 1st argument of list' must be A in ... *********) -\begin{coq_example} -Fail Inductive list' (A:Set) : Set := - | nil' : list' A - | cons' : A -> list' A -> list' (A*A). \end{coq_example} -Since \Coq{} version 8.1, there is no restriction about parameters in -the types of arguments of constructors. The following definition is -valid: -\begin{coq_example} -Inductive list' (A:Set) : Set := - | nil' : list' A - | cons' : A -> list' (A->A) -> list' A. -\end{coq_example} - +then: +\def\GammaI{\left[\begin{array}{r \colon l} + \tree & \Set\\ + \forest & \Set + \end{array} + \right]} +\def\GammaC{\left[\begin{array}{r \colon l} + \node & \forest\rightarrow\tree\\ + \emptyf & \forest\\ + \consf & \tree\rightarrow\forest\rightarrow\forest + \end{array} + \right]} +\begin{itemize} + \item $p = 0$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ +\end{itemize} +and thus it enriches the global environment with the following entry: +\vskip.5em +\ind{p}{\Gamma_I}{\Gamma_C} +\vskip.5em +\noindent that is: +\vskip.5em +\ind{0}{\GammaI}{\GammaC} +\vskip.5em +\noindent In this case, $\Gamma_P=[\,]$. \subsection{Types of inductive objects} We have to give the type of constants in a global environment $E$ which -- cgit v1.2.3 From 42bc6762952b2d4996e26285720b3e556a63c96d Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 15:25:20 +0100 Subject: QUESTION: Cannot we simplify the presentation of "Ind" and "Constr" typing rules like this? --- doc/refman/RefMan-cic.tex | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index f4d107ed8a..2eb79ce842 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -716,12 +716,9 @@ contains an inductive declaration. \begin{description} \item[Ind] \index{Typing rules!Ind} -\inference{\frac{\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}} -\inference{\frac{\WFE{\Gamma}~~~~\NInd{}{\Gamma_I}{\Gamma_C} \in E}{\WTEG{I_j}{A_j}}} + \inference{\frac{\WFE{\Gamma}\hskip2em\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\hskip2em(a:A)\in\Gamma_I}{\WTEG{a}{A}}} \item[Constr] \index{Typing rules!Constr} - -\inference{\frac{\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}} -\inference{\frac{\WFE{\Gamma}~~~~\NInd{}{\Gamma_I}{\Gamma_C} \in E}{\WTEG{c_i}{C_i}}} + \inference{\frac{\WFE{\Gamma}\hskip2em\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\hskip2em(c:C)\in\Gamma_C}{\WTEG{c}{C}}} \end{description} \paragraph{Example.} -- cgit v1.2.3 From 089f2195aa0d0351b5692a8b4c947c7652d148b0 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 15:31:56 +0100 Subject: SILENT: s/coq_example/coq_example*/ --- doc/refman/RefMan-cic.tex | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2eb79ce842..574ef33c2d 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -535,11 +535,11 @@ $\forall\Gamma_P, T^\prime$. \subsection*{Examples} If we take the following inductive definition (denoted in concrete syntax): -\begin{coq_example} +\begin{coq_example*} Inductive bool : Set := | true : bool | false : bool. -\end{coq_example} +\end{coq_example*} then: \def\colon{@{\hskip.5em:\hskip.5em}} \def\GammaI{\left[\begin{array}{r \colon l} @@ -575,11 +575,11 @@ and thus it enriches the global environment with the following entry: \vskip1em\hrule\vskip1em \noindent If we take the followig inductive definition: -\begin{coq_example} +\begin{coq_example*} Inductive nat : Set := | O : nat | S : nat -> nat. -\end{coq_example} +\end{coq_example*} then: \def\GammaI{\left[\begin{array}{r \colon l} \nat & \Set @@ -608,11 +608,11 @@ and thus it enriches the global environment with the following entry: \vskip1em\hrule\vskip1em \noindent If we take the following inductive definition: -\begin{coq_example} +\begin{coq_example*} Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. -\end{coq_example} +\end{coq_example*} then: \def\GammaI{\left[\begin{array}{r \colon l} \List & \Type\rightarrow\Type @@ -641,12 +641,12 @@ and thus it enriches the global environment with the following entry: \vskip1em\hrule\vskip1em \noindent If we take the following inductive definition: -\begin{coq_example} +\begin{coq_example*} Inductive Length (A : Type) : list A -> nat -> Prop := | Lnil : Length A (nil A) O | Lcons : forall (a:A) (l:list A) (n:nat), Length A l n -> Length A (cons A a l) (S n). -\end{coq_example} +\end{coq_example*} then: \def\GammaI{\left[\begin{array}{r \colon l} \Length & \forall~A\!:\!\Type,~\List~A\rightarrow\nat\rightarrow\Prop @@ -676,13 +676,13 @@ and thus it enriches the global environment with the following entry: \vskip1em\hrule\vskip1em \noindent If we take the following inductive definition: -\begin{coq_example} +\begin{coq_example*} Inductive tree : Set := | node : forest -> tree with forest : Set := | emptyf : forest | consf : tree -> forest -> forest. -\end{coq_example} +\end{coq_example*} then: \def\GammaI{\left[\begin{array}{r \colon l} \tree & \Set\\ -- cgit v1.2.3 From bc78fc26204d638f789597e2892d95483918f187 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 16:13:20 +0100 Subject: CLEANUP: Presentation of examples was changed to make them more comprehensible. --- doc/refman/RefMan-cic.tex | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 574ef33c2d..cc69355d4a 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -722,12 +722,27 @@ contains an inductive declaration. \end{description} \paragraph{Example.} -We have $(\List:\Set \ra \Set), (\cons:\forall~A:\Set,A\ra(\List~A)\ra -(\List~A))$, \\ -$(\Length:\forall~A:\Set, (\List~A)\ra\nat\ra\Prop)$, $\tree:\Set$ and $\forest:\Set$. - -From now on, we write $\ListA$ instead of $(\List~A)$ and $\LengthA$ -for $(\Length~A)$. +Provided that our environment $E$ contains inductive definitions we showed before, +these two inference rules above enable us to conclude that: +\vskip.5em +\def\prefix{E[\Gamma]\vdash\hskip.25em} +$\begin{array}{@{} l} + \prefix\bool : \Set\\ + \prefix\true : \bool\\ + \prefix\false : \bool\\ + \prefix\nat : \Set\\ + \prefix\nO : \nat\\ + \prefix\nS : \nat\ra\nat\\ + \prefix\List : \Type\rightarrow\Type\\ + \prefix\Nil : \forall~A\!:\!\Type,~\List~A\\ + \prefix\cons : \forall~A\!:\!\Type,~A\rightarrow\List~A\rightarrow\List~A\\ + \prefix\Length : \forall~A\!:\!\Type,~\List~A\rightarrow\nat\rightarrow\Prop\\ + \prefix\LNil : \forall~A\!:\!\Type,~\Length~A~(\Nil~A)~\nO\\ + \begin{array}{l l} + \hskip-.5em\prefix\LCons :\hskip-.5em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ + & \Length~A~l~n\rightarrow \Length~A~(\cons~A~a~l)~(\nS~n) + \end{array} + \end{array}$ %\paragraph{Parameters.} %%The parameters introduce a distortion between the inside specification -- cgit v1.2.3 From 42347ebd180f10b738f628bae904b5773a0150ac Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 16:15:38 +0100 Subject: COMMENT: to do --- doc/refman/RefMan-cic.tex | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index cc69355d4a..8f03cafd14 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -760,7 +760,9 @@ $\begin{array}{@{} l} \subsection{Well-formed inductive definitions} We cannot accept any inductive declaration because some of them lead -to inconsistent systems. We restrict ourselves to definitions which +to inconsistent systems. +% TODO: The statement above deserves explanation. +We restrict ourselves to definitions which satisfy a syntactic criterion of positivity. Before giving the formal rules, we need a few definitions: -- cgit v1.2.3 From f37c09e169b11ed683aeb9147c402b9980a6706c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 16:28:13 +0100 Subject: TYPOGRAPHY --- doc/refman/RefMan-cic.tex | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 8f03cafd14..8f50c1c323 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -771,14 +771,16 @@ rules, we need a few definitions: A type $T$ is an {\em arity of sort $s$}\index{Arity} if it converts to the sort $s$ or to a product $\forall~x:T,U$ with $U$ an arity of sort $s$. (For instance $A\ra \Set$ or $\forall~A:\Prop,A\ra -\Prop$ are arities of sort respectively \Set\ and \Prop). A {\em type +\Prop$ are arities of sort respectively \Set\ and \Prop). +\vskip.5em +\noindent A {\em type of constructor of $I$}\index{Type of constructor} is either a term $(I~t_1\ldots ~t_n)$ or $\fa x:T,C$ with $C$ recursively a {\em type of constructor of $I$}. \smallskip -The type of constructor $T$ will be said to {\em satisfy the positivity +\noindent The type of constructor $T$ will be said to {\em satisfy the positivity condition} for a constant $X$ in the following cases: \begin{itemize} -- cgit v1.2.3 From 6ce8d9b4b99afca623408e7052d5e6aaf72bb4ab Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 16:38:52 +0100 Subject: TYPOGRAPHY --- doc/refman/RefMan-cic.tex | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 8f50c1c323..eaf400f263 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -158,7 +158,7 @@ More precisely the language of the {\em Calculus of Inductive U''}. As $U$ depends on $x$, one says that $\forall~x:T,U$ is a {\em dependent product}. If $x$ does not occur in $U$ then $\forall~x:T,U$ reads as {\it ``if T then U''}. A {\em non dependent - product} can be written: $T \rightarrow U$. + product} can be written: $T \ra U$. \item if $x$ is a variable and $T$, $u$ are terms then $\lb x:T \mto u$ ($\kw{fun}~x:T~ {\tt =>}~ u$ in \Coq{} concrete syntax) is a term. This is a notation for the $\lambda$-abstraction of @@ -587,7 +587,7 @@ then: \right]} \def\GammaC{\left[\begin{array}{r \colon l} \nO & \nat\\ - \nS & \nat\rightarrow\nat + \nS & \nat\ra\nat \end{array} \right]} \begin{itemize} @@ -615,12 +615,12 @@ Inductive list (A : Type) : Type := \end{coq_example*} then: \def\GammaI{\left[\begin{array}{r \colon l} - \List & \Type\rightarrow\Type + \List & \Type\ra\Type \end{array} \right]} \def\GammaC{\left[\begin{array}{r \colon l} \Nil & \forall~A\!:\!\Type,~\List~A\\ - \cons & \forall~A\!:\!\Type,~A\rightarrow\List~A\rightarrow\List~A + \cons & \forall~A\!:\!\Type,~A\ra\List~A\ra\List~A \end{array} \right]} \begin{itemize} @@ -649,13 +649,13 @@ Inductive Length (A : Type) : list A -> nat -> Prop := \end{coq_example*} then: \def\GammaI{\left[\begin{array}{r \colon l} - \Length & \forall~A\!:\!\Type,~\List~A\rightarrow\nat\rightarrow\Prop + \Length & \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop \end{array} \right]} \def\GammaC{\left[\begin{array}{r c l} \LNil & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\Length~A~(\Nil~A)~\nO\\ \LCons & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ - & & \Length~A~l~n\rightarrow \Length~A~(\cons~A~a~l)~(\nS~n) + & & \Length~A~l~n\ra \Length~A~(\cons~A~a~l)~(\nS~n) \end{array} \right]} \begin{itemize} @@ -690,9 +690,9 @@ then: \end{array} \right]} \def\GammaC{\left[\begin{array}{r \colon l} - \node & \forest\rightarrow\tree\\ + \node & \forest\ra\tree\\ \emptyf & \forest\\ - \consf & \tree\rightarrow\forest\rightarrow\forest + \consf & \tree\ra\forest\ra\forest \end{array} \right]} \begin{itemize} @@ -733,14 +733,14 @@ $\begin{array}{@{} l} \prefix\nat : \Set\\ \prefix\nO : \nat\\ \prefix\nS : \nat\ra\nat\\ - \prefix\List : \Type\rightarrow\Type\\ + \prefix\List : \Type\ra\Type\\ \prefix\Nil : \forall~A\!:\!\Type,~\List~A\\ - \prefix\cons : \forall~A\!:\!\Type,~A\rightarrow\List~A\rightarrow\List~A\\ - \prefix\Length : \forall~A\!:\!\Type,~\List~A\rightarrow\nat\rightarrow\Prop\\ + \prefix\cons : \forall~A\!:\!\Type,~A\ra\List~A\ra\List~A\\ + \prefix\Length : \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop\\ \prefix\LNil : \forall~A\!:\!\Type,~\Length~A~(\Nil~A)~\nO\\ \begin{array}{l l} \hskip-.5em\prefix\LCons :\hskip-.5em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ - & \Length~A~l~n\rightarrow \Length~A~(\cons~A~a~l)~(\nS~n) + & \Length~A~l~n\ra \Length~A~(\cons~A~a~l)~(\nS~n) \end{array} \end{array}$ -- cgit v1.2.3 From 10f9c82c38c6eb01e64ab9a8fa233300568c18d4 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 16:39:28 +0100 Subject: ENH: adding a definition of the concept "_ is an arity". There already exists a definition of the following concept: "_ is an arity of sort _" I was not 100% sure what the following concept (used later in the text) means: "_ is an arity" so I added this (simple) definition in order to avoid possible confusion. --- doc/refman/RefMan-cic.tex | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index eaf400f263..deaa1047c8 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -773,6 +773,9 @@ to the sort $s$ or to a product $\forall~x:T,U$ with $U$ an arity of sort $s$. (For instance $A\ra \Set$ or $\forall~A:\Prop,A\ra \Prop$ are arities of sort respectively \Set\ and \Prop). \vskip.5em +\noindent A type $T$ is an {\em arity} if there is a $s\in\Sort$ +such that $T$ is an arity of sort $s$. +\vskip.5em \noindent A {\em type of constructor of $I$}\index{Type of constructor} is either a term $(I~t_1\ldots ~t_n)$ or $\fa x:T,C$ with $C$ recursively -- cgit v1.2.3 From fdb02e793da45a37355050342109da1be4a49c89 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 16:58:39 +0100 Subject: TYPOGRAPHY: Examples of "arity" concept(s) were put to a separate \paragraph{...} --- doc/refman/RefMan-cic.tex | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index deaa1047c8..2fa9c59a86 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -766,16 +766,23 @@ We restrict ourselves to definitions which satisfy a syntactic criterion of positivity. Before giving the formal rules, we need a few definitions: -\paragraph[Definitions]{Definitions\index{Positivity}\label{Positivity}} - -A type $T$ is an {\em arity of sort $s$}\index{Arity} if it converts +\paragraph[Definition]{Definition\index{Arity}\label{Arity}} +A type $T$ is an {\em arity of sort $s$} if it converts to the sort $s$ or to a product $\forall~x:T,U$ with $U$ an arity -of sort $s$. (For instance $A\ra \Set$ or $\forall~A:\Prop,A\ra -\Prop$ are arities of sort respectively \Set\ and \Prop). -\vskip.5em -\noindent A type $T$ is an {\em arity} if there is a $s\in\Sort$ +of sort $s$. + +\paragraph[Examples]{Examples} +$A\ra \Set$ is an arity of sort $\Set$. +$\forall~A:\Prop,A\ra \Prop$ is an arity of sort \Prop. + +\paragraph[Definition]{Definition} +A type $T$ is an {\em arity} if there is a $s\in\Sort$ such that $T$ is an arity of sort $s$. -\vskip.5em + +\paragraph[Examples]{Examples} +$A\ra \Set$ and $\forall~A:\Prop,A\ra \Prop$ are arities. + +\paragraph[Definition]{Definition\index{Positivity}\label{Positivity}} \noindent A {\em type of constructor of $I$}\index{Type of constructor} is either a term $(I~t_1\ldots ~t_n)$ or $\fa x:T,C$ with $C$ recursively -- cgit v1.2.3 From 1231781cf36d94858abc1a73a55fbba543209d4c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 2 Nov 2015 17:11:01 +0100 Subject: ENH: examples --- doc/refman/RefMan-cic.tex | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2fa9c59a86..d0bffa06e7 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -782,15 +782,17 @@ such that $T$ is an arity of sort $s$. \paragraph[Examples]{Examples} $A\ra \Set$ and $\forall~A:\Prop,A\ra \Prop$ are arities. -\paragraph[Definition]{Definition\index{Positivity}\label{Positivity}} -\noindent A {\em type - of constructor of $I$}\index{Type of constructor} is either a term +\paragraph[Definition]{Definition\index{type of constructor}} +A {\em type of constructor of $I$}\index{Type of constructor} is either a term $(I~t_1\ldots ~t_n)$ or $\fa x:T,C$ with $C$ recursively a {\em type of constructor of $I$}. -\smallskip +\paragraph[Examples]{Examples} +$\nat$ and $\nat\ra\nat$ are types of constructors of $\nat$.\\ +$\forall A:\Type,\List~A$ and $\forall A:\Type,A\ra\List~A\ra\List~A$ are constructors of $\List$. -\noindent The type of constructor $T$ will be said to {\em satisfy the positivity +\paragraph[Definition]{Definition\index{Positivity}\label{Positivity}} +The type of constructor $T$ will be said to {\em satisfy the positivity condition} for a constant $X$ in the following cases: \begin{itemize} -- cgit v1.2.3 From 6a66f087bdb773465ce55f8cac040158f07c8d5c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 10:07:16 +0100 Subject: ALPHA-CONVERSION: s/Length/has_length/g --- doc/common/macros.tex | 8 +++--- doc/refman/RefMan-cic.tex | 62 +++++++++++++++++++++++------------------------ 2 files changed, 35 insertions(+), 35 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index fb9190a162..1ac29b1553 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -257,13 +257,13 @@ \newcommand{\forest}{\mbox{\textsf{forest}}} \newcommand{\from}{\mbox{\textsf{from}}} \newcommand{\hd}{\mbox{\textsf{hd}}} -\newcommand{\Length}{\mbox{\textsf{Length}}} +\newcommand{\haslength}{\mbox{\textsf{has\_length}}} \newcommand{\length}{\mbox{\textsf{length}}} -\newcommand{\LengthA}{\mbox {\textsf{Length\_A}}} +\newcommand{\haslengthA}{\mbox {\textsf{has\_length~A}}} \newcommand{\List}{\mbox{\textsf{list}}} \newcommand{\ListA}{\mbox{\textsf{List\_A}}} -\newcommand{\LNil}{\mbox{\textsf{Lnil}}} -\newcommand{\LCons}{\mbox{\textsf{Lcons}}} +\newcommand{\nilhl}{\mbox{\textsf{nil\_hl}}} +\newcommand{\conshl}{\mbox{\textsf{cons\_hl}}} \newcommand{\nat}{\mbox{\textsf{nat}}} \newcommand{\nO}{\mbox{\textsf{O}}} \newcommand{\nS}{\mbox{\textsf{S}}} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index d0bffa06e7..bbf6372846 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -642,20 +642,20 @@ and thus it enriches the global environment with the following entry: \noindent If we take the following inductive definition: \begin{coq_example*} -Inductive Length (A : Type) : list A -> nat -> Prop := - | Lnil : Length A (nil A) O - | Lcons : forall (a:A) (l:list A) (n:nat), - Length A l n -> Length A (cons A a l) (S n). +Inductive has_length (A : Type) : list A -> nat -> Prop := + | nil_hl : has_length A (nil A) O + | cons_hl : forall (a:A) (l:list A) (n:nat), + has_length A l n -> has_length A (cons A a l) (S n). \end{coq_example*} then: \def\GammaI{\left[\begin{array}{r \colon l} - \Length & \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop + \haslength & \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop \end{array} \right]} \def\GammaC{\left[\begin{array}{r c l} - \LNil & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\Length~A~(\Nil~A)~\nO\\ - \LCons & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ - & & \Length~A~l~n\ra \Length~A~(\cons~A~a~l)~(\nS~n) + \nilhl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\haslength~A~(\Nil~A)~\nO\\ + \conshl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ + & & \haslength~A~l~n\ra \haslength~A~(\cons~A~a~l)~(\nS~n) \end{array} \right]} \begin{itemize} @@ -736,11 +736,11 @@ $\begin{array}{@{} l} \prefix\List : \Type\ra\Type\\ \prefix\Nil : \forall~A\!:\!\Type,~\List~A\\ \prefix\cons : \forall~A\!:\!\Type,~A\ra\List~A\ra\List~A\\ - \prefix\Length : \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop\\ - \prefix\LNil : \forall~A\!:\!\Type,~\Length~A~(\Nil~A)~\nO\\ + \prefix\haslength : \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop\\ + \prefix\nilhl : \forall~A\!:\!\Type,~\haslength~A~(\Nil~A)~\nO\\ \begin{array}{l l} - \hskip-.5em\prefix\LCons :\hskip-.5em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ - & \Length~A~l~n\ra \Length~A~(\cons~A~a~l)~(\nS~n) + \hskip-.5em\prefix\conshl :\hskip-.5em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ + & \haslength~A~l~n\ra \haslength~A~(\cons~A~a~l)~(\nS~n) \end{array} \end{array}$ @@ -752,10 +752,10 @@ $\begin{array}{@{} l} %%typing rules where the inductive objects are seen as objects %%abstracted with respect to the parameters. -%In the definition of \List\ or \Length\, $A$ is a parameter because -%what is effectively inductively defined is $\ListA$ or $\LengthA$ for +%In the definition of \List\ or \haslength\, $A$ is a parameter because +%what is effectively inductively defined is $\ListA$ or $\haslengthA$ for %a given $A$ which is constant in the type of constructors. But when -%we define $(\LengthA~l~n)$, $l$ and $n$ are not parameters because the +%we define $(\haslengthA~l~n)$, $l$ and $n$ are not parameters because the %constructors manipulate different instances of this family. \subsection{Well-formed inductive definitions} @@ -1099,21 +1099,21 @@ fixed point of this recursive equation. This says that we are only manipulating finite objects. This analysis provides induction principles. -For instance, in order to prove $\forall l:\ListA,(\LengthA~l~(\length~l))$ +For instance, in order to prove $\forall l:\ListA,(\haslengthA~l~(\length~l))$ it is enough to prove: -\noindent $(\LengthA~(\Nil~A)~(\length~(\Nil~A)))$ and +\noindent $(\haslengthA~(\Nil~A)~(\length~(\Nil~A)))$ and \smallskip -$\forall a:A, \forall l:\ListA, (\LengthA~l~(\length~l)) \ra -(\LengthA~(\cons~A~a~l)~(\length~(\cons~A~a~l)))$. +$\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra +(\haslengthA~(\cons~A~a~l)~(\length~(\cons~A~a~l)))$. \smallskip \noindent which given the conversion equalities satisfied by \length\ is the same as proving: -$(\LengthA~(\Nil~A)~\nO)$ and $\forall a:A, \forall l:\ListA, -(\LengthA~l~(\length~l)) \ra -(\LengthA~(\cons~A~a~l)~(\nS~(\length~l)))$. +$(\haslengthA~(\Nil~A)~\nO)$ and $\forall a:A, \forall l:\ListA, +(\haslengthA~l~(\length~l)) \ra +(\haslengthA~(\cons~A~a~l)~(\nS~(\length~l)))$. One conceptually simple way to do that, following the basic scheme proposed by Martin-L\"of in his Intuitionistic Type Theory, is to @@ -1370,15 +1370,15 @@ For $\ListA$ the type of $P$ will be $\ListA\ra s$ for $s \in \Sort$. \\ $ \CI{(\cons~A)}{P} \equiv \forall a:A, \forall l:\ListA,(P~(\cons~A~a~l))$. -For $\LengthA$, the type of $P$ will be -$\forall l:\ListA,\forall n:\nat, (\LengthA~l~n)\ra \Prop$ and the expression -\CI{(\LCons~A)}{P} is defined as:\\ +For $\haslengthA$, the type of $P$ will be +$\forall l:\ListA,\forall n:\nat, (\haslengthA~l~n)\ra \Prop$ and the expression +\CI{(\conshl~A)}{P} is defined as:\\ $\forall a:A, \forall l:\ListA, \forall n:\nat, \forall -h:(\LengthA~l~n), (P~(\cons~A~a~l)~(\nS~n)~(\LCons~A~a~l~n~l))$.\\ +h:(\haslengthA~l~n), (P~(\cons~A~a~l)~(\nS~n)~(\conshl~A~a~l~n~l))$.\\ If $P$ does not depend on its third argument, we find the more natural expression:\\ $\forall a:A, \forall l:\ListA, \forall n:\nat, -(\LengthA~l~n)\ra(P~(\cons~A~a~l)~(\nS~n))$. +(\haslengthA~l~n)\ra(P~(\cons~A~a~l)~(\nS~n))$. \paragraph{Typing rule.} @@ -1411,7 +1411,7 @@ only constructors of $I$. \end{description} \paragraph{Example.} -For \List\ and \Length\ the typing rules for the {\tt match} expression +For \List\ and \haslength\ the typing rules for the {\tt match} expression are (writing just $t:M$ instead of \WTEG{t}{M}, the global environment and local context being the same in all the judgments). @@ -1421,11 +1421,11 @@ local context being the same in all the judgments). \[\frac{ \begin{array}[b]{@{}c@{}} -H:(\LengthA~L~N) \\ P:\forall l:\ListA, \forall n:\nat, (\LengthA~l~n)\ra +H:(\haslengthA~L~N) \\ P:\forall l:\ListA, \forall n:\nat, (\haslengthA~l~n)\ra \Prop\\ - f_1:(P~(\Nil~A)~\nO~\LNil) \\ + f_1:(P~(\Nil~A)~\nO~\nilhl) \\ f_2:\forall a:A, \forall l:\ListA, \forall n:\nat, \forall - h:(\LengthA~l~n), (P~(\cons~A~a~n)~(\nS~n)~(\LCons~A~a~l~n~h)) + h:(\haslengthA~l~n), (P~(\cons~A~a~n)~(\nS~n)~(\conshl~A~a~l~n~h)) \end{array}} {\Case{P}{H}{f_1~|~f_2}:(P~L~N~H)}\] -- cgit v1.2.3 From 754bc95497ccf903391e5aa1cfda45cb59ad7927 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 10:23:19 +0100 Subject: ENH: new example: "even" --- doc/common/macros.tex | 5 +++++ doc/refman/RefMan-cic.tex | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 1ac29b1553..0ea2ed650b 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -280,6 +280,11 @@ \newcommand{\Type}{\mbox{\textsf{Type}}} \newcommand{\unfold}{\mbox{\textsf{unfold}}} \newcommand{\zeros}{\mbox{\textsf{zeros}}} +\newcommand{\even}{\mbox{\textsf{even}}} +\newcommand{\odd}{\mbox{\textsf{even}}} +\newcommand{\evenO}{\mbox{\textsf{even\_O}}} +\newcommand{\evenS}{\mbox{\textsf{even\_S}}} +\newcommand{\oddS}{\mbox{\textsf{odd\_S}}} %%%%%%%%% % Misc. % diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index bbf6372846..101c4e5036 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -640,6 +640,42 @@ and thus it enriches the global environment with the following entry: \vskip1em\hrule\vskip1em +\noindent If we take the following inductive definition: +\begin{coq_example*} +Inductive even : nat -> Prop := + | even_O : even 0 + | even_S : forall n, odd n -> even (S n) +with odd : nat -> Prop := + | odd_S : forall n, even n -> odd (S n). +\end{coq_example*} +then: +\def\GammaI{\left[\begin{array}{r \colon l} + \even & \nat\ra\Prop \\ + \odd & \nat\ra\Prop + \end{array} + \right]} +\def\GammaC{\left[\begin{array}{r \colon l} + \evenO & \even~\nO \\ + \evenS & \forall n : \nat, \odd~n \ra \even~(\nS~n) + \end{array} + \right]} +\begin{itemize} + \item $p = 1$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ +\end{itemize} +and thus it enriches the global environment with the following entry: +\vskip.5em +\ind{p}{\Gamma_I}{\Gamma_C} +\vskip.5em +\noindent that is: +\vskip.5em +\ind{1}{\GammaI}{\GammaC} +\vskip.5em +\noindent In this case, $\Gamma_P=[A:\Type]$. + +\vskip1em\hrule\vskip1em + \noindent If we take the following inductive definition: \begin{coq_example*} Inductive has_length (A : Type) : list A -> nat -> Prop := -- cgit v1.2.3 From 6c9f5450f476da94aa70df93c5a6368b98e73e90 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 10:37:16 +0100 Subject: CLEANUP: superfluous examples were removed --- doc/common/macros.tex | 2 +- doc/refman/RefMan-cic.tex | 20 +++++--------------- 2 files changed, 6 insertions(+), 16 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 0ea2ed650b..a6240ad284 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -281,7 +281,7 @@ \newcommand{\unfold}{\mbox{\textsf{unfold}}} \newcommand{\zeros}{\mbox{\textsf{zeros}}} \newcommand{\even}{\mbox{\textsf{even}}} -\newcommand{\odd}{\mbox{\textsf{even}}} +\newcommand{\odd}{\mbox{\textsf{odd}}} \newcommand{\evenO}{\mbox{\textsf{even\_O}}} \newcommand{\evenS}{\mbox{\textsf{even\_S}}} \newcommand{\oddS}{\mbox{\textsf{odd\_S}}} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 101c4e5036..d3e8755a85 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -763,21 +763,11 @@ these two inference rules above enable us to conclude that: \vskip.5em \def\prefix{E[\Gamma]\vdash\hskip.25em} $\begin{array}{@{} l} - \prefix\bool : \Set\\ - \prefix\true : \bool\\ - \prefix\false : \bool\\ - \prefix\nat : \Set\\ - \prefix\nO : \nat\\ - \prefix\nS : \nat\ra\nat\\ - \prefix\List : \Type\ra\Type\\ - \prefix\Nil : \forall~A\!:\!\Type,~\List~A\\ - \prefix\cons : \forall~A\!:\!\Type,~A\ra\List~A\ra\List~A\\ - \prefix\haslength : \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop\\ - \prefix\nilhl : \forall~A\!:\!\Type,~\haslength~A~(\Nil~A)~\nO\\ - \begin{array}{l l} - \hskip-.5em\prefix\conshl :\hskip-.5em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ - & \haslength~A~l~n\ra \haslength~A~(\cons~A~a~l)~(\nS~n) - \end{array} + \prefix\even : \nat\ra\Prop\\ + \prefix\odd : \nat\ra\Prop\\ + \prefix\evenO : \even~\nO\\ + \prefix\evenS : \forall~n:\nat, \odd~n \ra \even~(\nS~n)\\ + \prefix\oddS : \forall~n:\nat, \even~n \ra \odd~(\nS~n) \end{array}$ %\paragraph{Parameters.} -- cgit v1.2.3 From 4570133034c9457a4d641449a522c29a8f029a55 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 10:45:04 +0100 Subject: FIX: commit 315f771 --- doc/refman/RefMan-cic.tex | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index d3e8755a85..d3b4f3af7c 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -59,7 +59,9 @@ Formally, we call {\Sort} the set of sorts which is defined by: \index{Prop@{\Prop}}% \index{Set@{\Set}}% \[\Sort \equiv \{\Prop,\Set,\Type(i)\;|\; i \in \NN\} \] -Their properties are defined in Section~\ref{subtyping-rules}. +Their properties, such as: +{\Prop:\Type$(1)$}, {\Set:\Type$(1)$}, and {\Type$(i)$:\Type$(i+1)$}, +are defined in Section~\ref{subtyping-rules}. % TODO: Somewhere in the document we should explain: % - what concrete actions (in *.v files) cause creation of new universes -- cgit v1.2.3 From 8b559623f8f2539836069a7352498a5e2c4784e6 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 11:27:35 +0100 Subject: COMMENT: to do --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index d3b4f3af7c..f7a6470f9c 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -184,6 +184,7 @@ More precisely the language of the {\em Calculus of Inductive The notion of free variables is defined as usual. In the expressions $\lb x:T\mto U$ and $\forall x:T, U$ the occurrences of $x$ in $U$ are bound. +% TODO: what is the best play to say that "terms are considered equal up to α-conversion"? \paragraph[Substitution.]{Substitution.\index{Substitution}} The notion of substituting a term $t$ to free occurrences of a -- cgit v1.2.3 From f07348e606882ddb0d69029bde82be3106335f21 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 11:39:54 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index f7a6470f9c..5df70a8e97 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -305,6 +305,7 @@ local context $\Gamma$ and a term $T$ such that the judgment \WTEG{t}{T} can be derived from the following rules. \begin{description} \item[W-Empty] \inference{\WF{[]}{}} +% QUESTION: Why in W-Local-Assum and W-Local-Def we do not need x ∉ E hypothesis? \item[W-Local-Assum] % Ce n'est pas vrai : x peut apparaitre plusieurs fois dans Gamma \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~x \not\in \Gamma % \cup E }{\WFE{\Gamma::(x:T)}}} -- cgit v1.2.3 From ee629d65f2d36544b0e5c8afb657933ef19c296d Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 11:40:20 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 5df70a8e97..45613e03af 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -312,6 +312,7 @@ be derived from the following rules. \item[W-Local-Def] \inference{\frac{\WTEG{t}{T}~~~~x \not\in \Gamma % \cup E }{\WFE{\Gamma::(x:=t:T)}}} +% QUESTION: Why in W-Global-Assum and W-Global-Def we do not need x ∉ Γ hypothesis? \item[W-Global-Assum] \inference{\frac{\WTE{}{T}{s}~~~~s \in \Sort~~~~c \notin E} {\WF{E;c:T}{}}} \item[W-Global-Def] \inference{\frac{\WTE{}{t}{T}~~~c \notin E} -- cgit v1.2.3 From 420e750c4ef3be1d562e1729e5ec6adf94795913 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 18 Nov 2015 16:36:22 +0100 Subject: CLEANUP: the definition of "type of constructor" was rephrased in order to make it more clear --- doc/refman/RefMan-cic.tex | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 45613e03af..d05e3dd9e8 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -814,9 +814,12 @@ such that $T$ is an arity of sort $s$. $A\ra \Set$ and $\forall~A:\Prop,A\ra \Prop$ are arities. \paragraph[Definition]{Definition\index{type of constructor}} -A {\em type of constructor of $I$}\index{Type of constructor} is either a term -$(I~t_1\ldots ~t_n)$ or $\fa x:T,C$ with $C$ recursively -a {\em type of constructor of $I$}. +We say that $T$ is a {\em type of constructor of $I$\index{type of constructor}} +in one of the following two cases: +\begin{itemize} + \item $T$ is $(I~t_1\ldots ~t_n)$ + \item $T$ is $\forall x:U,T^\prime$ where $T^\prime$ is also a type of constructor of $I$ +\end{itemize} \paragraph[Examples]{Examples} $\nat$ and $\nat\ra\nat$ are types of constructors of $\nat$.\\ -- cgit v1.2.3 From 27c19fffda5c5b1f119a1b2115915b330fdfe1ba Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 13:25:42 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index d05e3dd9e8..c3dc80b1a6 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -828,6 +828,7 @@ $\forall A:\Type,\List~A$ and $\forall A:\Type,A\ra\List~A\ra\List~A$ are constr \paragraph[Definition]{Definition\index{Positivity}\label{Positivity}} The type of constructor $T$ will be said to {\em satisfy the positivity condition} for a constant $X$ in the following cases: +% QUESTION: Why is this property called "positivity"? \begin{itemize} \item $T=(X~t_1\ldots ~t_n)$ and $X$ does not occur free in -- cgit v1.2.3 From fc73973844f848fafb61b6aa39a327e95f09c129 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 13:28:57 +0100 Subject: CLEANUP: s/List_A/List~A/g --- doc/common/macros.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index a6240ad284..2271a8f134 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -261,7 +261,7 @@ \newcommand{\length}{\mbox{\textsf{length}}} \newcommand{\haslengthA}{\mbox {\textsf{has\_length~A}}} \newcommand{\List}{\mbox{\textsf{list}}} -\newcommand{\ListA}{\mbox{\textsf{List\_A}}} +\newcommand{\ListA}{\mbox{\textsf{List}~A}} \newcommand{\nilhl}{\mbox{\textsf{nil\_hl}}} \newcommand{\conshl}{\mbox{\textsf{cons\_hl}}} \newcommand{\nat}{\mbox{\textsf{nat}}} -- cgit v1.2.3 From 5a155b13b6a6820a1c0417025c67170a3e22fedc Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 13:32:59 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index c3dc80b1a6..c15ee9ffdd 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -820,6 +820,9 @@ in one of the following two cases: \item $T$ is $(I~t_1\ldots ~t_n)$ \item $T$ is $\forall x:U,T^\prime$ where $T^\prime$ is also a type of constructor of $I$ \end{itemize} +% QUESTION: Are we above sufficiently precise? +% Shouldn't we say also what is "n"? +% "n" couldn't be "0", could it? \paragraph[Examples]{Examples} $\nat$ and $\nat\ra\nat$ are types of constructors of $\nat$.\\ -- cgit v1.2.3 From c5a7d2bec3232625dcb50cfc3a3d6d5abcb81ff0 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 3 Nov 2015 16:59:08 +0100 Subject: ENH: examples for 'strict positivity' were expanded --- doc/common/macros.tex | 4 ++- doc/refman/RefMan-cic.tex | 72 +++++++++++++++++++++++++++++++++++------ doc/refman/Reference-Manual.tex | 1 + 3 files changed, 66 insertions(+), 11 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 2271a8f134..3b12f259b6 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -261,7 +261,7 @@ \newcommand{\length}{\mbox{\textsf{length}}} \newcommand{\haslengthA}{\mbox {\textsf{has\_length~A}}} \newcommand{\List}{\mbox{\textsf{list}}} -\newcommand{\ListA}{\mbox{\textsf{List}~A}} +\newcommand{\ListA}{\mbox{\textsf{list}}~\ensuremath{A}} \newcommand{\nilhl}{\mbox{\textsf{nil\_hl}}} \newcommand{\conshl}{\mbox{\textsf{cons\_hl}}} \newcommand{\nat}{\mbox{\textsf{nat}}} @@ -285,6 +285,8 @@ \newcommand{\evenO}{\mbox{\textsf{even\_O}}} \newcommand{\evenS}{\mbox{\textsf{even\_S}}} \newcommand{\oddS}{\mbox{\textsf{odd\_S}}} +\newcommand{\Prod}{\mbox{\textsf{prod}}} +\newcommand{\Pair}{\mbox{\textsf{pair}}} %%%%%%%%% % Misc. % diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index c15ee9ffdd..1c374e9397 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -876,16 +876,68 @@ any $u_i$ the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} -\paragraph{Example} - -$X$ occurs strictly positively in $A\ra X$ or $X*A$ or $({\tt list}~ -X)$ but not in $X \ra A$ or $(X \ra A)\ra A$ nor $({\tt neg}~X)$ -assuming the notion of product and lists were already defined and {\tt - neg} is an inductive definition with declaration \Ind{}{A:\Set}{{\tt - neg}:\Set}{{\tt neg}:(A\ra{\tt False}) \ra {\tt neg}}. Assuming -$X$ has arity ${\tt nat \ra Prop}$ and {\tt ex} is the inductively -defined existential quantifier, the occurrence of $X$ in ${\tt (ex~ - nat~ \lb n:nat\mto (X~ n))}$ is also strictly positive. +\newcommand\vv{\textSFxi} % │ +\newcommand\hh{\textSFx} % ─ +\newcommand\vh{\textSFviii} % ├ +\newcommand\hv{\textSFii} % └ +\newlength\framecharacterwidth +\settowidth\framecharacterwidth{\hh} +\newcommand\ws{\hbox{}\hskip\the\framecharacterwidth} +\newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} +\paragraph{Example}~\\ +\vskip-.5em +\noindent$X$ occurs strictly positively in $A\ra X$\ruleref5\\ +\vv\\ +\vh\hh\ws $X$does not occur in $A$\ruleref3\\ +\vv\\ +\hv\hh\ws $X$ occurs strictly positively in $X$\ruleref4 +\paragraph{Example}~\\ +\vskip-.5em +\noindent $X$ occurs strictly positively in $X*A$\\ +\vv\\ +\hv\hh $X$ occurs strictly positively in $(\Prod~X~A)$\ruleref6\\ +\ws\ws\vv\\ +\ws\ws\vv\ws\verb|Inductive prod (A B : Type) : Type :=|\\ +\ws\ws\vv\ws\verb| pair : A -> B -> prod A B.|\\ +\ws\ws\vv\\ +\ws\ws\vh\hh $X$ does not occur in any (real) arguments of $\Prod$ in the original term $(\Prod~X~A)$\\ +\ws\ws\vv\\ +\ws\ws\hv\ws the (instantiated) type $\Prod~X~A$ of constructor $\Pair$,\\ +\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref7\\ +\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\hv\ws $X$ does not occur in any (real) arguments of $(\Prod~X~A)$ +\paragraph{Example}~\\ +\vskip-.5em +\noindent $X$ occurs strictly positively in $\ListA$\ruleref6\\ +\vv\\ +\vv\ws\verb|Inductive list (A:Type) : Type :=|\\ +\vv\ws\verb$ | nil : list A$\\ +\vv\ws\verb$ | cons : A -> list A -> list A$\\ +\vv\\ +\vh\hh $X$ does not occur in any arguments of $\List$\\ +\vv\\ +\hv\hh\ws Every instantiated constructor of $\ListA$ satisfies the nested positivity condition for $X$\\ +\ws\ws\ws\vv\\ +\ws\ws\ws\vh\hh\ws concerning type $\ListA$ of constructor $\Nil$:\\ +\ws\ws\ws\vv\ws\ws Type $\ListA$ of constructor $\Nil$ satisfies the nested positivity condition for $X$\\ +\ws\ws\ws\vv\ws\ws because $X$ does not appear in any (real) arguments of the type of that constructor\\ +\ws\ws\ws\vv\ws\ws (primarily because $\List$ does not have any (real) arguments)\ruleref7\\ +\ws\ws\ws\vv\\ +\ws\ws\ws\hv\hh\ws concerning type $\forall~A\ra\ListA\ra\ListA$ of constructor $\cons$:\\ +\ws\ws\ws\ws\ws\ws Type $\forall~A:\Type,A\ra\ListA\ra\ListA$ of constructor $\cons$\\ +\ws\ws\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref8\\ +\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\Type$\ruleref3\\ +\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $A\ra\ListA\ra\ListA$\ruleref8\\ +\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $A$\ruleref3\\ +\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA\ra\ListA$\ruleref8\\ +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\ws $X$ occurs only strictly positively in $\ListA$\ruleref3\\ +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 \paragraph{Correctness rules.} We shall now describe the rules allowing the introduction of a new diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index ac28e0ba03..cb5d2ecb54 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -20,6 +20,7 @@ \usepackage{headers} % in this directory \usepackage{multicol} \usepackage{xspace} +\usepackage{pmboxdraw} % for coqide \ifpdf % si on est pas en pdflatex -- cgit v1.2.3 From 7fb0ac951bbc8081642448cab92def3540ee2f3f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 14:55:52 +0100 Subject: COMMENT: questions --- doc/refman/RefMan-cic.tex | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 1c374e9397..28c1c66453 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -835,6 +835,7 @@ condition} for a constant $X$ in the following cases: \begin{itemize} \item $T=(X~t_1\ldots ~t_n)$ and $X$ does not occur free in +% QUESTIONS: What is the meaning of 'n' above? any $t_i$ \item $T=\forall~x:U,V$ and $X$ occurs only strictly positively in $U$ and the type $V$ satisfies the positivity condition for $X$ @@ -846,10 +847,12 @@ following cases: \begin{itemize} \item $X$ does not occur in $T$ \item $T$ converts to $(X~t_1 \ldots ~t_n)$ and $X$ does not occur in +% QUESTIONS: What is the meaning of 'n' above? any of $t_i$ \item $T$ converts to $\forall~x:U,V$ and $X$ does not occur in type $U$ but occurs strictly positively in type $V$ \item $T$ converts to $(I~a_1 \ldots ~a_m ~ t_1 \ldots ~t_p)$ where +% QUESTIONS: What is the meaning of 'p' above? $I$ is the name of an inductive declaration of the form $\Ind{\Gamma}{m}{I:A}{c_1:\forall p_1:P_1,\ldots \forall p_m:P_m,C_1;\ldots;c_n:\forall p_1:P_1,\ldots \forall @@ -872,6 +875,7 @@ cases: \item $T=(I~b_1\ldots b_m~u_1\ldots ~u_{p})$, $I$ is an inductive definition with $m$ parameters and $X$ does not occur in any $u_i$ +% QUESTIONS: What is the meaning of 'p' above? \item $T=\forall~x:U,V$ and $X$ occurs only strictly positively in $U$ and the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} -- cgit v1.2.3 From d0d4eb3aedc2d971a1ab4182ac5e4ee3ac741427 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 18:54:07 +0100 Subject: FIX: making sure that my previous edits do not break HTML generation --- doc/refman/RefMan-cic.tex | 87 ++++++++++++++++++++++++++++++----------------- 1 file changed, 56 insertions(+), 31 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 28c1c66453..00ba0091ee 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -434,15 +434,34 @@ $\eta$-expansion $\lb x:T\mto (t\ x)$ for $x$ an arbitrary variable name fresh in $t$. \Rem We deliberately do not define $\eta$-reduction: -\def\noeta{\hskip-.1em\not\triangleright_\eta} -$$\lb x:T\mto (t\ x)\hskip.1em\noeta\hskip.3em t$$ +\begin{latexonly} + $$\lb x:T\mto (t\ x)\not\triangleright_\eta\hskip.3em t$$ +\end{latexonly} +\begin{htmlonly} + $$\lb x:T\mto (t\ x)~\not\triangleright_\eta~t$$ +\end{htmlonly} This is because, in general, the type of $t$ need not to be convertible to the type of $\lb x:T\mto (t\ x)$. E.g., if we take $f$ such that: -$$f\hskip.5em:\hskip.5em\forall x:Type(2),Type(1)$$ +\begin{latexonly} + $$f\hskip.5em:\hskip.5em\forall x:Type(2),Type(1)$$ +\end{latexonly} +\begin{htmlonly} + $$f~:~\forall x:Type(2),Type(1)$$ +\end{htmlonly} then -$$\lb x:Type(1),(f\, x)\hskip.5em:\hskip.5em\forall x:Type(1),Type(1)$$ +\begin{latexonly} + $$\lb x:Type(1),(f\, x)\hskip.5em:\hskip.5em\forall x:Type(1),Type(1)$$ +\end{latexonly} +\begin{htmlonly} + $$\lb x:Type(1),(f\, x)~:~\forall x:Type(1),Type(1)$$ +\end{htmlonly} We could not allow -$$\lb x:Type(1),(f\,x)\hskip.5em\noeta\hskip.6em f$$ +\begin{latexonly} + $$\lb x:Type(1),(f\,x)\hskip.4em\not\triangleright_\eta\hskip.6em f$$ +\end{latexonly} +\begin{htmlonly} + $$\lb x:Type(1),(f\,x)~\not\triangleright_\eta~f$$ +\end{htmlonly} because the type of the reduced term $\forall x:Type(2),Type(1)$ would not be convertible to the type of the original term $\forall x:Type(1),Type(1)$. @@ -530,13 +549,14 @@ Formally, we can represent any {\em inductive definition\index{definition!induct \item $p$ determines the number of parameters of these inductive types. \end{itemize} These inductive definitions, together with global assumptions and global definitions, then form the global environment. -\vskip.5em + \noindent Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: $\forall\Gamma_P, T^\prime$. -\vskip.5em + \noindent $\Gamma_P$ is called {\em context of parameters\index{context of parameters}}. +\begin{latexonly} \subsection*{Examples} If we take the following inductive definition (denoted in concrete syntax): @@ -547,35 +567,35 @@ Inductive bool : Set := \end{coq_example*} then: \def\colon{@{\hskip.5em:\hskip.5em}} -\def\GammaI{\left[\begin{array}{r \colon l} - \bool & \Set - \end{array} - \right]} -\def\GammaC{\left[\begin{array}{r \colon l} - \true & \bool\\ - \false & \bool - \end{array} - \right]} \newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em \begin{array}{r @{\mathrm{~:=~}} l} #2 & #3 \\ \end{array} \hskip-.4em \right)$} -\begin{itemize} - \item $p = 0$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ -\end{itemize} -and thus it enriches the global environment with the following entry: -\vskip.5em -\ind{p}{\Gamma_I}{\Gamma_C} -\vskip.5em -\noindent that is: -\vskip.5em -\ind{0}{\GammaI}{\GammaC} -\vskip.5em -\noindent In this case, $\Gamma_P=[\,]$. + \def\GammaI{\left[\begin{array}{r \colon l} + \bool & \Set + \end{array} + \right]} + \def\GammaC{\left[\begin{array}{r \colon l} + \true & \bool\\ + \false & \bool + \end{array} + \right]} + \begin{itemize} + \item $p = 0$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ + \end{itemize} + and thus it enriches the global environment with the following entry: + \vskip.5em + \ind{p}{\Gamma_I}{\Gamma_C} + \vskip.5em + \noindent that is: + \vskip.5em + \ind{0}{\GammaI}{\GammaC} + \vskip.5em + \noindent In this case, $\Gamma_P=[\,]$. \vskip1em\hrule\vskip1em @@ -608,7 +628,7 @@ and thus it enriches the global environment with the following entry: \vskip.5em \ind{0}{\GammaI}{\GammaC} \vskip.5em -\noindent In this case, $\Gamma_P=[\,]$. +\noindent In this case, $\Gamma_P=[~]$. \vskip1em\hrule\vskip1em @@ -750,6 +770,7 @@ and thus it enriches the global environment with the following entry: \ind{0}{\GammaI}{\GammaC} \vskip.5em \noindent In this case, $\Gamma_P=[\,]$. +\end{latexonly} \subsection{Types of inductive objects} We have to give the type of constants in a global environment $E$ which @@ -762,6 +783,7 @@ contains an inductive declaration. \inference{\frac{\WFE{\Gamma}\hskip2em\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\hskip2em(c:C)\in\Gamma_C}{\WTEG{c}{C}}} \end{description} +\begin{latexonly} \paragraph{Example.} Provided that our environment $E$ contains inductive definitions we showed before, these two inference rules above enable us to conclude that: @@ -774,6 +796,7 @@ $\begin{array}{@{} l} \prefix\evenS : \forall~n:\nat, \odd~n \ra \even~(\nS~n)\\ \prefix\oddS : \forall~n:\nat, \even~n \ra \odd~(\nS~n) \end{array}$ +\end{latexonly} %\paragraph{Parameters.} %%The parameters introduce a distortion between the inside specification @@ -880,6 +903,7 @@ any $u_i$ the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} +\begin{latexonly} \newcommand\vv{\textSFxi} % │ \newcommand\hh{\textSFx} % ─ \newcommand\vh{\textSFviii} % ├ @@ -942,6 +966,7 @@ the type $V$ satisfies the nested positivity condition for $X$ \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\ws $X$ occurs only strictly positively in $\ListA$\ruleref3\\ \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 +\end{latexonly} \paragraph{Correctness rules.} We shall now describe the rules allowing the introduction of a new -- cgit v1.2.3 From 70e705a47f435e1453d889177a426d89dacda07b Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 18:54:17 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 00ba0091ee..1013084702 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -969,6 +969,10 @@ the type $V$ satisfies the nested positivity condition for $X$ \end{latexonly} \paragraph{Correctness rules.} +% QUESTION: For a related problem, in case of global definitions +% and global assumptions, we used the term "well-formedness". +% Couldn't we continue to use the term also here? +% Does it make sense to use a different name, i.e. "correctness" in this case? We shall now describe the rules allowing the introduction of a new inductive definition. -- cgit v1.2.3 From 1200468d82136ab3279bbe18da8fa0ba4e4cc8c4 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 19:23:40 +0100 Subject: FIX: removing a reference to \Gamma, because it is undefined --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 1013084702..51a0068b03 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -994,7 +994,7 @@ provided that the following side conditions hold: \item $p$ is the number of parameters of \NInd{}{\Gamma_I}{\Gamma_C} and $\Gamma_P$ is the context of parameters, \item for $j=1\ldots k$ we have that $A_j$ is an arity of sort $s_j$ and $I_j - \notin \Gamma \cup E$, + \notin E$, \item for $i=1\ldots n$ we have that $C_i$ is a type of constructor of $I_{q_i}$ which satisfies the positivity condition for $I_1 \ldots I_k$ and $c_i \notin \Gamma \cup E$. -- cgit v1.2.3 From d62af5e39af63387f60dd0a92d9fbfd65974fcae Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 19:24:41 +0100 Subject: COMMENT: to do --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 51a0068b03..bacd62b776 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -999,6 +999,7 @@ provided that the following side conditions hold: $I_{q_i}$ which satisfies the positivity condition for $I_1 \ldots I_k$ and $c_i \notin \Gamma \cup E$. \end{itemize} +% TODO: justify the above constraints \end{description} One can remark that there is a constraint between the sort of the arity of the inductive type and the sort of the type of its -- cgit v1.2.3 From 2b7368ae43fefb6f151b7032b351f0da796f6cc3 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 19:26:26 +0100 Subject: COMMENT: to do --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index bacd62b776..ddd9f075ef 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1024,6 +1024,7 @@ The same definition on \Set{} is not allowed and fails: Fail Inductive exSet (P:Set->Prop) : Set := exS_intro : forall X:Set, P X -> exSet P. \end{coq_example} +% TODO: add the description of the 'Fail' command to the reference manual It is possible to declare the same inductive definition in the universe \Type. The \texttt{exType} inductive definition has type $(\Type_i \ra\Prop)\ra -- cgit v1.2.3 From 5edfac63b6feb0b8d6ddad47a4ca9c8b5905b03a Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 19:31:05 +0100 Subject: COMMENT: questions --- doc/refman/RefMan-cic.tex | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ddd9f075ef..b862db3204 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1910,7 +1910,36 @@ impredicative system for sort \Set{} become: {\compat{I:\Set}{I\ra s}}} \end{description} +% QUESTION: Why, when I add this definition: +% +% Inductive foo : Type := . +% +% Coq claims that the type of 'foo' is 'Prop'? + +% QUESTION: If I add this definition: +% +% Inductive bar (A:Type) : Type := . +% +% then Coq claims that 'bar' has type 'Type → Prop' where I would expect 'Type → Type' with appropriate constraint. +% QUESTION: If I add this definition: +% +% Inductive foo (A:Type) : Type := +% | foo1 : foo A +% | foo2 : foo A. +% +% then Coq claims that 'foo' has type 'Type → Set'. +% Why? + +% NOTE: If I add this definition: +% +% Inductive foo (A:Type) : Type := +% | foo1 : foo A +% | foo2 : A → foo A. +% +% then Coq claims, as expected, that: +% +% foo : Type → Type. %%% Local Variables: %%% mode: latex -- cgit v1.2.3 From 760765859cb74930ac8fd14fc1a241aa8ae20aa0 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 19:41:25 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index b862db3204..9e49481e23 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1007,6 +1007,7 @@ constructors which will always be satisfied for the impredicative sort {\Prop} but may fail to define inductive definition on sort \Set{} and generate constraints between universes for inductive definitions in the {\Type} hierarchy. +% QUESTION: which 'constraint' are we above referring to? \paragraph{Examples.} It is well known that existential quantifier can be encoded as an -- cgit v1.2.3 From 1a51c868d6f342c094f2d9f0b8101d6c13720537 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 4 Nov 2015 19:48:18 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 9e49481e23..adaa20de86 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1044,6 +1044,7 @@ Inductive exType (P:Type->Prop) : Type Inductive types declared in {\Type} are polymorphic over their arguments in {\Type}. +% QUESTION: Just arguments? Not also over the parameters? If $A$ is an arity of some sort and $s$ is a sort, we write $A_{/s}$ for the arity obtained from $A$ by replacing its sort with $s$. Especially, if $A$ -- cgit v1.2.3 From 90ae0897e80106194795e179d580da0d1118aaf2 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 09:14:23 +0100 Subject: CLEANUP PROPOSITION: s/local context of parameters/context of parameters --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index adaa20de86..6f0e952ce6 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1055,7 +1055,7 @@ The following typing rule is added to the theory. \begin{description} \item[Ind-Family] Let $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ be an inductive definition. Let $\Gamma_P = [p_1:P_1;\ldots;p_{p}:P_{p}]$ - be its local context of parameters, $\Gamma_I = [I_1:\forall + be its context of parameters, $\Gamma_I = [I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ its context of definitions and $\Gamma_C = [c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall \Gamma_P,C_n]$ its context of -- cgit v1.2.3 From 02b64e2d6c69996f95fa7bbcaf228e4848ad69f4 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 10:09:01 +0100 Subject: CLEANUP PROPOSITION: superfluous parentheses were removed --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 6f0e952ce6..a5832450ce 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1079,7 +1079,7 @@ The following typing rule is added to the theory. 1 \leq j \leq k \end{array} \right.} -{E[] \vdash (I_j\,q_1\,\ldots\,q_r:\forall [p_{r+1}:P_{r+1};\ldots;p_{p}:P_{p}], (A_j)_{/s_j})} +{E[] \vdash I_j\,q_1\,\ldots\,q_r:\forall [p_{r+1}:P_{r+1};\ldots;p_{p}:P_{p}], (A_j)_{/s_j}} } provided that the following side conditions hold: -- cgit v1.2.3 From a90487b5b377c1eadcc4bbb373ad489b4d236a7f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 10:43:04 +0100 Subject: GRAMMAR --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index a5832450ce..14a5e12fc5 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1160,7 +1160,7 @@ hence, if \texttt{option} is applied to a type in {\Set}, the result is in {\Set}. Note that if \texttt{option} is applied to a type in {\Prop}, then, the result is not set in \texttt{Prop} but in \texttt{Set} still. This is because \texttt{option} is not a singleton type (see -section~\ref{singleton}) and it would loose the elimination to {\Set} and +section~\ref{singleton}) and it would lose the elimination to {\Set} and {\Type} if set in {\Prop}. \begin{coq_example} -- cgit v1.2.3 From 2a5edc8ab15e556c6ee1741ffefb6869736feada Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 13:09:32 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 14a5e12fc5..ea1be67ee9 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1094,6 +1094,7 @@ $P_l$ arity implies $P'_l$ arity since $\WTEGLECONV{P'_l}{ \subst{P_l}{p_u}{q_u} we have $(\WTE{\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; \item the sorts are such that all eliminations, to {\Prop}, {\Set} and $\Type(j)$, are allowed (see section~\ref{elimdep}). +% QUESTION: How should I interpret the above side-condition, when I am trying to show that 'list nat : Set'? \end{itemize} \end{description} -- cgit v1.2.3 From 3600dbb0546a910cda3996b5226bd7a6800d3040 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 13:46:40 +0100 Subject: TYPESETTING --- doc/refman/RefMan-cic.tex | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ea1be67ee9..001ce54f8c 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -962,10 +962,10 @@ the type $V$ satisfies the nested positivity condition for $X$ \ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $A$\ruleref3\\ \ws\ws\ws\ws\ws\ws\ws\ws\vv\\ \ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA\ra\ListA$\ruleref8\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\ws $X$ occurs only strictly positively in $\ListA$\ruleref3\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\ListA$\ruleref3\\ +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ +\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 \end{latexonly} \paragraph{Correctness rules.} -- cgit v1.2.3 From cd60731dae4e7627588027fe1c1aa60a2ae44594 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 14:09:54 +0100 Subject: FIX: removing references to Γ which is not defined in a given context --- doc/refman/RefMan-cic.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 001ce54f8c..37ca23417d 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1075,7 +1075,7 @@ The following typing rule is added to the theory. {\left\{\begin{array}{l} \Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\\ (E[] \vdash q_l : P'_l)_{l=1\ldots r}\\ -(\WTEGLECONV{P'_l}{\subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}})_{l=1\ldots r}\\ +(\WTELECONV{}{P'_l}{\subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}})_{l=1\ldots r}\\ 1 \leq j \leq k \end{array} \right.} @@ -1087,7 +1087,7 @@ provided that the following side conditions hold: \begin{itemize} \item $\Gamma_{P'}$ is the context obtained from $\Gamma_P$ by replacing each $P_l$ that is an arity with $P'_l$ for $1\leq l \leq r$ (notice that -$P_l$ arity implies $P'_l$ arity since $\WTEGLECONV{P'_l}{ \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}}$); +$P_l$ arity implies $P'_l$ arity since $\WTELECONV{}{P'_l}{ \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}}$); \item there are sorts $s_i$, for $1 \leq i \leq k$ such that, for $\Gamma_{I'} = [I_1:\forall \Gamma_{P'},(A_1)_{/s_1};\ldots;I_k:\forall \Gamma_{P'},(A_k)_{/s_k}]$ -- cgit v1.2.3 From 763723a144877582b9a5013b1c32a64de8e27db5 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 14:45:06 +0100 Subject: COMMENT: questions and to do --- doc/refman/RefMan-cic.tex | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 37ca23417d..1781d96fe5 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1098,6 +1098,8 @@ we have $(\WTE{\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; \end{itemize} \end{description} +% QUESTION: Do we need the following paragraph? +% (I find it confusing.) Notice that if $I_j\,q_1\,\ldots\,q_r$ is typable using the rules {\bf Ind-Const} and {\bf App}, then it is typable using the rule {\bf Ind-Family}. Conversely, the extended theory is not stronger than the @@ -1206,6 +1208,8 @@ Because we need to keep a consistent theory and also we prefer to keep a strongly normalizing reduction, we cannot accept any sort of recursion (even terminating). So the basic idea is to restrict ourselves to primitive recursive functions and functionals. +% TODO: it may be worthwhile to show the consequences of lifting +% those restrictions. For instance, assuming a parameter $A:\Set$ exists in the local context, we want to build a function \length\ of type $\ListA\ra \nat$ which @@ -1925,6 +1929,14 @@ impredicative system for sort \Set{} become: % % then Coq claims that 'bar' has type 'Type → Prop' where I would expect 'Type → Type' with appropriate constraint. +% QUESTION: If I add this definition: +% +% Inductive foo (A:Type) : Type := +% | foo1 : foo A +% +% then Coq claims that 'foo' has type 'Type → Prop'. +% Why? + % QUESTION: If I add this definition: % % Inductive foo (A:Type) : Type := -- cgit v1.2.3 From 5d32732cdf110e44a51cf6a23a8972f015e3fc88 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 15:05:47 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 1781d96fe5..9e5f18f52a 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1258,6 +1258,11 @@ But this operator is rather tedious to implement and use. We choose in this version of {\Coq} to factorize the operator for primitive recursion into two more primitive operations as was first suggested by Th. Coquand in~\cite{Coq92}. One is the definition by pattern-matching. The second one is a definition by guarded fixpoints. +% QUESTION: Shouldn't we, instead, include a more straightforward argument: +% +% http://matej-kosik.github.io/www/doc/coq/notes/24__match_and_fix.html +% +% ? \subsubsection[The {\tt match\ldots with \ldots end} construction.]{The {\tt match\ldots with \ldots end} construction.\label{Caseexpr} \index{match@{\tt match\ldots with\ldots end}}} -- cgit v1.2.3 From d95fd157ac6600f4784de44ef558c4880aed624b Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 15:25:50 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 9e5f18f52a..f69b402783 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1246,6 +1246,11 @@ same as proving: $(\haslengthA~(\Nil~A)~\nO)$ and $\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra (\haslengthA~(\cons~A~a~l)~(\nS~(\length~l)))$. +% QUESTION: Wouldn't something like: +% +% http://matej-kosik.github.io/www/doc/coq/notes/25__has_length.html +% +% be more comprehensible? One conceptually simple way to do that, following the basic scheme proposed by Martin-L\"of in his Intuitionistic Type Theory, is to -- cgit v1.2.3 From 0ad9953cfacda53dea9b08f3b5b60ee5531b0850 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 15:42:17 +0100 Subject: CLEANUP: removing duplicate paragraph --- doc/refman/RefMan-cic.tex | 6 ------ 1 file changed, 6 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index f69b402783..bea0079a5c 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1272,12 +1272,6 @@ in~\cite{Coq92}. One is the definition by pattern-matching. The second one is a \subsubsection[The {\tt match\ldots with \ldots end} construction.]{The {\tt match\ldots with \ldots end} construction.\label{Caseexpr} \index{match@{\tt match\ldots with\ldots end}}} -The basic idea of this operator is that we have an object -$m$ in an inductive type $I$ and we want to prove a property -which possibly depends on $m$. For this, it is enough to prove the -property for $m = (c_i~u_1\ldots u_{p_i})$ for each constructor of $I$. - - The basic idea of this operator is that we have an object $m$ in an inductive type $I$ and we want to prove a property which possibly depends on $m$. For this, it is enough to prove the -- cgit v1.2.3 From 42039fff68ea24ad3fff58d17d79195faa0ee3e7 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 15:46:06 +0100 Subject: FIX: "u_p" was not defined --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index bea0079a5c..34f55fa004 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1284,7 +1284,7 @@ In this expression, if $m$ eventually happens to evaluate to $(c_i~u_1\ldots u_{p_i})$ then the expression will behave as specified in its $i$-th branch and it will reduce to $f_i$ where the $x_{i1}$\ldots $x_{ip_i}$ are replaced -by the $u_1\ldots u_p$ according to the $\iota$-reduction. +by the $u_1\ldots u_{p_i}$ according to the $\iota$-reduction. Actually, for type-checking a \kw{match\ldots with\ldots end} expression we also need to know the predicate $P$ to be proved by case -- cgit v1.2.3 From 435c8b0fdf3c01d2618d1ffbbfe2321250326420 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:01:00 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 34f55fa004..148c4505c0 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1306,7 +1306,23 @@ The \kw{in} part can be omitted if the result type does not depend on the arguments of $I$. Note that the arguments of $I$ corresponding to parameters \emph{must} be \verb!_!, because the result type is not generalized to -all possible values of the parameters. The other arguments of $I$ +all possible values of the parameters. +% QUESTION: The last sentence above does not seem to be accurate. +% +% Imagine: +% +% Definition foo (A:Type) (a:A) (l : list A) := +% match l return A with +% | nil => a +% | cons _ _ _ => a +% end. +% +% There, the term in the return-clause happily refer to the parameter of 'l' +% and Coq does not protest. +% +% So I am not sure if I really understand why parameters cannot be bound +% in as-clause. +The other arguments of $I$ (sometimes called indices in the litterature) have to be variables ($a$ above) and these variables can occur in $P$ and bound in it. The expression after \kw{in} -- cgit v1.2.3 From 7028d08eb6e08d1a1af7f8e99f2e9edd880b8da2 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:04:59 +0100 Subject: ENH: improving precision --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 148c4505c0..f6e9152ca2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1295,7 +1295,7 @@ one corresponds to object $m$. \Coq{} can sometimes infer this predicate but sometimes not. The concrete syntax for describing this predicate uses the \kw{as\ldots in\ldots return} construction. For instance, let us assume that $I$ is an unary predicate with one -parameter. The predicate is made explicit using the syntax: +parameter and one argument. The predicate is made explicit using the syntax: \[\kw{match}~m~\kw{as}~ x~ \kw{in}~ I~\verb!_!~a~ \kw{return}~ P ~\kw{with}~ (c_1~x_{11}~...~x_{1p_1}) \Ra f_1 ~|~\ldots~|~ (c_n~x_{n1}~...~x_{np_n}) \Ra f_n \kw{end}\] -- cgit v1.2.3 From 3ecbc485d8e00a14aa643a34a448289d0014c7a8 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:08:47 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index f6e9152ca2..dee31cf86d 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1323,7 +1323,9 @@ all possible values of the parameters. % So I am not sure if I really understand why parameters cannot be bound % in as-clause. The other arguments of $I$ -(sometimes called indices in the litterature) have to be variables +(sometimes called indices in the litterature) +% QUESTION: in which literature? +have to be variables ($a$ above) and these variables can occur in $P$ and bound in it. The expression after \kw{in} must be seen as an \emph{inductive type pattern}. Notice that -- cgit v1.2.3 From 62005786bdb2e117442230c99ed8922e2c6eed81 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:08:55 +0100 Subject: GRAMMAR --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index dee31cf86d..2c1aedc407 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1323,7 +1323,7 @@ all possible values of the parameters. % So I am not sure if I really understand why parameters cannot be bound % in as-clause. The other arguments of $I$ -(sometimes called indices in the litterature) +(sometimes called indices in the literature) % QUESTION: in which literature? have to be variables ($a$ above) and these variables can occur in $P$ and bound in it. -- cgit v1.2.3 From 740d35edcb1caf599dfbb956efd0f10aa310b5ae Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:10:26 +0100 Subject: CLEANUP: unnecessary --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2c1aedc407..b3a9925b97 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1326,7 +1326,7 @@ The other arguments of $I$ (sometimes called indices in the literature) % QUESTION: in which literature? have to be variables -($a$ above) and these variables can occur in $P$ and bound in it. +($a$ above) and these variables can occur in $P$. The expression after \kw{in} must be seen as an \emph{inductive type pattern}. Notice that expansion of implicit arguments and notations apply to this pattern. -- cgit v1.2.3 From 4e8a02a38635cb33ecee78736a2661d169d52046 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:18:27 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index b3a9925b97..c54481e874 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1373,6 +1373,9 @@ We define now a relation \compat{I:A}{B} between an inductive definition $I$ of type $A$ and an arity $B$. This relation states that an object in the inductive definition $I$ can be eliminated for proving a property $\lb a x \mto P$ of type $B$. +% QUESTION: Is it necessary to explain the meaning of [I:A|B] in such a complicated way? +% Couldn't we just say that: "relation [I:A|B] defines which types can we choose as 'result types' +% with respect to the type of the matched object". The case of inductive definitions in sorts \Set\ or \Type{} is simple. There is no restriction on the sort of the predicate to be -- cgit v1.2.3 From d139d73949ee7ab6c070cac98f1af23431967ab0 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:21:56 +0100 Subject: ENH: a forward reference to a place where the concept of "allowed elimination sorts" is actually used --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index c54481e874..49e1649316 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1376,6 +1376,7 @@ proving a property $\lb a x \mto P$ of type $B$. % QUESTION: Is it necessary to explain the meaning of [I:A|B] in such a complicated way? % Couldn't we just say that: "relation [I:A|B] defines which types can we choose as 'result types' % with respect to the type of the matched object". +We use this concept to formulate the hypothesis of the typing rule for the match-construct. The case of inductive definitions in sorts \Set\ or \Type{} is simple. There is no restriction on the sort of the predicate to be -- cgit v1.2.3 From bce5332773276bca755dd47608dd13ae09016ded Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:29:48 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 49e1649316..9cb52dba28 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1395,6 +1395,8 @@ $I$. s_1 \in \{\Set,\Type(j)\}, s_2 \in \Sort}{\compat{I:s_1}{I\ra s_2}}} \end{description} +% QUESTION: What kind of value is represented by "x" in the "numerator"? +% There, "x" is unbound. Isn't it? The case of Inductive definitions of sort \Prop{} is a bit more complicated, because of our interpretation of this sort. The only -- cgit v1.2.3 From 55fee343ecbb6e510aa9c2729627fe7a758f384b Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:31:57 +0100 Subject: CLEANUP: originally, we talked about "B" as an "arity" --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 9cb52dba28..5a8dcfc245 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1372,7 +1372,7 @@ definitions. We define now a relation \compat{I:A}{B} between an inductive definition $I$ of type $A$ and an arity $B$. This relation states that an object in the inductive definition $I$ can be eliminated for -proving a property $\lb a x \mto P$ of type $B$. +proving a property $\lb a x \mto P$ of arity $B$. % QUESTION: Is it necessary to explain the meaning of [I:A|B] in such a complicated way? % Couldn't we just say that: "relation [I:A|B] defines which types can we choose as 'result types' % with respect to the type of the matched object". -- cgit v1.2.3 From 1caa0c61b7dfd535d4b2026e83933746de19291a Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:42:26 +0100 Subject: TYPOGRAPHY --- doc/refman/RefMan-cic.tex | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 5a8dcfc245..79756eb2fd 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1392,8 +1392,7 @@ $I$. \item[Prod] \inference{\frac{\compat{(I~x):A'}{B'}} {\compat{I:\forall x:A, A'}{\forall x:A, B'}}} \item[{\Set} \& \Type] \inference{\frac{ - s_1 \in \{\Set,\Type(j)\}, - s_2 \in \Sort}{\compat{I:s_1}{I\ra s_2}}} + s_1 \in \{\Set,\Type(j)\}~~~~~~~~s_2 \in \Sort}{\compat{I:s_1}{I\ra s_2}}} \end{description} % QUESTION: What kind of value is represented by "x" in the "numerator"? % There, "x" is unbound. Isn't it? -- cgit v1.2.3 From f427a920e6fa31b145578c53d8853266cd215a26 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 16:43:58 +0100 Subject: COMMENT: note --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 79756eb2fd..7c38a54ea6 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1396,6 +1396,7 @@ $I$. \end{description} % QUESTION: What kind of value is represented by "x" in the "numerator"? % There, "x" is unbound. Isn't it? +% NOTE: Above, "Set" is subsumed in "Type(0)" so, strictly speaking, we wouldn't need to mention in explicitely. The case of Inductive definitions of sort \Prop{} is a bit more complicated, because of our interpretation of this sort. The only -- cgit v1.2.3 From 6a54c04d60038fbf5b617ee76bb59216ff4038d4 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 17:20:23 +0100 Subject: GRAMMAR --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 7c38a54ea6..611782b4f6 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1450,7 +1450,7 @@ a logical property of a computational object. In the same spirit, elimination on $P$ of type $I\ra \Type$ cannot be allowed because it trivially implies the elimination on $P$ of type $I\ra \Set$ by cumulativity. It also implies that there -is two proofs of the same property which are provably different, +are two proofs of the same property which are provably different, contradicting the proof-irrelevance property which is sometimes a useful axiom: \begin{coq_example} -- cgit v1.2.3 From c3973cc972cd1474fb4bad308197d64634a518dc Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 17:23:45 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 611782b4f6..9e11d66ab5 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1464,6 +1464,7 @@ predicate $P$ of type $I\ra \Type$ leads to a paradox when applied to impredicative inductive definition like the second-order existential quantifier \texttt{exProp} defined above, because it give access to the two projections on this type. +% QUESTION: I did not get the point of the paragraph above. %\paragraph{Warning: strong elimination} %\index{Elimination!Strong elimination} -- cgit v1.2.3 From 0e7a91379a49be9874ce1669f3058fa0ae1194bb Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 5 Nov 2015 19:33:33 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 9e11d66ab5..6cd84cfc6e 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1396,6 +1396,10 @@ $I$. \end{description} % QUESTION: What kind of value is represented by "x" in the "numerator"? % There, "x" is unbound. Isn't it? +% The rule does not fully justify the following (plausible) argument: +% +% http://matej-kosik.github.io/www/doc/coq/notes/26__allowed_elimination_sorts.html +% % NOTE: Above, "Set" is subsumed in "Type(0)" so, strictly speaking, we wouldn't need to mention in explicitely. The case of Inductive definitions of sort \Prop{} is a bit more -- cgit v1.2.3 From c372f60433da664431a394153eaf8dbcd6f15f07 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 11:38:51 +0100 Subject: CLEANUP: removing a superfluous index --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 6cd84cfc6e..23d86cbbc1 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1524,7 +1524,7 @@ We define a new type \CI{c:C}{P} which represents the type of the branch corresponding to the $c:C$ constructor. \[ \begin{array}{ll} -\CI{c:(I_i~p_1\ldots p_r\ t_1 \ldots t_p)}{P} &\equiv (P~t_1\ldots ~t_p~c) \\[2mm] +\CI{c:(I~p_1\ldots p_r\ t_1 \ldots t_p)}{P} &\equiv (P~t_1\ldots ~t_p~c) \\[2mm] \CI{c:\forall~x:T,C}{P} &\equiv \forall~x:T,\CI{(c~x):C}{P} \end{array} \] -- cgit v1.2.3 From 4ac0855b28c2e266f4fe2646a00754d907c3e6b3 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 13:20:17 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 53 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 23d86cbbc1..db80d79109 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1514,6 +1514,59 @@ Extraction eq_rec. An empty definition has no constructors, in that case also, elimination on any sort is allowed. +% QUESTION: +% +% In Coq, this works: +% +% Check match 42 as x return match x with +% | O => nat +% | _ => bool +% end +% with +% | O => 42 +% | _ => true +% end. +% +% Also this works: +% +% Check let foo := 42 in +% match foo return match foo with +% | O => nat +% | _ => bool +% end +% with +% | O => 42 +% | _ => true +% end. +% +% But here: +% +% Definition foo := 42. +% Check match foo return match foo with +% | O => nat +% | _ => bool +% end +% with +% | O => 42 +% | _ => true +% end. +% +% Coq complains: +% +% Error: +% The term "42" has type "nat" while it is expected to have type +% "match foo with +% | 0 => nat +% | S _ => bool +% end". +% +% However, the Reference Manual says that: +% +% "Remark that when the term being matched is a variable, the as clause can +% be omitted and the term being matched can serve itself as binding name in the return type." +% +% so I do not understand why, in this case, Coq produces a given error message. + \paragraph{Type of branches.} Let $c$ be a term of type $C$, we assume $C$ is a type of constructor for an inductive definition $I$. Let $P$ be a term that represents the -- cgit v1.2.3 From 8efc7854332a3376a0e7ec348545cff83829a70e Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 14:36:38 +0100 Subject: CLEANUP: We decided to call these guys E[Γ] ⊢ (Γi := Γc) as inductive definition. --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index db80d79109..1cb0a7318e 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1622,7 +1622,7 @@ following typing rule (\WTEG{f_i}{\CI{(c_{p_i}~q_1\ldots q_r)}{P}})_{i=1\ldots l}} {\WTEG{\Case{P}{c}{f_1|\ldots |f_l}}{(P\ t_1\ldots t_s\ c)}}}%\\[3mm] -provided $I$ is an inductive type in a declaration +provided $I$ is an inductive type in a definition \Ind{}{r}{\Gamma_I}{\Gamma_C} with $\Gamma_C = [c_1:C_1;\ldots;c_n:C_n]$ and $c_{p_1}\ldots c_{p_l}$ are the only constructors of $I$. -- cgit v1.2.3 From 38fc8566ab59bcf67e6eeaf5860ce97cfab38e74 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 15:09:34 +0100 Subject: CLEANUP PROPOSITION: does it make sense to refer to 'I' as 'inductive definition'? Doesn't make more sense to refer to it as 'inductive type'? --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 1cb0a7318e..87ef046fa4 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1569,7 +1569,7 @@ elimination on any sort is allowed. \paragraph{Type of branches.} Let $c$ be a term of type $C$, we assume $C$ is a type of constructor -for an inductive definition $I$. Let $P$ be a term that represents the +for an inductive type $I$. Let $P$ be a term that represents the property to be proved. We assume $r$ is the number of parameters. -- cgit v1.2.3 From f7051cd4eb4cefc4b2ec04c8c29369dcaf0062f2 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 15:18:35 +0100 Subject: ENH: define the meaning of 'p' --- doc/refman/RefMan-cic.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 87ef046fa4..91c1418546 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1571,7 +1571,7 @@ elimination on any sort is allowed. Let $c$ be a term of type $C$, we assume $C$ is a type of constructor for an inductive type $I$. Let $P$ be a term that represents the property to be proved. -We assume $r$ is the number of parameters. +We assume $r$ is the number of parameters and $p$ is the number of arguments. We define a new type \CI{c:C}{P} which represents the type of the branch corresponding to the $c:C$ constructor. @@ -1584,7 +1584,7 @@ branch corresponding to the $c:C$ constructor. We write \CI{c}{P} for \CI{c:C}{P} with $C$ the type of $c$. \paragraph{Examples.} -For $\ListA$ the type of $P$ will be $\ListA\ra s$ for $s \in \Sort$. \\ +For $\List \nat$ the type of $P$ will be $\ListA\ra s$ for $s \in \Sort$. \\ $ \CI{(\cons~A)}{P} \equiv \forall a:A, \forall l:\ListA,(P~(\cons~A~a~l))$. -- cgit v1.2.3 From 56abd3ce281e3fd8f3df27597c6348d6ab033b64 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 16:58:22 +0100 Subject: ENH: existing example was expanded --- doc/refman/RefMan-cic.tex | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 91c1418546..d2bae76f61 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1584,9 +1584,12 @@ branch corresponding to the $c:C$ constructor. We write \CI{c}{P} for \CI{c:C}{P} with $C$ the type of $c$. \paragraph{Examples.} -For $\List \nat$ the type of $P$ will be $\ListA\ra s$ for $s \in \Sort$. \\ -$ \CI{(\cons~A)}{P} \equiv -\forall a:A, \forall l:\ListA,(P~(\cons~A~a~l))$. +For $\List~\nat$ the type of $P$ will be $\List~\nat\ra s$ for $s \in \Sort$. \\ +$ \CI{(\cons~\nat)}{P} + \equiv\CI{(\cons~\nat) : (\nat\ra\List~\nat\ra\List~\nat)}{P} \equiv\\ + \equiv\forall n:\nat, \CI{(\cons~\nat~n) : \List~\nat\ra\List~\nat)}{P} \equiv\\ + \equiv\forall n:\nat, \forall l:\List~\nat, \CI{(\cons~\nat~n~l) : \List~\nat)}{P} \equiv\\ +\equiv\forall n:\nat, \forall l:\List~\nat,(P~(\cons~\nat~n~l))$. For $\haslengthA$, the type of $P$ will be $\forall l:\ListA,\forall n:\nat, (\haslengthA~l~n)\ra \Prop$ and the expression -- cgit v1.2.3 From a388d599ba461cf35b40c3850d593f5e9bb71d3d Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 16:58:44 +0100 Subject: CLEANUP: Existing example was removed. We have expanded the example above. For consistency reasons, it would make sense to do the same also for this example. However, due to the size of the terms, it is hard to typeset it nicely. I propose to remove it. --- doc/refman/RefMan-cic.tex | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index d2bae76f61..87d6f1d28e 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1591,16 +1591,6 @@ $ \CI{(\cons~\nat)}{P} \equiv\forall n:\nat, \forall l:\List~\nat, \CI{(\cons~\nat~n~l) : \List~\nat)}{P} \equiv\\ \equiv\forall n:\nat, \forall l:\List~\nat,(P~(\cons~\nat~n~l))$. -For $\haslengthA$, the type of $P$ will be -$\forall l:\ListA,\forall n:\nat, (\haslengthA~l~n)\ra \Prop$ and the expression -\CI{(\conshl~A)}{P} is defined as:\\ -$\forall a:A, \forall l:\ListA, \forall n:\nat, \forall -h:(\haslengthA~l~n), (P~(\cons~A~a~l)~(\nS~n)~(\conshl~A~a~l~n~l))$.\\ -If $P$ does not depend on its third argument, we find the more natural -expression:\\ -$\forall a:A, \forall l:\ListA, \forall n:\nat, -(\haslengthA~l~n)\ra(P~(\cons~A~a~l)~(\nS~n))$. - \paragraph{Typing rule.} Our very general destructor for inductive definition enjoys the -- cgit v1.2.3 From 59b4ea72a6896e05c4b6094b10b9a294b0322e53 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 18:55:49 +0100 Subject: ENH: an existing example was further expanded. --- doc/refman/RefMan-cic.tex | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 87d6f1d28e..edf7840fdd 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1583,13 +1583,42 @@ branch corresponding to the $c:C$ constructor. \] We write \CI{c}{P} for \CI{c:C}{P} with $C$ the type of $c$. -\paragraph{Examples.} -For $\List~\nat$ the type of $P$ will be $\List~\nat\ra s$ for $s \in \Sort$. \\ +\paragraph{Example.} +The following term in concrete syntax: +\begin{verbatim} +match t as l return P' with +| nil _ => t1 +| cons _ hd tl => t2 +end +\end{verbatim} +can be represented in abstract syntax as $$\Case{P}{t}{f_1\,|\,f_2}$$ +where +\begin{eqnarray*} + P & = & \lambda~l~.~P^\prime\\ + f_1 & = & t_1\\ + f_2 & = & \lambda~(hd:\nat)~.~\lambda~(tl:\List~\nat)~.~t_2 +\end{eqnarray*} +According to the definition: +\begin{latexonly}\vskip.5em\noindent\end{latexonly}% +\begin{htmlonly} + +\end{htmlonly} +$ \CI{(\Nil~\nat)}{P} \equiv \CI{(\Nil~\nat) : (\List~\nat)}{P} \equiv (P~(\Nil~\nat))$ +\begin{latexonly}\vskip.5em\noindent\end{latexonly}% +\begin{htmlonly} + +\end{htmlonly} $ \CI{(\cons~\nat)}{P} \equiv\CI{(\cons~\nat) : (\nat\ra\List~\nat\ra\List~\nat)}{P} \equiv\\ \equiv\forall n:\nat, \CI{(\cons~\nat~n) : \List~\nat\ra\List~\nat)}{P} \equiv\\ \equiv\forall n:\nat, \forall l:\List~\nat, \CI{(\cons~\nat~n~l) : \List~\nat)}{P} \equiv\\ \equiv\forall n:\nat, \forall l:\List~\nat,(P~(\cons~\nat~n~l))$. +\begin{latexonly}\vskip.5em\noindent\end{latexonly}% +\begin{htmlonly} + +\end{htmlonly} +Given some $P$, then \CI{(\Nil~\nat)}{P} represents the expected type of $f_1$, and +\CI{(\cons~\nat)}{P} represents the expected type of $f_2$. \paragraph{Typing rule.} -- cgit v1.2.3 From 793a5842cf7adeff60c380738a7d4bd3430e926a Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 19:49:05 +0100 Subject: ENH: existing example was changed so that it is now linked to the results shown in the previous example --- doc/refman/RefMan-cic.tex | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index edf7840fdd..d512df3b78 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1651,13 +1651,17 @@ only constructors of $I$. \end{description} \paragraph{Example.} -For \List\ and \haslength\ the typing rules for the {\tt match} expression -are (writing just $t:M$ instead of \WTEG{t}{M}, the global environment and -local context being the same in all the judgments). -\[\frac{l:\ListA~~P:\ListA\ra s~~~f_1:(P~(\Nil~A))~~ - f_2:\forall a:A, \forall l:\ListA, (P~(\cons~A~a~l))} - {\Case{P}{l}{f_1~|~f_2}:(P~l)}\] +Below is a typing rule for the term shown in the previous example: +\inference{ + \frac{% + \WTEG{t}{(\List~\nat)}~~~~% + \WTEG{P}{B}~~~~% + \compat{(\List~\nat)}{B}~~~~% + \WTEG{f_1}{\CI{(\Nil~\nat)}{P}}~~~~% + \WTEG{f_2}{\CI{(\cons~\nat)}{P}}% + } +{\WTEG{\Case{P}{t}{f_1|f_2}}{(P~t)}}} \[\frac{ \begin{array}[b]{@{}c@{}} -- cgit v1.2.3 From 07b9d5bc3c54e849b95f2b8dd223896e64614954 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 6 Nov 2015 19:50:08 +0100 Subject: CLEANUP PROPOSITION: existing example was removed because it is not urgently needed --- doc/refman/RefMan-cic.tex | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index d512df3b78..e5307ef1ec 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1663,16 +1663,6 @@ Below is a typing rule for the term shown in the previous example: } {\WTEG{\Case{P}{t}{f_1|f_2}}{(P~t)}}} -\[\frac{ - \begin{array}[b]{@{}c@{}} -H:(\haslengthA~L~N) \\ P:\forall l:\ListA, \forall n:\nat, (\haslengthA~l~n)\ra - \Prop\\ - f_1:(P~(\Nil~A)~\nO~\nilhl) \\ - f_2:\forall a:A, \forall l:\ListA, \forall n:\nat, \forall - h:(\haslengthA~l~n), (P~(\cons~A~a~n)~(\nS~n)~(\conshl~A~a~l~n~h)) - \end{array}} - {\Case{P}{H}{f_1~|~f_2}:(P~L~N~H)}\] - \paragraph[Definition of $\iota$-reduction.]{Definition of $\iota$-reduction.\label{iotared} \index{iota-reduction@$\iota$-reduction}} We still have to define the $\iota$-reduction in the general case. -- cgit v1.2.3 From 43816ce712054c07cb04452821570054aff3dc44 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 15:37:39 +0100 Subject: CLEANUP PROPOSITION: rephrasing the original idea in a simpler way --- doc/refman/RefMan-cic.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index e5307ef1ec..2a4ccfed87 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -242,7 +242,7 @@ either $x:T$ is an assumption in $\Gamma$ or that there exists some $t$ such that $x:=t:T$ is a definition in $\Gamma$. If $\Gamma$ defines some $x:=t:T$, we also write $(x:=t:T) \in \Gamma$. For the rest of the chapter, the -notation $\Gamma::(y:T)$ (resp. $\Gamma::(y:=t:T)$) denotes the local context +notation $\Gamma::(y:T)$ (resp.\ $\Gamma::(y:=t:T)$) denotes the local context $\Gamma$ enriched with the declaration $y:T$ (resp. $y:=t:T$). The notation $[]$ denotes the empty local context. @@ -1708,7 +1708,7 @@ The typing rule is the expected one for a fixpoint. \end{description} Any fixpoint definition cannot be accepted because non-normalizing terms -will lead to proofs of absurdity. +allow proofs of absurdity. The basic scheme of recursion that should be allowed is the one needed for defining primitive -- cgit v1.2.3 From 33c0d3b95bdf0ff1fdd2d6dbe7088e48c2fa6f67 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 16:01:27 +0100 Subject: GRAMMAR: added punctuation --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2a4ccfed87..092dba46b4 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1738,7 +1738,7 @@ The first stage is to precise on which argument the fixpoint will be decreasing. The type of this argument should be an inductive definition. -For doing this the syntax of fixpoints is extended and becomes +For doing this, the syntax of fixpoints is extended and becomes \[\Fix{f_i}{f_1/k_1:A_1:=t_1 \ldots f_n/k_n:A_n:=t_n}\] where $k_i$ are positive integers. Each $A_i$ should be a type (reducible to a term) starting with at least -- cgit v1.2.3 From 2cb48a3fe5a8cd435e4e0ad6990e5ee5e6079fa5 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 16:17:44 +0100 Subject: COMMENT: to do --- doc/refman/RefMan-cic.tex | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 092dba46b4..3d56dcac60 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1745,6 +1745,8 @@ Each $A_i$ should be a type (reducible to a term) starting with at least $k_i$ products $\forall y_1:B_1,\ldots \forall y_{k_i}:B_{k_i}, A'_i$ and $B_{k_i}$ being an instance of an inductive definition. +% TODO: We should probably define somewhere explicitely, what we mean by +% "x is an instance of an inductive type I". Now in the definition $t_i$, if $f_j$ occurs then it should be applied to at least $k_j$ arguments and the $k_j$-th argument should be -- cgit v1.2.3 From fc8e19c82a24fea551b47a99bb68f6f64fc16a01 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 17:30:07 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 3d56dcac60..8c8537cfb2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1747,6 +1747,8 @@ and $B_{k_i}$ being an instance of an inductive definition. % TODO: We should probably define somewhere explicitely, what we mean by % "x is an instance of an inductive type I". +% +% QUESTION: So, $k_i$ is the index of the argument on which $f_i$ is decreasing? Now in the definition $t_i$, if $f_j$ occurs then it should be applied to at least $k_j$ arguments and the $k_j$-th argument should be -- cgit v1.2.3 From 02be0f4e071c12800177eecdb067949dcce3b174 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 18:06:41 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 8c8537cfb2..1a17f3f35f 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1764,7 +1764,9 @@ $\forall p_1:P_1,\ldots \forall p_r:P_r, \forall x_1:T_1, \ldots \forall x_r:T_r, (I_j~p_1\ldots p_r~t_1\ldots t_s)$ the recursive arguments will correspond to $T_i$ in which one of the $I_l$ occurs. - +% QUESTION: The last sentence above really fully make sense. +% Isn't some word missing? +% Maybe "if"? The main rules for being structurally smaller are the following:\\ Given a variable $y$ of type an inductive -- cgit v1.2.3 From 0f97c5d4429e1f191b89125caa1ed652b0f19c79 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 18:08:01 +0100 Subject: TYPOGRAPHY --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 1a17f3f35f..66111fa708 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1776,7 +1776,7 @@ where $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is $[c_1:C_1;\ldots;c_n:C_n]$. The terms structurally smaller than $y$ are: \begin{itemize} -\item $(t~u), \lb x:u \mto t$ when $t$ is structurally smaller than $y$ . +\item $(t~u)$ and $\lb x:u \mto t$ when $t$ is structurally smaller than $y$. \item \Case{P}{c}{f_1\ldots f_n} when each $f_i$ is structurally smaller than $y$. \\ If $c$ is $y$ or is structurally smaller than $y$, its type is an inductive -- cgit v1.2.3 From cbdceb06359e10a4cad7f9ec5a505d0afcd76677 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 18:22:59 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 66111fa708..3cb0b95700 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1782,6 +1782,7 @@ The terms structurally smaller than $y$ are: If $c$ is $y$ or is structurally smaller than $y$, its type is an inductive definition $I_p$ part of the inductive declaration corresponding to $y$. + % QUESTION: What does the above sentence mean? Each $f_i$ corresponds to a type of constructor $C_q \equiv \forall p_1:P_1,\ldots,\forall p_r:P_r, \forall y_1:B_1, \ldots \forall y_k:B_k, (I~a_1\ldots a_k)$ and can consequently be -- cgit v1.2.3 From 6d5a8e69517276d1d13275533aee9fceb42b9d13 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 18:26:59 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 3cb0b95700..736affe940 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1792,6 +1792,9 @@ The terms structurally smaller than $y$ are: in $g_i$ corresponding to recursive arguments $B_i$ (the ones in which one of the $I_l$ occurs) are structurally smaller than $y$. \end{itemize} +% QUESTION: How could one show, that some of the functions defined below are "guarded" +% in a sense of the definition given above. +% E.g., how could I show that "p" in "plus" below is structurally smaller than "n"? The following definitions are correct, we enter them using the {\tt Fixpoint} command as described in Section~\ref{Fixpoint} and show the internal representation. -- cgit v1.2.3 From 55fe005b2141a69ffd9589568f8b854075174d56 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 18:49:37 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 736affe940..29e4f256bb 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1858,6 +1858,7 @@ reflexivity. \begin{coq_eval} Abort. \end{coq_eval} +% QUESTION: What are we trying to say with the above examples? % La disparition de Program devrait rendre la construction Match obsolete % \subsubsection{The {\tt Match \ldots with \ldots end} expression} -- cgit v1.2.3 From 796c433f5da19511ddc5de3d2cbec878ac3d25fc Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Sat, 7 Nov 2015 23:59:30 +0100 Subject: COMMENT: question --- doc/refman/RefMan-cic.tex | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 29e4f256bb..39b7d4f156 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1828,6 +1828,7 @@ The reduction for fixpoints is: \[ (\Fix{f_i}{F}~a_1\ldots a_{k_i}) \triangleright_{\iota} \substs{t_i}{f_k}{\Fix{f_k}{F}}{k=1\ldots n} ~a_1\ldots a_{k_i}\] +% QUESTION: Is it wise to use \iota for twice with two different meanings? when $a_{k_i}$ starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction for primitive recursive operators. -- cgit v1.2.3 From 67d0db55d55dd2c650a33f11794e8a6747fc518b Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 9 Nov 2015 16:33:12 +0100 Subject: DONE --- doc/refman/RefMan-cic.tex | 216 ++++------------------------------------------ 1 file changed, 16 insertions(+), 200 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 39b7d4f156..2f4016d71e 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -63,11 +63,6 @@ Their properties, such as: {\Prop:\Type$(1)$}, {\Set:\Type$(1)$}, and {\Type$(i)$:\Type$(i+1)$}, are defined in Section~\ref{subtyping-rules}. -% TODO: Somewhere in the document we should explain: -% - what concrete actions (in *.v files) cause creation of new universes -% - different kinds of relationships between universes (i.e. "max" and "succ") -% - what are all the actions (in *.v files) from which those relationships arise - The user does not have to mention explicitly the index $i$ when referring to the universe \Type$(i)$. One only writes \Type. The system itself generates for each instance of \Type\ a new @@ -94,17 +89,6 @@ constraints must remain acyclic. Typing expressions that violate the acyclicity of the graph of constraints results in a \errindex{Universe inconsistency} error (see also Section~\ref{PrintingUniverses}). -% TODO: The concept of 'universe inconsistency' deserves more attention. -% Somewhere in the document we should: -% - give concrete examples when universe inconsistency arises -% - explain why it arised -% - how can a user identify the "vicious cycle". - -% QUESTION: Is the presentation of universes as totally ordered a necessary or advantageous step? - -% QUESTION: Shouldn't the explanation of universes in this chapter -% be consolidatd with Chapter 29: Polymorphic Universes? - %% HH: This looks to me more like source of confusion than helpful %% \subsection{Constants} @@ -184,7 +168,6 @@ More precisely the language of the {\em Calculus of Inductive The notion of free variables is defined as usual. In the expressions $\lb x:T\mto U$ and $\forall x:T, U$ the occurrences of $x$ in $U$ are bound. -% TODO: what is the best play to say that "terms are considered equal up to α-conversion"? \paragraph[Substitution.]{Substitution.\index{Substitution}} The notion of substituting a term $t$ to free occurrences of a @@ -241,10 +224,11 @@ we write $x \in \Gamma$. By writing $(x:T) \in \Gamma$ we mean that either $x:T$ is an assumption in $\Gamma$ or that there exists some $t$ such that $x:=t:T$ is a definition in $\Gamma$. If $\Gamma$ defines some $x:=t:T$, we also write $(x:=t:T) \in \Gamma$. -For the rest of the chapter, the -notation $\Gamma::(y:T)$ (resp.\ $\Gamma::(y:=t:T)$) denotes the local context -$\Gamma$ enriched with the declaration $y:T$ (resp. $y:=t:T$). The -notation $[]$ denotes the empty local context. +For the rest of the chapter, the $\Gamma::(y:T)$ denotes the local context +$\Gamma$ enriched with the local assumption $y:T$. +Similarly, $\Gamma::(y:=t:T)$ denotes the local context +$\Gamma$ enriched with the local definition $(y:=t:T)$. +The notation $[]$ denotes the empty local context. % Does not seem to be used further... % Si dans l'explication WF(E)[Gamma] concernant les constantes @@ -305,23 +289,16 @@ local context $\Gamma$ and a term $T$ such that the judgment \WTEG{t}{T} can be derived from the following rules. \begin{description} \item[W-Empty] \inference{\WF{[]}{}} -% QUESTION: Why in W-Local-Assum and W-Local-Def we do not need x ∉ E hypothesis? \item[W-Local-Assum] % Ce n'est pas vrai : x peut apparaitre plusieurs fois dans Gamma \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~x \not\in \Gamma % \cup E }{\WFE{\Gamma::(x:T)}}} \item[W-Local-Def] \inference{\frac{\WTEG{t}{T}~~~~x \not\in \Gamma % \cup E }{\WFE{\Gamma::(x:=t:T)}}} -% QUESTION: Why in W-Global-Assum and W-Global-Def we do not need x ∉ Γ hypothesis? \item[W-Global-Assum] \inference{\frac{\WTE{}{T}{s}~~~~s \in \Sort~~~~c \notin E} {\WF{E;c:T}{}}} \item[W-Global-Def] \inference{\frac{\WTE{}{t}{T}~~~c \notin E} {\WF{E;c:=t:T}{}}} -% QUESTION: Why, in case of W-Local-Assum and W-Global-Assum we need s ∈ S hypothesis. -% QUESTION: At the moment, enrichment of a local context is denoted with ∷ -% whereas enrichment of the global environment is denoted with ; -% Is it necessary to use two different notations? -% Couldn't we use ∷ also for enrichment of the global context? \item[Ax-Prop] \index{Typing rules!Ax-Prop} \inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(1)}}} \item[Ax-Set] \index{Typing rules!Ax-Set} @@ -366,7 +343,6 @@ difference between {\Prop} and {\Set}: well-typed without having $((\lb x:T\mto u)~t)$ well-typed (where $T$ is a type of $t$). This is because the value $t$ associated to $x$ may be used in a conversion rule (see Section~\ref{conv-rules}). -% QUESTION: I do not understand. How would that be possible? \section[Conversion rules]{Conversion rules\index{Conversion rules} \label{conv-rules}} @@ -815,7 +791,6 @@ $\begin{array}{@{} l} \subsection{Well-formed inductive definitions} We cannot accept any inductive declaration because some of them lead to inconsistent systems. -% TODO: The statement above deserves explanation. We restrict ourselves to definitions which satisfy a syntactic criterion of positivity. Before giving the formal rules, we need a few definitions: @@ -843,9 +818,6 @@ in one of the following two cases: \item $T$ is $(I~t_1\ldots ~t_n)$ \item $T$ is $\forall x:U,T^\prime$ where $T^\prime$ is also a type of constructor of $I$ \end{itemize} -% QUESTION: Are we above sufficiently precise? -% Shouldn't we say also what is "n"? -% "n" couldn't be "0", could it? \paragraph[Examples]{Examples} $\nat$ and $\nat\ra\nat$ are types of constructors of $\nat$.\\ @@ -854,11 +826,9 @@ $\forall A:\Type,\List~A$ and $\forall A:\Type,A\ra\List~A\ra\List~A$ are constr \paragraph[Definition]{Definition\index{Positivity}\label{Positivity}} The type of constructor $T$ will be said to {\em satisfy the positivity condition} for a constant $X$ in the following cases: -% QUESTION: Why is this property called "positivity"? \begin{itemize} \item $T=(X~t_1\ldots ~t_n)$ and $X$ does not occur free in -% QUESTIONS: What is the meaning of 'n' above? any $t_i$ \item $T=\forall~x:U,V$ and $X$ occurs only strictly positively in $U$ and the type $V$ satisfies the positivity condition for $X$ @@ -870,12 +840,10 @@ following cases: \begin{itemize} \item $X$ does not occur in $T$ \item $T$ converts to $(X~t_1 \ldots ~t_n)$ and $X$ does not occur in -% QUESTIONS: What is the meaning of 'n' above? any of $t_i$ \item $T$ converts to $\forall~x:U,V$ and $X$ does not occur in type $U$ but occurs strictly positively in type $V$ \item $T$ converts to $(I~a_1 \ldots ~a_m ~ t_1 \ldots ~t_p)$ where -% QUESTIONS: What is the meaning of 'p' above? $I$ is the name of an inductive declaration of the form $\Ind{\Gamma}{m}{I:A}{c_1:\forall p_1:P_1,\ldots \forall p_m:P_m,C_1;\ldots;c_n:\forall p_1:P_1,\ldots \forall @@ -898,7 +866,6 @@ cases: \item $T=(I~b_1\ldots b_m~u_1\ldots ~u_{p})$, $I$ is an inductive definition with $m$ parameters and $X$ does not occur in any $u_i$ -% QUESTIONS: What is the meaning of 'p' above? \item $T=\forall~x:U,V$ and $X$ occurs only strictly positively in $U$ and the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} @@ -969,10 +936,6 @@ the type $V$ satisfies the nested positivity condition for $X$ \end{latexonly} \paragraph{Correctness rules.} -% QUESTION: For a related problem, in case of global definitions -% and global assumptions, we used the term "well-formedness". -% Couldn't we continue to use the term also here? -% Does it make sense to use a different name, i.e. "correctness" in this case? We shall now describe the rules allowing the introduction of a new inductive definition. @@ -999,7 +962,6 @@ provided that the following side conditions hold: $I_{q_i}$ which satisfies the positivity condition for $I_1 \ldots I_k$ and $c_i \notin \Gamma \cup E$. \end{itemize} -% TODO: justify the above constraints \end{description} One can remark that there is a constraint between the sort of the arity of the inductive type and the sort of the type of its @@ -1007,7 +969,6 @@ constructors which will always be satisfied for the impredicative sort {\Prop} but may fail to define inductive definition on sort \Set{} and generate constraints between universes for inductive definitions in the {\Type} hierarchy. -% QUESTION: which 'constraint' are we above referring to? \paragraph{Examples.} It is well known that existential quantifier can be encoded as an @@ -1025,7 +986,6 @@ The same definition on \Set{} is not allowed and fails: Fail Inductive exSet (P:Set->Prop) : Set := exS_intro : forall X:Set, P X -> exSet P. \end{coq_example} -% TODO: add the description of the 'Fail' command to the reference manual It is possible to declare the same inductive definition in the universe \Type. The \texttt{exType} inductive definition has type $(\Type_i \ra\Prop)\ra @@ -1044,7 +1004,6 @@ Inductive exType (P:Type->Prop) : Type Inductive types declared in {\Type} are polymorphic over their arguments in {\Type}. -% QUESTION: Just arguments? Not also over the parameters? If $A$ is an arity of some sort and $s$ is a sort, we write $A_{/s}$ for the arity obtained from $A$ by replacing its sort with $s$. Especially, if $A$ @@ -1093,13 +1052,10 @@ $P_l$ arity implies $P'_l$ arity since $\WTELECONV{}{P'_l}{ \subst{P_l}{p_u}{q_u \Gamma_{P'},(A_1)_{/s_1};\ldots;I_k:\forall \Gamma_{P'},(A_k)_{/s_k}]$ we have $(\WTE{\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; \item the sorts are such that all eliminations, to {\Prop}, {\Set} and - $\Type(j)$, are allowed (see section~\ref{elimdep}). -% QUESTION: How should I interpret the above side-condition, when I am trying to show that 'list nat : Set'? + $\Type(j)$, are allowed (see Section~\ref{allowedeleminationofsorts}). \end{itemize} \end{description} -% QUESTION: Do we need the following paragraph? -% (I find it confusing.) Notice that if $I_j\,q_1\,\ldots\,q_r$ is typable using the rules {\bf Ind-Const} and {\bf App}, then it is typable using the rule {\bf Ind-Family}. Conversely, the extended theory is not stronger than the @@ -1142,7 +1098,6 @@ singleton -- see paragraph~\ref{singleton}) is set in {\Prop}, a small non-singleton inductive type is set in {\Set} (even in case {\Set} is impredicative -- see Section~\ref{impredicativity}), and otherwise in the {\Type} hierarchy. -% TODO: clarify the case of a partial application ?? Note that the side-condition about allowed elimination sorts in the rule~{\bf Ind-Family} is just to avoid to recompute the allowed @@ -1208,8 +1163,6 @@ Because we need to keep a consistent theory and also we prefer to keep a strongly normalizing reduction, we cannot accept any sort of recursion (even terminating). So the basic idea is to restrict ourselves to primitive recursive functions and functionals. -% TODO: it may be worthwhile to show the consequences of lifting -% those restrictions. For instance, assuming a parameter $A:\Set$ exists in the local context, we want to build a function \length\ of type $\ListA\ra \nat$ which @@ -1246,11 +1199,6 @@ same as proving: $(\haslengthA~(\Nil~A)~\nO)$ and $\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra (\haslengthA~(\cons~A~a~l)~(\nS~(\length~l)))$. -% QUESTION: Wouldn't something like: -% -% http://matej-kosik.github.io/www/doc/coq/notes/25__has_length.html -% -% be more comprehensible? One conceptually simple way to do that, following the basic scheme proposed by Martin-L\"of in his Intuitionistic Type Theory, is to @@ -1263,11 +1211,6 @@ But this operator is rather tedious to implement and use. We choose in this version of {\Coq} to factorize the operator for primitive recursion into two more primitive operations as was first suggested by Th. Coquand in~\cite{Coq92}. One is the definition by pattern-matching. The second one is a definition by guarded fixpoints. -% QUESTION: Shouldn't we, instead, include a more straightforward argument: -% -% http://matej-kosik.github.io/www/doc/coq/notes/24__match_and_fix.html -% -% ? \subsubsection[The {\tt match\ldots with \ldots end} construction.]{The {\tt match\ldots with \ldots end} construction.\label{Caseexpr} \index{match@{\tt match\ldots with\ldots end}}} @@ -1307,24 +1250,9 @@ omitted if the result type does not depend on the arguments of $I$. Note that the arguments of $I$ corresponding to parameters \emph{must} be \verb!_!, because the result type is not generalized to all possible values of the parameters. -% QUESTION: The last sentence above does not seem to be accurate. -% -% Imagine: -% -% Definition foo (A:Type) (a:A) (l : list A) := -% match l return A with -% | nil => a -% | cons _ _ _ => a -% end. -% -% There, the term in the return-clause happily refer to the parameter of 'l' -% and Coq does not protest. -% -% So I am not sure if I really understand why parameters cannot be bound -% in as-clause. The other arguments of $I$ (sometimes called indices in the literature) -% QUESTION: in which literature? +% NOTE: e.g. http://www.qatar.cmu.edu/~sacchini/papers/types08.pdf have to be variables ($a$ above) and these variables can occur in $P$. The expression after \kw{in} @@ -1364,6 +1292,7 @@ compact notation: % \mbox{\tt =>}~ \false} \paragraph[Allowed elimination sorts.]{Allowed elimination sorts.\index{Elimination sorts}} +\label{allowedeleminationofsorts} An important question for building the typing rule for \kw{match} is what can be the type of $\lb a x \mto P$ with respect to the type of the inductive @@ -1373,34 +1302,26 @@ We define now a relation \compat{I:A}{B} between an inductive definition $I$ of type $A$ and an arity $B$. This relation states that an object in the inductive definition $I$ can be eliminated for proving a property $\lb a x \mto P$ of arity $B$. -% QUESTION: Is it necessary to explain the meaning of [I:A|B] in such a complicated way? -% Couldn't we just say that: "relation [I:A|B] defines which types can we choose as 'result types' -% with respect to the type of the matched object". +% TODO: The meaning of [I:A|B] relation is not trivial, +% but I do not think that we must explain it in as complicated way as we do above. We use this concept to formulate the hypothesis of the typing rule for the match-construct. -The case of inductive definitions in sorts \Set\ or \Type{} is simple. -There is no restriction on the sort of the predicate to be -eliminated. - \paragraph{Notations.} The \compat{I:A}{B} is defined as the smallest relation satisfying the following rules: We write \compat{I}{B} for \compat{I:A}{B} where $A$ is the type of $I$. +The case of inductive definitions in sorts \Set\ or \Type{} is simple. +There is no restriction on the sort of the predicate to be +eliminated. + \begin{description} \item[Prod] \inference{\frac{\compat{(I~x):A'}{B'}} {\compat{I:\forall x:A, A'}{\forall x:A, B'}}} \item[{\Set} \& \Type] \inference{\frac{ s_1 \in \{\Set,\Type(j)\}~~~~~~~~s_2 \in \Sort}{\compat{I:s_1}{I\ra s_2}}} \end{description} -% QUESTION: What kind of value is represented by "x" in the "numerator"? -% There, "x" is unbound. Isn't it? -% The rule does not fully justify the following (plausible) argument: -% -% http://matej-kosik.github.io/www/doc/coq/notes/26__allowed_elimination_sorts.html -% -% NOTE: Above, "Set" is subsumed in "Type(0)" so, strictly speaking, we wouldn't need to mention in explicitely. The case of Inductive definitions of sort \Prop{} is a bit more complicated, because of our interpretation of this sort. The only @@ -1468,7 +1389,6 @@ predicate $P$ of type $I\ra \Type$ leads to a paradox when applied to impredicative inductive definition like the second-order existential quantifier \texttt{exProp} defined above, because it give access to the two projections on this type. -% QUESTION: I did not get the point of the paragraph above. %\paragraph{Warning: strong elimination} %\index{Elimination!Strong elimination} @@ -1514,59 +1434,6 @@ Extraction eq_rec. An empty definition has no constructors, in that case also, elimination on any sort is allowed. -% QUESTION: -% -% In Coq, this works: -% -% Check match 42 as x return match x with -% | O => nat -% | _ => bool -% end -% with -% | O => 42 -% | _ => true -% end. -% -% Also this works: -% -% Check let foo := 42 in -% match foo return match foo with -% | O => nat -% | _ => bool -% end -% with -% | O => 42 -% | _ => true -% end. -% -% But here: -% -% Definition foo := 42. -% Check match foo return match foo with -% | O => nat -% | _ => bool -% end -% with -% | O => 42 -% | _ => true -% end. -% -% Coq complains: -% -% Error: -% The term "42" has type "nat" while it is expected to have type -% "match foo with -% | 0 => nat -% | S _ => bool -% end". -% -% However, the Reference Manual says that: -% -% "Remark that when the term being matched is a variable, the as clause can -% be omitted and the term being matched can serve itself as binding name in the return type." -% -% so I do not understand why, in this case, Coq produces a given error message. - \paragraph{Type of branches.} Let $c$ be a term of type $C$, we assume $C$ is a type of constructor for an inductive type $I$. Let $P$ be a term that represents the @@ -1741,14 +1608,10 @@ definition. For doing this, the syntax of fixpoints is extended and becomes \[\Fix{f_i}{f_1/k_1:A_1:=t_1 \ldots f_n/k_n:A_n:=t_n}\] where $k_i$ are positive integers. +Each $k_i$ represents the index of pararameter of $f_i$, on which $f_i$ is decreasing. Each $A_i$ should be a type (reducible to a term) starting with at least $k_i$ products $\forall y_1:B_1,\ldots \forall y_{k_i}:B_{k_i}, A'_i$ -and $B_{k_i}$ -being an instance of an inductive definition. -% TODO: We should probably define somewhere explicitely, what we mean by -% "x is an instance of an inductive type I". -% -% QUESTION: So, $k_i$ is the index of the argument on which $f_i$ is decreasing? +and $B_{k_i}$ an is unductive type. Now in the definition $t_i$, if $f_j$ occurs then it should be applied to at least $k_j$ arguments and the $k_j$-th argument should be @@ -1764,9 +1627,6 @@ $\forall p_1:P_1,\ldots \forall p_r:P_r, \forall x_1:T_1, \ldots \forall x_r:T_r, (I_j~p_1\ldots p_r~t_1\ldots t_s)$ the recursive arguments will correspond to $T_i$ in which one of the $I_l$ occurs. -% QUESTION: The last sentence above really fully make sense. -% Isn't some word missing? -% Maybe "if"? The main rules for being structurally smaller are the following:\\ Given a variable $y$ of type an inductive @@ -1782,7 +1642,6 @@ The terms structurally smaller than $y$ are: If $c$ is $y$ or is structurally smaller than $y$, its type is an inductive definition $I_p$ part of the inductive declaration corresponding to $y$. - % QUESTION: What does the above sentence mean? Each $f_i$ corresponds to a type of constructor $C_q \equiv \forall p_1:P_1,\ldots,\forall p_r:P_r, \forall y_1:B_1, \ldots \forall y_k:B_k, (I~a_1\ldots a_k)$ and can consequently be @@ -1792,9 +1651,6 @@ The terms structurally smaller than $y$ are: in $g_i$ corresponding to recursive arguments $B_i$ (the ones in which one of the $I_l$ occurs) are structurally smaller than $y$. \end{itemize} -% QUESTION: How could one show, that some of the functions defined below are "guarded" -% in a sense of the definition given above. -% E.g., how could I show that "p" in "plus" below is structurally smaller than "n"? The following definitions are correct, we enter them using the {\tt Fixpoint} command as described in Section~\ref{Fixpoint} and show the internal representation. @@ -1828,7 +1684,6 @@ The reduction for fixpoints is: \[ (\Fix{f_i}{F}~a_1\ldots a_{k_i}) \triangleright_{\iota} \substs{t_i}{f_k}{\Fix{f_k}{F}}{k=1\ldots n} ~a_1\ldots a_{k_i}\] -% QUESTION: Is it wise to use \iota for twice with two different meanings? when $a_{k_i}$ starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction for primitive recursive operators. @@ -2030,45 +1885,6 @@ impredicative system for sort \Set{} become: \{\Type(i)\}} {\compat{I:\Set}{I\ra s}}} \end{description} - -% QUESTION: Why, when I add this definition: -% -% Inductive foo : Type := . -% -% Coq claims that the type of 'foo' is 'Prop'? - -% QUESTION: If I add this definition: -% -% Inductive bar (A:Type) : Type := . -% -% then Coq claims that 'bar' has type 'Type → Prop' where I would expect 'Type → Type' with appropriate constraint. - -% QUESTION: If I add this definition: -% -% Inductive foo (A:Type) : Type := -% | foo1 : foo A -% -% then Coq claims that 'foo' has type 'Type → Prop'. -% Why? - -% QUESTION: If I add this definition: -% -% Inductive foo (A:Type) : Type := -% | foo1 : foo A -% | foo2 : foo A. -% -% then Coq claims that 'foo' has type 'Type → Set'. -% Why? - -% NOTE: If I add this definition: -% -% Inductive foo (A:Type) : Type := -% | foo1 : foo A -% | foo2 : A → foo A. -% -% then Coq claims, as expected, that: -% -% foo : Type → Type. %%% Local Variables: %%% mode: latex -- cgit v1.2.3 From 15311e51c20e6edc3b97f12d483dd15bfbc1164c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 9 Nov 2015 16:43:47 +0100 Subject: PROPOSITION: Example was simplified --- doc/refman/RefMan-cic.tex | 35 ++++++++--------------------------- 1 file changed, 8 insertions(+), 27 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2f4016d71e..ac860b8276 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1688,33 +1688,14 @@ when $a_{k_i}$ starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction for primitive recursive operators. -We can illustrate this behavior on examples. -\begin{coq_example} -Goal forall n m:nat, plus (S n) m = S (plus n m). -reflexivity. -Abort. -Goal forall f:forest, sizet (node f) = S (sizef f). -reflexivity. -Abort. -\end{coq_example} -But assuming the definition of a son function from \tree\ to \forest: -\begin{coq_example} -Definition sont (t:tree) : forest - := let (f) := t in f. -\end{coq_example} -The following is not a conversion but can be proved after a case analysis. -% (******************************************************************) -% (** Error: Impossible to unify .... **) -\begin{coq_example} -Goal forall t:tree, sizet t = S (sizef (sont t)). -Fail reflexivity. -destruct t. -reflexivity. -\end{coq_example} -\begin{coq_eval} -Abort. -\end{coq_eval} -% QUESTION: What are we trying to say with the above examples? +The following reductions are now possible: +\def\plus{\mathsf{plus}} +\def\tri{\triangleright_\iota} +\begin{eqnarray*} + \plus~(\nS~(\nS~\nO))~(\nS~\nO) & \tri & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ + & \tri & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ + & \tri & \nS~(\nS~(\nS~\nO))\\ +\end{eqnarray*} % La disparition de Program devrait rendre la construction Match obsolete % \subsubsection{The {\tt Match \ldots with \ldots end} expression} -- cgit v1.2.3 From 5e48f1aafb45d1c883e32e13a8458979663b04fb Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 9 Nov 2015 16:52:23 +0100 Subject: PROPOSITION: Added "if" and "then" words missing in the original sentence. --- doc/refman/RefMan-cic.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ac860b8276..6c1417a7f2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1622,10 +1622,10 @@ The definition of being structurally smaller is a bit technical. One needs first to define the notion of {\em recursive arguments of a constructor}\index{Recursive arguments}. For an inductive definition \Ind{}{r}{\Gamma_I}{\Gamma_C}, -the type of a constructor $c$ has the form +if the type of a constructor $c$ has the form $\forall p_1:P_1,\ldots \forall p_r:P_r, \forall x_1:T_1, \ldots \forall x_r:T_r, (I_j~p_1\ldots -p_r~t_1\ldots t_s)$ the recursive arguments will correspond to $T_i$ in +p_r~t_1\ldots t_s)$, then the recursive arguments will correspond to $T_i$ in which one of the $I_l$ occurs. The main rules for being structurally smaller are the following:\\ -- cgit v1.2.3 From 32bd14114d5137b917601092730469db569d6385 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 10 Nov 2015 09:11:50 +0100 Subject: PROPOSITION: Added an explicit definition of the notation for enriching the global environment (we use throughout the document) --- doc/refman/RefMan-cic.tex | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 6c1417a7f2..2781b4cbe5 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -257,6 +257,10 @@ A {\em global definition} will be represented in the global environment as $c:=t:T$ which defines the name $c$ to have value $t$ and type $T$. We shall call such names {\em constants}. +For the rest of the chapter, the $E;c:T$ denotes the global environment +$E$ enriched with the global assumption $c:T$. +Similarly, $E;c:=t:T$ denotes the global environment +$E$ enriched with the global definition $(c:=t:T)$. The rules for inductive definitions (see Section \ref{Cic-inductive-definitions}) have to be considered as assumption -- cgit v1.2.3 From e90a1be62b9d26b1982e48d7bbd2a73b5bc54b0a Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 10 Nov 2015 13:08:20 +0100 Subject: PROPOSITION: rephrasing of the explanation of the meaning of '[I:A|B]' --- doc/refman/RefMan-cic.tex | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 2781b4cbe5..dd194d4eb9 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1299,16 +1299,12 @@ compact notation: \label{allowedeleminationofsorts} An important question for building the typing rule for \kw{match} is -what can be the type of $\lb a x \mto P$ with respect to the type of the inductive -definitions. - -We define now a relation \compat{I:A}{B} between an inductive -definition $I$ of type $A$ and an arity $B$. This relation states that -an object in the inductive definition $I$ can be eliminated for -proving a property $\lb a x \mto P$ of arity $B$. -% TODO: The meaning of [I:A|B] relation is not trivial, -% but I do not think that we must explain it in as complicated way as we do above. -We use this concept to formulate the hypothesis of the typing rule for the match-construct. +what can be the type of $\lb a x \mto P$ with respect to the type of $m$. If +$m:I$ and +$I:A$ and +$\lb a x \mto P : B$ +then by \compat{I:A}{B} we mean that one can use $\lb a x \mto P$ with $m$ in the above +match-construct. \paragraph{Notations.} The \compat{I:A}{B} is defined as the smallest relation satisfying the -- cgit v1.2.3 From 48431e5f7583f9fec3b776b07fac0f84f021a69e Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 10 Nov 2015 14:55:39 +0100 Subject: PROPOSITION: the side-condition was made more specific. --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index dd194d4eb9..dd9284e606 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1055,7 +1055,7 @@ $P_l$ arity implies $P'_l$ arity since $\WTELECONV{}{P'_l}{ \subst{P_l}{p_u}{q_u $\Gamma_{I'} = [I_1:\forall \Gamma_{P'},(A_1)_{/s_1};\ldots;I_k:\forall \Gamma_{P'},(A_k)_{/s_k}]$ we have $(\WTE{\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; -\item the sorts are such that all eliminations, to {\Prop}, {\Set} and +\item the sorts $s_i$ are such that all eliminations, to {\Prop}, {\Set} and $\Type(j)$, are allowed (see Section~\ref{allowedeleminationofsorts}). \end{itemize} \end{description} -- cgit v1.2.3 From 9959dd34dedf40c3be9a1fb1e08f04b79e0869c5 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 12 Nov 2015 11:36:00 +0100 Subject: TYPOGRAPHY: adjustments --- doc/refman/RefMan-cic.tex | 123 ++++++++++++++++++++++------------------------ 1 file changed, 58 insertions(+), 65 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index dd9284e606..dd3a059d7f 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -69,7 +69,6 @@ system itself generates for each instance of \Type\ a new index for the universe and checks that the constraints between these indexes can be solved. From the user point of view we consequently have {\Type}:{\Type}. - We shall make precise in the typing rules the constraints between the indexes. @@ -125,13 +124,11 @@ Terms are built from sorts, variables, constants, abstractions, applications, local definitions, %case analysis, fixpoints, cofixpoints and products. - From a syntactic point of view, types cannot be distinguished from terms, except that they cannot start by an abstraction or a constructor. - More precisely the language of the {\em Calculus of Inductive Constructions} is built from the following rules. - +% \begin{enumerate} \item the sorts {\Set}, {\Prop}, ${\Type(i)}$ are terms. \item variables, hereafter ranged over by letters $x$, $y$, etc., are terms @@ -414,31 +411,31 @@ $\eta$-expansion $\lb x:T\mto (t\ x)$ for $x$ an arbitrary variable name fresh in $t$. \Rem We deliberately do not define $\eta$-reduction: -\begin{latexonly} +\begin{latexonly}% $$\lb x:T\mto (t\ x)\not\triangleright_\eta\hskip.3em t$$ -\end{latexonly} +\end{latexonly}% \begin{htmlonly} $$\lb x:T\mto (t\ x)~\not\triangleright_\eta~t$$ \end{htmlonly} This is because, in general, the type of $t$ need not to be convertible to the type of $\lb x:T\mto (t\ x)$. E.g., if we take $f$ such that: -\begin{latexonly} +\begin{latexonly}% $$f\hskip.5em:\hskip.5em\forall x:Type(2),Type(1)$$ -\end{latexonly} +\end{latexonly}% \begin{htmlonly} $$f~:~\forall x:Type(2),Type(1)$$ \end{htmlonly} then -\begin{latexonly} +\begin{latexonly}% $$\lb x:Type(1),(f\, x)\hskip.5em:\hskip.5em\forall x:Type(1),Type(1)$$ -\end{latexonly} +\end{latexonly}% \begin{htmlonly} $$\lb x:Type(1),(f\, x)~:~\forall x:Type(1),Type(1)$$ \end{htmlonly} We could not allow -\begin{latexonly} +\begin{latexonly}% $$\lb x:Type(1),(f\,x)\hskip.4em\not\triangleright_\eta\hskip.6em f$$ -\end{latexonly} +\end{latexonly}% \begin{htmlonly} $$\lb x:Type(1),(f\,x)~\not\triangleright_\eta~f$$ \end{htmlonly} @@ -514,7 +511,7 @@ term is no more an abstraction leads to the {\em $\beta$-head normal where $v$ is not an abstraction (nor an application). Note that the head normal form must not be confused with the normal form since some $u_i$ can be reducible. - +% Similar notions of head-normal forms involving $\delta$, $\iota$ and $\zeta$ reductions or any combination of those can also be defined. @@ -529,14 +526,12 @@ Formally, we can represent any {\em inductive definition\index{definition!induct \item $p$ determines the number of parameters of these inductive types. \end{itemize} These inductive definitions, together with global assumptions and global definitions, then form the global environment. - -\noindent Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ +% +Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: -$\forall\Gamma_P, T^\prime$. +$\forall\Gamma_P, T^\prime$ where $\Gamma_P$ is called the {\em context of parameters\index{context of parameters}}. -\noindent $\Gamma_P$ is called {\em context of parameters\index{context of parameters}}. - -\begin{latexonly} +\begin{latexonly}% \subsection*{Examples} If we take the following inductive definition (denoted in concrete syntax): @@ -750,7 +745,7 @@ and thus it enriches the global environment with the following entry: \ind{0}{\GammaI}{\GammaC} \vskip.5em \noindent In this case, $\Gamma_P=[\,]$. -\end{latexonly} +\end{latexonly}% \subsection{Types of inductive objects} We have to give the type of constants in a global environment $E$ which @@ -763,7 +758,7 @@ contains an inductive declaration. \inference{\frac{\WFE{\Gamma}\hskip2em\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\hskip2em(c:C)\in\Gamma_C}{\WTEG{c}{C}}} \end{description} -\begin{latexonly} +\begin{latexonly}% \paragraph{Example.} Provided that our environment $E$ contains inductive definitions we showed before, these two inference rules above enable us to conclude that: @@ -776,7 +771,7 @@ $\begin{array}{@{} l} \prefix\evenS : \forall~n:\nat, \odd~n \ra \even~(\nS~n)\\ \prefix\oddS : \forall~n:\nat, \even~n \ra \odd~(\nS~n) \end{array}$ -\end{latexonly} +\end{latexonly}% %\paragraph{Parameters.} %%The parameters introduce a distortion between the inside specification @@ -837,10 +832,10 @@ any $t_i$ \item $T=\forall~x:U,V$ and $X$ occurs only strictly positively in $U$ and the type $V$ satisfies the positivity condition for $X$ \end{itemize} - +% The constant $X$ {\em occurs strictly positively} in $T$ in the following cases: - +% \begin{itemize} \item $X$ does not occur in $T$ \item $T$ converts to $(X~t_1 \ldots ~t_n)$ and $X$ does not occur in @@ -861,7 +856,7 @@ following cases: %positively in $T[x:U]u$ if $X$ does not occur in $U$ but occurs %strictly positively in $u$ \end{itemize} - +% The type of constructor $T$ of $I$ {\em satisfies the nested positivity condition} for a constant $X$ in the following cases: @@ -874,7 +869,7 @@ any $u_i$ the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} -\begin{latexonly} +\begin{latexonly}% \newcommand\vv{\textSFxi} % │ \newcommand\hh{\textSFx} % ─ \newcommand\vh{\textSFviii} % ├ @@ -937,7 +932,7 @@ the type $V$ satisfies the nested positivity condition for $X$ \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\ListA$\ruleref3\\ \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 -\end{latexonly} +\end{latexonly}% \paragraph{Correctness rules.} We shall now describe the rules allowing the introduction of a new @@ -1008,7 +1003,6 @@ Inductive exType (P:Type->Prop) : Type Inductive types declared in {\Type} are polymorphic over their arguments in {\Type}. - If $A$ is an arity of some sort and $s$ is a sort, we write $A_{/s}$ for the arity obtained from $A$ by replacing its sort with $s$. Especially, if $A$ is well-typed in some global environment and local context, then $A_{/s}$ is typable @@ -1059,7 +1053,7 @@ we have $(\WTE{\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; $\Type(j)$, are allowed (see Section~\ref{allowedeleminationofsorts}). \end{itemize} \end{description} - +% Notice that if $I_j\,q_1\,\ldots\,q_r$ is typable using the rules {\bf Ind-Const} and {\bf App}, then it is typable using the rule {\bf Ind-Family}. Conversely, the extended theory is not stronger than the @@ -1106,15 +1100,14 @@ and otherwise in the {\Type} hierarchy. Note that the side-condition about allowed elimination sorts in the rule~{\bf Ind-Family} is just to avoid to recompute the allowed elimination sorts at each instance of a pattern-matching (see -section~\ref{elimdep}). - +section~\ref{elimdep}). As an example, let us consider the following definition: \begin{coq_example*} Inductive option (A:Type) : Type := | None : option A | Some : A -> option A. \end{coq_example*} - +% As the definition is set in the {\Type} hierarchy, it is used polymorphically over its parameters whose types are arities of a sort in the {\Type} hierarchy. Here, the parameter $A$ has this property, @@ -1129,13 +1122,13 @@ section~\ref{singleton}) and it would lose the elimination to {\Set} and Check (fun A:Set => option A). Check (fun A:Prop => option A). \end{coq_example} - +% Here is another example. - +% \begin{coq_example*} Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. \end{coq_example*} - +% As \texttt{prod} is a singleton type, it will be in {\Prop} if applied twice to propositions, in {\Set} if applied twice to at least one type in {\Set} and none in {\Type}, and in {\Type} otherwise. In all cases, @@ -1186,24 +1179,25 @@ In case the inductive definition is effectively a recursive one, we want to capture the extra property that we have built the smallest fixed point of this recursive equation. This says that we are only manipulating finite objects. This analysis provides induction -principles. - +principles. For instance, in order to prove $\forall l:\ListA,(\haslengthA~l~(\length~l))$ it is enough to prove: - -\noindent $(\haslengthA~(\Nil~A)~(\length~(\Nil~A)))$ and - -\smallskip -$\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra -(\haslengthA~(\cons~A~a~l)~(\length~(\cons~A~a~l)))$. -\smallskip - -\noindent which given the conversion equalities satisfied by \length\ is the +% +\begin{itemize} + \item $(\haslengthA~(\Nil~A)~(\length~(\Nil~A)))$ + \item $\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra\\ + \ra (\haslengthA~(\cons~A~a~l)~(\length~(\cons~A~a~l)))$ +\end{itemize} +% +which given the conversion equalities satisfied by \length\ is the same as proving: -$(\haslengthA~(\Nil~A)~\nO)$ and $\forall a:A, \forall l:\ListA, -(\haslengthA~l~(\length~l)) \ra -(\haslengthA~(\cons~A~a~l)~(\nS~(\length~l)))$. - +% +\begin{itemize} + \item $(\haslengthA~(\Nil~A)~\nO)$ + \item $\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra\\ + \ra (\haslengthA~(\cons~A~a~l)~(\nS~(\length~l)))$ +\end{itemize} +% One conceptually simple way to do that, following the basic scheme proposed by Martin-L\"of in his Intuitionistic Type Theory, is to introduce for each inductive definition an elimination operator. At @@ -1223,7 +1217,6 @@ The basic idea of this operator is that we have an object $m$ in an inductive type $I$ and we want to prove a property which possibly depends on $m$. For this, it is enough to prove the property for $m = (c_i~u_1\ldots u_{p_i})$ for each constructor of $I$. - The \Coq{} term for this proof will be written: \[\kw{match}~m~\kw{with}~ (c_1~x_{11}~...~x_{1p_1}) \Ra f_1 ~|~\ldots~|~ (c_n~x_{n1}~...~x_{np_n}) \Ra f_n~ \kw{end}\] @@ -1262,7 +1255,7 @@ have to be variables The expression after \kw{in} must be seen as an \emph{inductive type pattern}. Notice that expansion of implicit arguments and notations apply to this pattern. - +% For the purpose of presenting the inference rules, we use a more compact notation: \[ \Case{(\lb a x \mto P)}{m}{ \lb x_{11}~...~x_{1p_1} \mto f_1 ~|~\ldots~|~ @@ -1315,14 +1308,14 @@ $I$. The case of inductive definitions in sorts \Set\ or \Type{} is simple. There is no restriction on the sort of the predicate to be eliminated. - +% \begin{description} \item[Prod] \inference{\frac{\compat{(I~x):A'}{B'}} {\compat{I:\forall x:A, A'}{\forall x:A, B'}}} \item[{\Set} \& \Type] \inference{\frac{ s_1 \in \{\Set,\Type(j)\}~~~~~~~~s_2 \in \Sort}{\compat{I:s_1}{I\ra s_2}}} \end{description} - +% The case of Inductive definitions of sort \Prop{} is a bit more complicated, because of our interpretation of this sort. The only harmless allowed elimination, is the one when predicate $P$ is also of @@ -1413,10 +1406,10 @@ eliminations are allowed. definition}~~~s \in \Sort}{\compat{I:\Prop}{I\ra s}} } \end{description} - +% % A {\em singleton definition} has always an informative content, % even if it is a proposition. - +% A {\em singleton definition} has only one constructor and all the arguments of this constructor have type \Prop. In that case, there is a canonical @@ -1573,17 +1566,17 @@ The typing rule is the expected one for a fixpoint. (\WTE{\Gamma,f_1:A_1,\ldots,f_n:A_n}{t_i}{A_i})_{i=1\ldots n}} {\WTEG{\Fix{f_i}{f_1:A_1:=t_1 \ldots f_n:A_n:=t_n}}{A_i}}} \end{description} - +% Any fixpoint definition cannot be accepted because non-normalizing terms allow proofs of absurdity. - +% The basic scheme of recursion that should be allowed is the one needed for defining primitive recursive functionals. In that case the fixpoint enjoys a special syntactic restriction, namely one of the arguments belongs to an inductive type, the function starts with a case analysis and recursive calls are done on variables coming from patterns and representing subterms. - +% For instance in the case of natural numbers, a proof of the induction principle of type \[\forall P:\nat\ra\Prop, (P~\nO)\ra(\forall n:\nat, (P~n)\ra(P~(\nS~n)))\ra @@ -1596,15 +1589,15 @@ can be represented by the term: p:\nat\mto (g~p~(h~p))}} \end{array} \] - +% Before accepting a fixpoint definition as being correctly typed, we check that the definition is ``guarded''. A precise analysis of this notion can be found in~\cite{Gim94}. - +% The first stage is to precise on which argument the fixpoint will be decreasing. The type of this argument should be an inductive definition. - +% For doing this, the syntax of fixpoints is extended and becomes \[\Fix{f_i}{f_1/k_1:A_1:=t_1 \ldots f_n/k_n:A_n:=t_n}\] where $k_i$ are positive integers. @@ -1687,7 +1680,7 @@ a_{k_i}) \triangleright_{\iota} \substs{t_i}{f_k}{\Fix{f_k}{F}}{k=1\ldots n} when $a_{k_i}$ starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction for primitive recursive operators. - +% The following reductions are now possible: \def\plus{\mathsf{plus}} \def\tri{\triangleright_\iota} @@ -1785,7 +1778,7 @@ $\subst{\subst{E}{y_1}{(y_1~c)}\ldots}{y_n}{(y_n~c)}$. \inference{\frac{\WF{E;c:U;E';\Ind{}{p}{\Gamma_I}{\Gamma_C};E''}{\Gamma}} {\WFTWOLINES{E;c:U;E';\Ind{}{p+1}{\forall x:U,\subst{\Gamma_I}{c}{x}}{\forall x:U,\subst{\Gamma_C}{c}{x}};\subst{E''}{|\Gamma_I,\Gamma_C|}{|\Gamma_I,\Gamma_C|~c}}{\subst{\Gamma}{|\Gamma_I,\Gamma_C|}{|\Gamma_I,\Gamma_C|~c}}}} - +% One can similarly modify a global declaration by generalizing it over a previously defined constant~$c'$. Below, if $\Gamma$ is a context of the form $[y_1:A_1;\ldots;y_n:A_n]$, we write $ @@ -1830,7 +1823,7 @@ in~\cite{Gimenez95b,Gim98,GimCas05}. \Coq{} can be used as a type-checker for the Calculus of Inductive Constructions with an impredicative sort \Set{} by using the compiler option \texttt{-impredicative-set}. - +% For example, using the ordinary \texttt{coqtop} command, the following is rejected. % (** This example should fail ******************************* -- cgit v1.2.3 From 89d033112607733ad0007638762bde326fc0eb8b Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 18 Nov 2015 16:11:27 +0100 Subject: ENH: The definition of the "_ ; _" operation on local context was added. --- doc/refman/RefMan-cic.tex | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index dd3a059d7f..4066a108cd 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -226,6 +226,8 @@ $\Gamma$ enriched with the local assumption $y:T$. Similarly, $\Gamma::(y:=t:T)$ denotes the local context $\Gamma$ enriched with the local definition $(y:=t:T)$. The notation $[]$ denotes the empty local context. +By $\Gamma_1; \Gamma_2$ we mean concatenation of the local context $\Gamma_1$ +and the local context $\Gamma_2$. % Does not seem to be used further... % Si dans l'explication WF(E)[Gamma] concernant les constantes -- cgit v1.2.3 From 6fa4d20b5208852ac468c28405e93bcb5288d774 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 23 Nov 2015 13:02:03 +0100 Subject: CLEANUP: putting examples inside "figure" environment --- doc/refman/RefMan-cic.tex | 507 ++++++++++++++++++++-------------------- doc/refman/Reference-Manual.tex | 4 + 2 files changed, 262 insertions(+), 249 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 4066a108cd..ad711549b2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -532,221 +532,221 @@ These inductive definitions, together with global assumptions and global definit Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: $\forall\Gamma_P, T^\prime$ where $\Gamma_P$ is called the {\em context of parameters\index{context of parameters}}. +Figures~\ref{fig:bool}--\ref{fig:even:odd} show formal representation of several inductive definitions. \begin{latexonly}% -\subsection*{Examples} - -If we take the following inductive definition (denoted in concrete syntax): -\begin{coq_example*} + \newpage + \def\captionstrut{\vbox to 1.5em{}} + \newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em + \begin{array}{r @{\mathrm{~:=~}} l} + #2 & #3 \\ + \end{array} + \hskip-.4em + \right)$} + + \def\colon{@{\hskip.5em:\hskip.5em}} + + \begin{figure}[H] + \strut If we take the following inductive definition (denoted in concrete syntax): +\begin{verbatim} Inductive bool : Set := | true : bool | false : bool. -\end{coq_example*} -then: -\def\colon{@{\hskip.5em:\hskip.5em}} -\newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em - \begin{array}{r @{\mathrm{~:=~}} l} - #2 & #3 \\ - \end{array} - \hskip-.4em - \right)$} - \def\GammaI{\left[\begin{array}{r \colon l} - \bool & \Set - \end{array} - \right]} - \def\GammaC{\left[\begin{array}{r \colon l} - \true & \bool\\ - \false & \bool - \end{array} - \right]} - \begin{itemize} +\end{verbatim} + then: + \def\GammaI{\left[\begin{array}{r \colon l} + \bool & \Set + \end{array} + \right]} + \def\GammaC{\left[\begin{array}{r \colon l} + \true & \bool\\ + \false & \bool + \end{array} + \right]} + \begin{itemize} \item $p = 0$ \item $\Gamma_I = \GammaI$ \item $\Gamma_C = \GammaC$ - \end{itemize} - and thus it enriches the global environment with the following entry: - \vskip.5em - \ind{p}{\Gamma_I}{\Gamma_C} - \vskip.5em - \noindent that is: - \vskip.5em - \ind{0}{\GammaI}{\GammaC} - \vskip.5em - \noindent In this case, $\Gamma_P=[\,]$. - -\vskip1em\hrule\vskip1em - -\noindent If we take the followig inductive definition: -\begin{coq_example*} + \item $\Gamma_P=[\,]$. + \end{itemize} + and thus it enriches the global environment with the following entry: + \vskip.5em + \ind{p}{\Gamma_I}{\Gamma_C} + \vskip.5em + \noindent that is: + \vskip.5em + \ind{0}{\GammaI}{\GammaC} + \caption{\captionstrut Formal representation of the {\bool} inductive type.} + \label{fig:bool} + \end{figure} + + \begin{figure}[H] + \strut If we take the followig inductive definition: +\begin{verbatim} Inductive nat : Set := | O : nat | S : nat -> nat. -\end{coq_example*} -then: -\def\GammaI{\left[\begin{array}{r \colon l} - \nat & \Set - \end{array} - \right]} -\def\GammaC{\left[\begin{array}{r \colon l} - \nO & \nat\\ - \nS & \nat\ra\nat - \end{array} - \right]} -\begin{itemize} - \item $p = 0$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ -\end{itemize} -and thus it enriches the global environment with the following entry: -\vskip.5em -\ind{p}{\Gamma_I}{\Gamma_C} -\vskip.5em -\noindent that is: -\vskip.5em -\ind{0}{\GammaI}{\GammaC} -\vskip.5em -\noindent In this case, $\Gamma_P=[~]$. - -\vskip1em\hrule\vskip1em - -\noindent If we take the following inductive definition: -\begin{coq_example*} +\end{verbatim} + then: + \def\GammaI{\left[\begin{array}{r \colon l} + \nat & \Set + \end{array} + \right]} + \def\GammaC{\left[\begin{array}{r \colon l} + \nO & \nat\\ + \nS & \nat\ra\nat + \end{array} + \right]} + \begin{itemize} + \item $p = 0$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ + \item $\Gamma_P=[\,]$. + \end{itemize} + and thus it enriches the global environment with the following entry: + \vskip.5em + \ind{p}{\Gamma_I}{\Gamma_C} + \vskip.5em + \noindent that is: + \vskip.5em + \ind{0}{\GammaI}{\GammaC} + \caption{\captionstrut Formal representation of the {\nat} inductive type.} + \label{fig:nat} + \end{figure} + + \begin{figure}[H] + \strut If we take the following inductive definition: +\begin{verbatim} Inductive list (A : Type) : Type := | nil : list A | cons : A -> list A -> list A. -\end{coq_example*} -then: -\def\GammaI{\left[\begin{array}{r \colon l} - \List & \Type\ra\Type - \end{array} - \right]} -\def\GammaC{\left[\begin{array}{r \colon l} - \Nil & \forall~A\!:\!\Type,~\List~A\\ - \cons & \forall~A\!:\!\Type,~A\ra\List~A\ra\List~A - \end{array} - \right]} -\begin{itemize} - \item $p = 1$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ -\end{itemize} -and thus it enriches the global environment with the following entry: -\vskip.5em -\ind{p}{\Gamma_I}{\Gamma_C} -\vskip.5em -\noindent that is: -\vskip.5em -\ind{1}{\GammaI}{\GammaC} -\vskip.5em -\noindent In this case, $\Gamma_P=[A:\Type]$. - -\vskip1em\hrule\vskip1em - -\noindent If we take the following inductive definition: -\begin{coq_example*} +\end{verbatim} + then: + \def\GammaI{\left[\begin{array}{r \colon l} + \List & \Type\ra\Type + \end{array} + \right]} + \def\GammaC{\left[\begin{array}{r \colon l} + \Nil & \forall~A\!:\!\Type,~\List~A\\ + \cons & \forall~A\!:\!\Type,~A\ra\List~A\ra\List~A + \end{array} + \right]} + \begin{itemize} + \item $p = 1$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ + \item $\Gamma_P=[A:\Type]$ + \end{itemize} + and thus it enriches the global environment with the following entry: + \vskip.5em + \ind{1}{\GammaI}{\GammaC} + \caption{\captionstrut Formal representation of the {\List} inductive type.} + \label{fig:list} + \end{figure} + + \begin{figure}[H] + \strut If we take the following inductive definition: +\begin{verbatim} Inductive even : nat -> Prop := | even_O : even 0 | even_S : forall n, odd n -> even (S n) with odd : nat -> Prop := | odd_S : forall n, even n -> odd (S n). -\end{coq_example*} -then: -\def\GammaI{\left[\begin{array}{r \colon l} - \even & \nat\ra\Prop \\ - \odd & \nat\ra\Prop - \end{array} - \right]} -\def\GammaC{\left[\begin{array}{r \colon l} - \evenO & \even~\nO \\ - \evenS & \forall n : \nat, \odd~n \ra \even~(\nS~n) - \end{array} - \right]} -\begin{itemize} - \item $p = 1$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ -\end{itemize} -and thus it enriches the global environment with the following entry: -\vskip.5em -\ind{p}{\Gamma_I}{\Gamma_C} -\vskip.5em -\noindent that is: -\vskip.5em -\ind{1}{\GammaI}{\GammaC} -\vskip.5em -\noindent In this case, $\Gamma_P=[A:\Type]$. - -\vskip1em\hrule\vskip1em - -\noindent If we take the following inductive definition: -\begin{coq_example*} +\end{verbatim} + then: + \def\GammaI{\left[\begin{array}{r \colon l} + \even & \nat\ra\Prop \\ + \odd & \nat\ra\Prop + \end{array} + \right]} + \def\GammaC{\left[\begin{array}{r \colon l} + \evenO & \even~\nO \\ + \evenS & \forall n : \nat, \odd~n \ra \even~(\nS~n)\\ + \oddS & \forall n : \nat, \even~n \ra \odd~(\nS~n) + \end{array} + \right]} + \begin{itemize} + \item $p = 1$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ + \item $\Gamma_P=[A:\Type]$. + \end{itemize} + and thus it enriches the global environment with the following entry: + \vskip.5em + \ind{1}{\GammaI}{\GammaC} + \caption{\captionstrut Formal representation of the {\even} and {\odd} inductive types.} + \label{fig:even:odd} + \end{figure} + + \begin{figure}[H] + \strut If we take the following inductive definition: +\begin{verbatim} Inductive has_length (A : Type) : list A -> nat -> Prop := | nil_hl : has_length A (nil A) O | cons_hl : forall (a:A) (l:list A) (n:nat), has_length A l n -> has_length A (cons A a l) (S n). -\end{coq_example*} -then: -\def\GammaI{\left[\begin{array}{r \colon l} - \haslength & \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop - \end{array} - \right]} -\def\GammaC{\left[\begin{array}{r c l} - \nilhl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\haslength~A~(\Nil~A)~\nO\\ - \conshl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ - & & \haslength~A~l~n\ra \haslength~A~(\cons~A~a~l)~(\nS~n) - \end{array} - \right]} -\begin{itemize} - \item $p = 1$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ -\end{itemize} -and thus it enriches the global environment with the following entry: -\vskip.5em -\ind{p}{\Gamma_I}{\Gamma_C} -%\vskip.5em -%\noindent that is: -%\vskip.5em -%\ind{1}{\GammaI}{\GammaC} -\vskip.5em -\noindent In this case, $\Gamma_P=[A:\Type]$. - -\vskip1em\hrule\vskip1em - -\noindent If we take the following inductive definition: -\begin{coq_example*} +\end{verbatim} + then: + \def\GammaI{\left[\begin{array}{r \colon l} + \haslength & \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop + \end{array} + \right]} + \def\GammaC{\left[\begin{array}{r c l} + \nilhl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\haslength~A~(\Nil~A)~\nO\\ + \conshl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ + & & \haslength~A~l~n\ra \haslength~A~(\cons~A~a~l)~(\nS~n) + \end{array} + \right]} + \begin{itemize} + \item $p = 1$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ + \item $\Gamma_P=[A:\Type]$. + \end{itemize} + and thus it enriches the global environment with the following entry: + \vskip.5em + \ind{p}{\Gamma_I}{\Gamma_C} + %\vskip.5em + %\noindent that is: + %\vskip.5em + %\ind{1}{\GammaI}{\GammaC} + \caption{\captionstrut Formal representation of the {\haslength} inductive type.} + \label{fig:haslength} + \end{figure} + + \begin{figure}[H] + \strut If we take the following inductive definition: +\begin{verbatim} Inductive tree : Set := | node : forest -> tree with forest : Set := | emptyf : forest | consf : tree -> forest -> forest. -\end{coq_example*} -then: -\def\GammaI{\left[\begin{array}{r \colon l} - \tree & \Set\\ - \forest & \Set - \end{array} - \right]} -\def\GammaC{\left[\begin{array}{r \colon l} - \node & \forest\ra\tree\\ - \emptyf & \forest\\ - \consf & \tree\ra\forest\ra\forest - \end{array} - \right]} -\begin{itemize} - \item $p = 0$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ -\end{itemize} -and thus it enriches the global environment with the following entry: -\vskip.5em -\ind{p}{\Gamma_I}{\Gamma_C} -\vskip.5em -\noindent that is: -\vskip.5em -\ind{0}{\GammaI}{\GammaC} -\vskip.5em -\noindent In this case, $\Gamma_P=[\,]$. +\end{verbatim} + then: + \def\GammaI{\left[\begin{array}{r \colon l} + \tree & \Set\\ + \forest & \Set + \end{array} + \right]} + \def\GammaC{\left[\begin{array}{r \colon l} + \node & \forest\ra\tree\\ + \emptyf & \forest\\ + \consf & \tree\ra\forest\ra\forest + \end{array} + \right]} + \begin{itemize} + \item $p = 0$ + \item $\Gamma_I = \GammaI$ + \item $\Gamma_C = \GammaC$ + \end{itemize} + and thus it enriches the global environment with the following entry: + \vskip.5em + \ind{0}{\GammaI}{\GammaC} + \caption{\captionstrut Formal representation of the {\tree} and {\forest} inductive types.} + \label{fig:tree:forest} + \end{figure}% + \newpage \end{latexonly}% \subsection{Types of inductive objects} @@ -872,68 +872,77 @@ the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} \begin{latexonly}% -\newcommand\vv{\textSFxi} % │ -\newcommand\hh{\textSFx} % ─ -\newcommand\vh{\textSFviii} % ├ -\newcommand\hv{\textSFii} % └ -\newlength\framecharacterwidth -\settowidth\framecharacterwidth{\hh} -\newcommand\ws{\hbox{}\hskip\the\framecharacterwidth} -\newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} -\paragraph{Example}~\\ -\vskip-.5em -\noindent$X$ occurs strictly positively in $A\ra X$\ruleref5\\ -\vv\\ -\vh\hh\ws $X$does not occur in $A$\ruleref3\\ -\vv\\ -\hv\hh\ws $X$ occurs strictly positively in $X$\ruleref4 -\paragraph{Example}~\\ -\vskip-.5em -\noindent $X$ occurs strictly positively in $X*A$\\ -\vv\\ -\hv\hh $X$ occurs strictly positively in $(\Prod~X~A)$\ruleref6\\ -\ws\ws\vv\\ -\ws\ws\vv\ws\verb|Inductive prod (A B : Type) : Type :=|\\ -\ws\ws\vv\ws\verb| pair : A -> B -> prod A B.|\\ -\ws\ws\vv\\ -\ws\ws\vh\hh $X$ does not occur in any (real) arguments of $\Prod$ in the original term $(\Prod~X~A)$\\ -\ws\ws\vv\\ -\ws\ws\hv\ws the (instantiated) type $\Prod~X~A$ of constructor $\Pair$,\\ -\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref7\\ -\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\hv\ws $X$ does not occur in any (real) arguments of $(\Prod~X~A)$ -\paragraph{Example}~\\ -\vskip-.5em -\noindent $X$ occurs strictly positively in $\ListA$\ruleref6\\ -\vv\\ -\vv\ws\verb|Inductive list (A:Type) : Type :=|\\ -\vv\ws\verb$ | nil : list A$\\ -\vv\ws\verb$ | cons : A -> list A -> list A$\\ -\vv\\ -\vh\hh $X$ does not occur in any arguments of $\List$\\ -\vv\\ -\hv\hh\ws Every instantiated constructor of $\ListA$ satisfies the nested positivity condition for $X$\\ -\ws\ws\ws\vv\\ -\ws\ws\ws\vh\hh\ws concerning type $\ListA$ of constructor $\Nil$:\\ -\ws\ws\ws\vv\ws\ws Type $\ListA$ of constructor $\Nil$ satisfies the nested positivity condition for $X$\\ -\ws\ws\ws\vv\ws\ws because $X$ does not appear in any (real) arguments of the type of that constructor\\ -\ws\ws\ws\vv\ws\ws (primarily because $\List$ does not have any (real) arguments)\ruleref7\\ -\ws\ws\ws\vv\\ -\ws\ws\ws\hv\hh\ws concerning type $\forall~A\ra\ListA\ra\ListA$ of constructor $\cons$:\\ -\ws\ws\ws\ws\ws\ws Type $\forall~A:\Type,A\ra\ListA\ra\ListA$ of constructor $\cons$\\ -\ws\ws\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref8\\ -\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\Type$\ruleref3\\ -\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $A\ra\ListA\ra\ListA$\ruleref8\\ -\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $A$\ruleref3\\ -\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA\ra\ListA$\ruleref8\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\ListA$\ruleref3\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ -\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 + \newpage + \newcommand\vv{\textSFxi} % │ + \newcommand\hh{\textSFx} % ─ + \newcommand\vh{\textSFviii} % ├ + \newcommand\hv{\textSFii} % └ + \newlength\framecharacterwidth + \settowidth\framecharacterwidth{\hh} + \newcommand\ws{\hbox{}\hskip\the\framecharacterwidth} + \newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} + \def\captionstrut{\vbox to 1.5em{}} + + \begin{figure}[H] + \ws\strut $X$ occurs strictly positively in $A\ra X$\ruleref5\\ + \ws\vv\\ + \ws\vh\hh\ws $X$does not occur in $A$\\ + \ws\vv\\ + \ws\hv\hh\ws $X$ occurs strictly positively in $X$\ruleref4 + \caption{\captionstrut A proof that $X$ occurs strictly positively in $A\ra X$.} + \end{figure} + +% \begin{figure}[H] +% \strut $X$ occurs strictly positively in $X*A$\\ +% \vv\\ +% \hv\hh $X$ occurs strictly positively in $(\Prod~X~A)$\ruleref6\\ +% \ws\ws\vv\\ +% \ws\ws\vv\ws\verb|Inductive prod (A B : Type) : Type :=|\\ +% \ws\ws\vv\ws\verb| pair : A -> B -> prod A B.|\\ +% \ws\ws\vv\\ +% \ws\ws\vh\hh $X$ does not occur in any (real) arguments of $\Prod$ in the original term $(\Prod~X~A)$\\ +% \ws\ws\vv\\ +% \ws\ws\hv\hh\ws the (instantiated) type $\Prod~X~A$ of constructor $\Pair$,\\ +% \ws\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref7\\ +% \ws\ws\ws\ws\ws\vv\\ +% \ws\ws\ws\ws\ws\hv\hh\ws $X$ does not occur in any (real) arguments of $(\Prod~X~A)$ +% \caption{\captionstrut A proof that $X$ occurs strictly positively in $X*A$} +% \end{figure} + + \begin{figure}[H] + \ws\strut $X$ occurs strictly positively in $\ListA$\ruleref6\\ + \ws\vv\\ + \ws\vv\ws\verb|Inductive list (A:Type) : Type :=|\\ + \ws\vv\ws\verb$ | nil : list A$\\ + \ws\vv\ws\verb$ | cons : A -> list A -> list A$\\ + \ws\vv\\ + \ws\vh\hh $X$ does not occur in any (real) arguments of $\List$\\ + \ws\vv\\ + \ws\hv\hh\ws Every instantiated constructor of $\ListA$ satisfies the nested positivity condition for $X$\\ + \ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\vh\hh\ws concerning type $\ListA$ of constructor $\Nil$:\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws Type $\ListA$ of constructor $\Nil$ satisfies the nested positivity condition for $X$\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws because $X$ does not appear in any (real) arguments of the type of that constructor\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws (primarily because $\List$ does not have any (real) arguments)\ruleref7\\ + \ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\hv\hh\ws concerning type $\forall~A\ra\ListA\ra\ListA$ of constructor $\cons$:\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws Type $\forall~A:\Type,A\ra\ListA\ra\ListA$ of constructor $\cons$\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref8\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\Type$\ruleref3\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $A\ra\ListA\ra\ListA$\ruleref8\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $A$\ruleref3\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA\ra\ListA$\ruleref8\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\ListA$\ruleref4\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 + \caption{\captionstrut A proof that $X$ occurs strictly positively in $\ListA$} + \end{figure} + \newpage \end{latexonly}% \paragraph{Correctness rules.} diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index cb5d2ecb54..dcb98d96b3 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -21,6 +21,10 @@ \usepackage{multicol} \usepackage{xspace} \usepackage{pmboxdraw} +\usepackage{float} + +\floatstyle{boxed} +\restylefloat{figure} % for coqide \ifpdf % si on est pas en pdflatex -- cgit v1.2.3 From f43f474fe3ba0b01115ef02b0032f706879ee521 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 24 Nov 2015 13:50:08 +0100 Subject: FIX: wrong reference to a figure --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ad711549b2..1b461afcb2 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -532,7 +532,7 @@ These inductive definitions, together with global assumptions and global definit Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: $\forall\Gamma_P, T^\prime$ where $\Gamma_P$ is called the {\em context of parameters\index{context of parameters}}. -Figures~\ref{fig:bool}--\ref{fig:even:odd} show formal representation of several inductive definitions. +Figures~\ref{fig:bool}--\ref{fig:tree:forest} show formal representation of several inductive definitions. \begin{latexonly}% \newpage -- cgit v1.2.3 From 9e12f35ddf03dd47af99284fa9bfbb14759834b8 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 24 Nov 2015 18:12:32 +0100 Subject: ENH: redundant examples were removed --- doc/refman/RefMan-cic.tex | 198 ---------------------------------------------- 1 file changed, 198 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 1b461afcb2..3e50ac0de0 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -532,10 +532,8 @@ These inductive definitions, together with global assumptions and global definit Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: $\forall\Gamma_P, T^\prime$ where $\Gamma_P$ is called the {\em context of parameters\index{context of parameters}}. -Figures~\ref{fig:bool}--\ref{fig:tree:forest} show formal representation of several inductive definitions. \begin{latexonly}% - \newpage \def\captionstrut{\vbox to 1.5em{}} \newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em \begin{array}{r @{\mathrm{~:=~}} l} @@ -546,104 +544,6 @@ Figures~\ref{fig:bool}--\ref{fig:tree:forest} show formal representation of seve \def\colon{@{\hskip.5em:\hskip.5em}} - \begin{figure}[H] - \strut If we take the following inductive definition (denoted in concrete syntax): -\begin{verbatim} -Inductive bool : Set := - | true : bool - | false : bool. -\end{verbatim} - then: - \def\GammaI{\left[\begin{array}{r \colon l} - \bool & \Set - \end{array} - \right]} - \def\GammaC{\left[\begin{array}{r \colon l} - \true & \bool\\ - \false & \bool - \end{array} - \right]} - \begin{itemize} - \item $p = 0$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ - \item $\Gamma_P=[\,]$. - \end{itemize} - and thus it enriches the global environment with the following entry: - \vskip.5em - \ind{p}{\Gamma_I}{\Gamma_C} - \vskip.5em - \noindent that is: - \vskip.5em - \ind{0}{\GammaI}{\GammaC} - \caption{\captionstrut Formal representation of the {\bool} inductive type.} - \label{fig:bool} - \end{figure} - - \begin{figure}[H] - \strut If we take the followig inductive definition: -\begin{verbatim} -Inductive nat : Set := - | O : nat - | S : nat -> nat. -\end{verbatim} - then: - \def\GammaI{\left[\begin{array}{r \colon l} - \nat & \Set - \end{array} - \right]} - \def\GammaC{\left[\begin{array}{r \colon l} - \nO & \nat\\ - \nS & \nat\ra\nat - \end{array} - \right]} - \begin{itemize} - \item $p = 0$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ - \item $\Gamma_P=[\,]$. - \end{itemize} - and thus it enriches the global environment with the following entry: - \vskip.5em - \ind{p}{\Gamma_I}{\Gamma_C} - \vskip.5em - \noindent that is: - \vskip.5em - \ind{0}{\GammaI}{\GammaC} - \caption{\captionstrut Formal representation of the {\nat} inductive type.} - \label{fig:nat} - \end{figure} - - \begin{figure}[H] - \strut If we take the following inductive definition: -\begin{verbatim} -Inductive list (A : Type) : Type := - | nil : list A - | cons : A -> list A -> list A. -\end{verbatim} - then: - \def\GammaI{\left[\begin{array}{r \colon l} - \List & \Type\ra\Type - \end{array} - \right]} - \def\GammaC{\left[\begin{array}{r \colon l} - \Nil & \forall~A\!:\!\Type,~\List~A\\ - \cons & \forall~A\!:\!\Type,~A\ra\List~A\ra\List~A - \end{array} - \right]} - \begin{itemize} - \item $p = 1$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ - \item $\Gamma_P=[A:\Type]$ - \end{itemize} - and thus it enriches the global environment with the following entry: - \vskip.5em - \ind{1}{\GammaI}{\GammaC} - \caption{\captionstrut Formal representation of the {\List} inductive type.} - \label{fig:list} - \end{figure} - \begin{figure}[H] \strut If we take the following inductive definition: \begin{verbatim} @@ -677,76 +577,6 @@ with odd : nat -> Prop := \caption{\captionstrut Formal representation of the {\even} and {\odd} inductive types.} \label{fig:even:odd} \end{figure} - - \begin{figure}[H] - \strut If we take the following inductive definition: -\begin{verbatim} -Inductive has_length (A : Type) : list A -> nat -> Prop := - | nil_hl : has_length A (nil A) O - | cons_hl : forall (a:A) (l:list A) (n:nat), - has_length A l n -> has_length A (cons A a l) (S n). -\end{verbatim} - then: - \def\GammaI{\left[\begin{array}{r \colon l} - \haslength & \forall~A\!:\!\Type,~\List~A\ra\nat\ra\Prop - \end{array} - \right]} - \def\GammaC{\left[\begin{array}{r c l} - \nilhl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\haslength~A~(\Nil~A)~\nO\\ - \conshl & \hskip.1em:\hskip.1em & \forall~A\!:\!\Type,~\forall~a\!:\!A,~\forall~l\!:\!\List~A,~\forall~n\!:\!\nat,\\ - & & \haslength~A~l~n\ra \haslength~A~(\cons~A~a~l)~(\nS~n) - \end{array} - \right]} - \begin{itemize} - \item $p = 1$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ - \item $\Gamma_P=[A:\Type]$. - \end{itemize} - and thus it enriches the global environment with the following entry: - \vskip.5em - \ind{p}{\Gamma_I}{\Gamma_C} - %\vskip.5em - %\noindent that is: - %\vskip.5em - %\ind{1}{\GammaI}{\GammaC} - \caption{\captionstrut Formal representation of the {\haslength} inductive type.} - \label{fig:haslength} - \end{figure} - - \begin{figure}[H] - \strut If we take the following inductive definition: -\begin{verbatim} -Inductive tree : Set := - | node : forest -> tree -with forest : Set := - | emptyf : forest - | consf : tree -> forest -> forest. -\end{verbatim} - then: - \def\GammaI{\left[\begin{array}{r \colon l} - \tree & \Set\\ - \forest & \Set - \end{array} - \right]} - \def\GammaC{\left[\begin{array}{r \colon l} - \node & \forest\ra\tree\\ - \emptyf & \forest\\ - \consf & \tree\ra\forest\ra\forest - \end{array} - \right]} - \begin{itemize} - \item $p = 0$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ - \end{itemize} - and thus it enriches the global environment with the following entry: - \vskip.5em - \ind{0}{\GammaI}{\GammaC} - \caption{\captionstrut Formal representation of the {\tree} and {\forest} inductive types.} - \label{fig:tree:forest} - \end{figure}% - \newpage \end{latexonly}% \subsection{Types of inductive objects} @@ -872,7 +702,6 @@ the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} \begin{latexonly}% - \newpage \newcommand\vv{\textSFxi} % │ \newcommand\hh{\textSFx} % ─ \newcommand\vh{\textSFviii} % ├ @@ -883,32 +712,6 @@ the type $V$ satisfies the nested positivity condition for $X$ \newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} \def\captionstrut{\vbox to 1.5em{}} - \begin{figure}[H] - \ws\strut $X$ occurs strictly positively in $A\ra X$\ruleref5\\ - \ws\vv\\ - \ws\vh\hh\ws $X$does not occur in $A$\\ - \ws\vv\\ - \ws\hv\hh\ws $X$ occurs strictly positively in $X$\ruleref4 - \caption{\captionstrut A proof that $X$ occurs strictly positively in $A\ra X$.} - \end{figure} - -% \begin{figure}[H] -% \strut $X$ occurs strictly positively in $X*A$\\ -% \vv\\ -% \hv\hh $X$ occurs strictly positively in $(\Prod~X~A)$\ruleref6\\ -% \ws\ws\vv\\ -% \ws\ws\vv\ws\verb|Inductive prod (A B : Type) : Type :=|\\ -% \ws\ws\vv\ws\verb| pair : A -> B -> prod A B.|\\ -% \ws\ws\vv\\ -% \ws\ws\vh\hh $X$ does not occur in any (real) arguments of $\Prod$ in the original term $(\Prod~X~A)$\\ -% \ws\ws\vv\\ -% \ws\ws\hv\hh\ws the (instantiated) type $\Prod~X~A$ of constructor $\Pair$,\\ -% \ws\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref7\\ -% \ws\ws\ws\ws\ws\vv\\ -% \ws\ws\ws\ws\ws\hv\hh\ws $X$ does not occur in any (real) arguments of $(\Prod~X~A)$ -% \caption{\captionstrut A proof that $X$ occurs strictly positively in $X*A$} -% \end{figure} - \begin{figure}[H] \ws\strut $X$ occurs strictly positively in $\ListA$\ruleref6\\ \ws\vv\\ @@ -942,7 +745,6 @@ the type $V$ satisfies the nested positivity condition for $X$ \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 \caption{\captionstrut A proof that $X$ occurs strictly positively in $\ListA$} \end{figure} - \newpage \end{latexonly}% \paragraph{Correctness rules.} -- cgit v1.2.3 From 006e1a5bf9e90fba3ba9fa1541e7ed8978c99441 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 09:25:03 +0100 Subject: Refman, ch. 4: A few fixes. --- doc/refman/RefMan-cic.tex | 155 ++++++++++++++++++++++++++-------------------- 1 file changed, 89 insertions(+), 66 deletions(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 3e50ac0de0..e3e49e115d 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -533,51 +533,76 @@ Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: $\forall\Gamma_P, T^\prime$ where $\Gamma_P$ is called the {\em context of parameters\index{context of parameters}}. -\begin{latexonly}% - \def\captionstrut{\vbox to 1.5em{}} - \newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em +\paragraph{Examples} + + \newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em \begin{array}{r @{\mathrm{~:=~}} l} #2 & #3 \\ \end{array} \hskip-.4em \right)$} + \def\colon{@{\hskip.5em:\hskip.5em}} - \def\colon{@{\hskip.5em:\hskip.5em}} +The declaration for parameterized lists is: + \vskip.5em - \begin{figure}[H] - \strut If we take the following inductive definition: -\begin{verbatim} -Inductive even : nat -> Prop := - | even_O : even 0 - | even_S : forall n, odd n -> even (S n) -with odd : nat -> Prop := - | odd_S : forall n, even n -> odd (S n). -\end{verbatim} - then: - \def\GammaI{\left[\begin{array}{r \colon l} +\ind{1}{\List:\Set\ra\Set}{\left[\begin{array}{r \colon l} + \Nil & \forall A:\Set,\List~A \\ + \cons & \forall A:\Set, A \ra \List~A \ra \List~A + \end{array}\right]} + \vskip.5em + +which corresponds to the result of the \Coq\ declaration: +\begin{coq_example*} +Inductive list (A:Set) : Set := + | nil : list A + | cons : A -> list A -> list A. +\end{coq_example*} + +The declaration for a mutual inductive definition of forests and trees is: + \vskip.5em +\ind{}{\left[\begin{array}{r \colon l}\tree&\Set\\\forest&\Set\end{array}\right]} + {\left[\begin{array}{r \colon l} + \node & \forest \ra \tree\\ + \emptyf & \forest\\ + \consf & \tree \ra \forest \ra \forest\\ + \end{array}\right]} + \vskip.5em + +which corresponds to the result of the \Coq\ +declaration: +\begin{coq_example*} +Inductive tree : Set := + node : forest -> tree +with forest : Set := + | emptyf : forest + | consf : tree -> forest -> forest. +\end{coq_example*} + +The declaration for a mutual inductive definition of even and odd is: + \newcommand\GammaI{\left[\begin{array}{r \colon l} \even & \nat\ra\Prop \\ \odd & \nat\ra\Prop \end{array} \right]} - \def\GammaC{\left[\begin{array}{r \colon l} + \newcommand\GammaC{\left[\begin{array}{r \colon l} \evenO & \even~\nO \\ \evenS & \forall n : \nat, \odd~n \ra \even~(\nS~n)\\ \oddS & \forall n : \nat, \even~n \ra \odd~(\nS~n) \end{array} \right]} - \begin{itemize} - \item $p = 1$ - \item $\Gamma_I = \GammaI$ - \item $\Gamma_C = \GammaC$ - \item $\Gamma_P=[A:\Type]$. - \end{itemize} - and thus it enriches the global environment with the following entry: \vskip.5em \ind{1}{\GammaI}{\GammaC} - \caption{\captionstrut Formal representation of the {\even} and {\odd} inductive types.} - \label{fig:even:odd} - \end{figure} -\end{latexonly}% + \vskip.5em +which corresponds to the result of the \Coq\ +declaration: +\begin{coq_example*} +Inductive even : nat -> Prop := + | even_O : even 0 + | even_S : forall n, odd n -> even (S n) +with odd : nat -> Prop := + | odd_S : forall n, even n -> odd (S n). +\end{coq_example*} \subsection{Types of inductive objects} We have to give the type of constants in a global environment $E$ which @@ -595,7 +620,7 @@ contains an inductive declaration. Provided that our environment $E$ contains inductive definitions we showed before, these two inference rules above enable us to conclude that: \vskip.5em -\def\prefix{E[\Gamma]\vdash\hskip.25em} +\newcommand\prefix{E[\Gamma]\vdash\hskip.25em} $\begin{array}{@{} l} \prefix\even : \nat\ra\Prop\\ \prefix\odd : \nat\ra\Prop\\ @@ -701,51 +726,49 @@ any $u_i$ the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} -\begin{latexonly}% - \newcommand\vv{\textSFxi} % │ - \newcommand\hh{\textSFx} % ─ - \newcommand\vh{\textSFviii} % ├ - \newcommand\hv{\textSFii} % └ - \newlength\framecharacterwidth - \settowidth\framecharacterwidth{\hh} - \newcommand\ws{\hbox{}\hskip\the\framecharacterwidth} - \newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} - \def\captionstrut{\vbox to 1.5em{}} - - \begin{figure}[H] - \ws\strut $X$ occurs strictly positively in $\ListA$\ruleref6\\ - \ws\vv\\ - \ws\vv\ws\verb|Inductive list (A:Type) : Type :=|\\ - \ws\vv\ws\verb$ | nil : list A$\\ - \ws\vv\ws\verb$ | cons : A -> list A -> list A$\\ - \ws\vv\\ - \ws\vh\hh $X$ does not occur in any (real) arguments of $\List$\\ - \ws\vv\\ - \ws\hv\hh\ws Every instantiated constructor of $\ListA$ satisfies the nested positivity condition for $X$\\ +%% \begin{latexonly}% + \newcommand\vv{\textSFxi} % │ + \newcommand\hh{\textSFx} % ─ + \newcommand\vh{\textSFviii} % ├ + \newcommand\hv{\textSFii} % └ + \newlength\framecharacterwidth + \settowidth\framecharacterwidth{\hh} + \newcommand\ws{\hbox{}\hskip\the\framecharacterwidth} + \newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} +%% \def\captionstrut{\vbox to 1.5em{}} + +%% \begin{figure}[H] +For instance, if one considers the type + +\begin{verbatim} +Inductive tree (A:Type) : Type := + | leaf : list A + | node : A -> (nat -> tree A) -> tree A +\end{verbatim} + +Then every instantiated constructor of $\ListA$ satisfies the nested positivity condition for $\List$ + +\noindent \ws\ws\ws\ws\vv\\ \ws\ws\ws\ws\vh\hh\ws concerning type $\ListA$ of constructor $\Nil$:\\ - \ws\ws\ws\ws\vv\ws\ws\ws\ws Type $\ListA$ of constructor $\Nil$ satisfies the nested positivity condition for $X$\\ - \ws\ws\ws\ws\vv\ws\ws\ws\ws because $X$ does not appear in any (real) arguments of the type of that constructor\\ - \ws\ws\ws\ws\vv\ws\ws\ws\ws (primarily because $\List$ does not have any (real) arguments)\ruleref7\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws Type $\ListA$ of constructor $\Nil$ satisfies the positivity condition for $\List$\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws because $\List$ does not appear in any (real) arguments of the type of that constructor\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws (primarily because $\List$ does not have any (real) arguments)\ruleref1\\ \ws\ws\ws\ws\vv\\ \ws\ws\ws\ws\hv\hh\ws concerning type $\forall~A\ra\ListA\ra\ListA$ of constructor $\cons$:\\ \ws\ws\ws\ws\ws\ws\ws\ws\ws Type $\forall~A:\Type,A\ra\ListA\ra\ListA$ of constructor $\cons$\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws satisfies the nested positivity condition for $X$\ruleref8\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws satisfies the positivity condition for $\List$ because:\\ \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\Type$\ruleref3\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $\Type$\ruleref3\\ \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $A\ra\ListA\ra\ListA$\ruleref8\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $A$\ruleref3\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA\ra\ListA$\ruleref8\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $X$ occurs only strictly positively in $\ListA$\ruleref4\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ - \ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $X$ satisfies the nested positivity condition for $\ListA$\ruleref7 - \caption{\captionstrut A proof that $X$ occurs strictly positively in $\ListA$} - \end{figure} -\end{latexonly}% + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $A$\ruleref3\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $\ListA$\ruleref4\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $\List$ satisfies the positivity condition for $\ListA$\ruleref1 +%% \caption{\captionstrut A proof that $X$ occurs strictly positively in $\ListA$} +%% \end{figure} +%% \end{latexonly}% \paragraph{Correctness rules.} We shall now describe the rules allowing the introduction of a new -- cgit v1.2.3 From a6f1944809e4caa6c99deb8c508dab9ad0e0071e Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 10 Dec 2015 16:02:15 +0100 Subject: Silently ignore requests to _not_ clear something when that something cannot be cleared. This should fix the contrib failures on tactics like "destruct (0)". --- tactics/tactics.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index ce8b9b3dbd..536a10eaa7 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -277,7 +277,8 @@ let apply_clear_request clear_flag dft c = error "keep/clear modifiers apply only to hypothesis names." in let clear = match clear_flag with | None -> dft && isVar c - | Some clear -> check_isvar c; clear in + | Some true -> check_isvar c; true + | Some false -> false in if clear then Proofview.V82.tactic (thin [destVar c]) else Tacticals.New.tclIDTAC -- cgit v1.2.3 From 20e1829ad3de42dd322af972c6f9a585f40738ef Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 16:40:38 +0100 Subject: Fixing compilation with OCaml 3.12 after commit 9d45d45f3a87 on removing "open Unix" from lib/system.ml. --- lib/system.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/system.ml b/lib/system.ml index f860bd2f7e..a902229609 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -262,7 +262,7 @@ type time = float * float * float let get_time () = let t = Unix.times () in - (Unix.gettimeofday(), t.tms_utime, t.tms_stime) + (Unix.gettimeofday(), t.Unix.tms_utime, t.Unix.tms_stime) (* Keep only 3 significant digits *) let round f = (floor (f *. 1e3)) *. 1e-3 -- cgit v1.2.3 From fb77937a6ba0fe45e978911db08de57f931683e1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 9 Dec 2015 23:38:00 +0100 Subject: Changing syntax of pat/constr1.../constrn into pat%constr1...%constrn. Marking it as experimental. --- CHANGES | 3 +++ doc/refman/RefMan-tac.tex | 14 +++++++------- parsing/g_tactic.ml4 | 3 ++- test-suite/success/intros.v | 20 ++++++++++---------- theories/Logic/WKL.v | 6 +++--- theories/Logic/WeakFan.v | 2 +- theories/Wellfounded/Lexicographic_Exponentiation.v | 2 +- 7 files changed, 27 insertions(+), 23 deletions(-) diff --git a/CHANGES b/CHANGES index 70ed1bef01..389572014e 100644 --- a/CHANGES +++ b/CHANGES @@ -9,6 +9,9 @@ Tactics - Syntax "destruct !hyp" changed to "destruct (hyp)", and similarly for induction. +- Syntax "p/c" for on-the-fly application of a lemma c before + introducing along pattern p changed to p%c1..%cn. The feature and + syntax are in experimental stage. Changes from V8.5beta2 to V8.5beta3 =================================== diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index f367f04c43..3a3877105b 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -813,7 +813,7 @@ either: \item the pattern \texttt{?\ident} \item an identifier \end{itemize} -\item a {\em destructing introduction pattern} which itself classifies into: +\item an {\em action introduction pattern} which itself classifies into: \begin{itemize} \item a {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: \begin{itemize} @@ -828,9 +828,9 @@ either: \item a pattern for decomposing an equality: {\tt [= $p_1$ \dots\ $p_n$]} \item the rewriting orientations: {\tt ->} or {\tt <-} \end{itemize} - \item the on-the-fly application of lemmas: $p${\tt /{\term$_1$}} - \ldots {\tt /{\term$_n$}} where $p$ itself is not an on-the-fly - application of lemmas pattern + \item the on-the-fly application of lemmas: $p${\tt \%{\term$_1$}} + \ldots {\tt \%{\term$_n$}} where $p$ itself is not a pattern for + on-the-fly application of lemmas (note: syntax is in experimental stage) \end{itemize} \item the wildcard: {\tt \_} \end{itemize} @@ -898,10 +898,10 @@ introduction pattern~$p$: itself is erased; if the term to substitute is a variable, it is substituted also in the context of goal and the variable is removed too; -\item introduction over a pattern $p${\tt /{\term$_1$}} \ldots {\tt - /{\term$_n$}} first applies {\term$_1$},\ldots, {\term$_n$} on the +\item introduction over a pattern $p${\tt \%{\term$_1$}} \ldots {\tt + \%{\term$_n$}} first applies {\term$_1$},\ldots, {\term$_n$} on the hypothesis to be introduced (as in {\tt apply }{\term}$_1$, \ldots, - {\term}$_n$ {\tt in}), prior to the application of the introduction + {\term}$_n$ {\tt in}) prior to the application of the introduction pattern $p$; \item introduction on the wildcard depends on whether the product is dependent or not: in the non-dependent case, it erases the diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 4d42dfe85a..3d59b9b8db 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -311,7 +311,8 @@ GEXTEND Gram | "**" -> !@loc, IntroForthcoming false ]] ; simple_intropattern: - [ [ pat = simple_intropattern_closed; l = LIST0 ["/"; c = constr -> c] -> + [ [ pat = simple_intropattern_closed; + l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> let loc0,pat = pat in let f c pat = let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 741f372ff2..17f160f98e 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -34,47 +34,47 @@ intros _ ?. exact H. Qed. -(* A short test about introduction pattern pat/c *) +(* A short test about introduction pattern pat%c *) Goal (True -> 0=0) -> True /\ False -> 0=0. -intros H (H1/H,_). +intros H (H1%H,_). exact H1. Qed. (* A test about bugs in 8.5beta2 *) Goal (True -> 0=0) -> True /\ False -> False -> 0=0. intros H H0 H1. -destruct H0 as (a/H,_). +destruct H0 as (a%H,_). (* Check that H0 is removed (was bugged in 8.5beta2) *) Fail clear H0. -(* Check position of newly created hypotheses when using pat/c (was +(* Check position of newly created hypotheses when using pat%c (was left at top in 8.5beta2) *) match goal with H:_ |- _ => clear H end. (* clear H1:False *) match goal with H:_ |- _ => exact H end. (* check that next hyp shows 0=0 *) Qed. Goal (True -> 0=0) -> True -> 0=0. -intros H H1/H. +intros H H1%H. exact H1. Qed. Goal forall n, n = S n -> 0=0. -intros n H/n_Sn. +intros n H%n_Sn. destruct H. Qed. (* Another check about generated names and cleared hypotheses with - pat/c patterns *) + pat%c patterns *) Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. -intros H (H1,?)/H. +intros H (H1,?)%H. change (1=1) in H0. exact H1. Qed. -(* Checking iterated pat/c1.../cn introduction patterns and side conditions *) +(* Checking iterated pat%c1...%cn introduction patterns and side conditions *) Goal forall A B C D:Prop, (A -> B -> C) -> (C -> D) -> B -> A -> D. intros * H H0 H1. -intros H2/H/H0. +intros H2%H%H0. - exact H2. - exact H1. Qed. diff --git a/theories/Logic/WKL.v b/theories/Logic/WKL.v index 408eca4a33..abe6a8d995 100644 --- a/theories/Logic/WKL.v +++ b/theories/Logic/WKL.v @@ -40,7 +40,7 @@ Proposition is_path_from_characterization P n l : Proof. intros. split. - induction 1 as [|* HP _ (l'&Hl'&HPl')|* HP _ (l'&Hl'&HPl')]. - + exists []. split. reflexivity. intros n <-/le_n_0_eq. assumption. + + exists []. split. reflexivity. intros n <-%le_n_0_eq. assumption. + exists (true :: l'). split. apply eq_S, Hl'. intros [|] H. * assumption. * simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. @@ -51,10 +51,10 @@ intros. split. + constructor. apply (HPl' 0). apply le_0_n. + eapply next_left. * apply (HPl' 0), le_0_n. - * fold (length l'). apply IHl'. intros n' H/le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + apply next_right. * apply (HPl' 0), le_0_n. - * fold (length l'). apply IHl'. intros n' H/le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. Qed. (** [infinite_from P l] means that we can find arbitrary long paths diff --git a/theories/Logic/WeakFan.v b/theories/Logic/WeakFan.v index 2f84ebe5f3..365661be05 100644 --- a/theories/Logic/WeakFan.v +++ b/theories/Logic/WeakFan.v @@ -89,7 +89,7 @@ Qed. Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P []. Proof. intros P Hbar. -destruct Hbar with (X P) as (l,(Hd/Y_approx,HP)). +destruct Hbar with (X P) as (l,(Hd%Y_approx,HP)). assert (inductively_barred P l) by (apply (now P l), HP). clear Hbar HP. induction l as [|a l]. diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index dd9e4c986e..b8b9e929c2 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -95,7 +95,7 @@ Section Wf_Lexicographic_Exponentiation. intros. - inversion H. assert ([b; a] = ([] ++ [b]) ++ [a]) by auto with sets. - destruct (app_inj_tail (l ++ [y]) ([] ++ [b]) _ _ H0) as ((?, <-)/app_inj_tail, <-). + destruct (app_inj_tail (l ++ [y]) ([] ++ [b]) _ _ H0) as ((?, <-)%app_inj_tail, <-). inversion H1; subst; [ apply rt_step; assumption | apply rt_refl ]. - inversion H0. + apply app_cons_not_nil in H3 as (). -- cgit v1.2.3 From cdaf8e2ed109bd117da2366a279fa575d7b6185a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 19:14:19 +0100 Subject: Fixing a pat%constr bug. Thanks to Enrico for reporting. --- tactics/tacinterp.ml | 2 +- test-suite/success/intros.v | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 693b382cac..59420e4e01 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -866,7 +866,7 @@ and interp_intro_pattern_action ist env sigma = function let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l | IntroApplyOn (c,ipat) -> - let c = fun env sigma -> interp_constr ist env sigma c in + let c = fun env sigma -> interp_open_constr ist env sigma c in let sigma,ipat = interp_intro_pattern ist env sigma ipat in sigma, IntroApplyOn (c,ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 17f160f98e..11156aa0ee 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -78,3 +78,9 @@ intros H2%H%H0. - exact H2. - exact H1. Qed. + +(* Bug found by Enrico *) + +Goal forall x : nat, True. +intros y%(fun x => x). +Abort. -- cgit v1.2.3 From 5ad28372f001acbc562e1d095728cdb8a131938c Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 10 Dec 2015 18:26:08 +0100 Subject: Add tactic native_cast_no_check, analog to vm_cast_no_check. --- tactics/coretactics.ml4 | 4 ++++ tactics/tactics.ml | 4 ++++ tactics/tactics.mli | 1 + 3 files changed, 9 insertions(+) diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index e909a14c9e..92d4960a7c 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -42,6 +42,10 @@ TACTIC EXTEND vm_cast_no_check [ "vm_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ] END +TACTIC EXTEND native_cast_no_check + [ "native_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.native_cast_no_check c) ] +END + TACTIC EXTEND casetype [ "casetype" constr(c) ] -> [ Tactics.case_type c ] END diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 536a10eaa7..131730ebc0 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1731,6 +1731,10 @@ let vm_cast_no_check c gl = let concl = pf_concl gl in refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl +let native_cast_no_check c gl = + let concl = pf_concl gl in + refine_no_check (Term.mkCast(c,Term.NATIVEcast,concl)) gl + let exact_proof c gl = let c,ctx = Constrintern.interp_casted_constr (pf_env gl) (project gl) c (pf_concl gl) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index b9a0184180..896b33727c 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -118,6 +118,7 @@ val intros_patterns : intro_patterns -> unit Proofview.tactic val assumption : unit Proofview.tactic val exact_no_check : constr -> tactic val vm_cast_no_check : constr -> tactic +val native_cast_no_check : constr -> tactic val exact_check : constr -> unit Proofview.tactic val exact_proof : Constrexpr.constr_expr -> tactic -- cgit v1.2.3 From ab3a1aed8fcaed3b0988b686b7f4cf7124b07ab2 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 11 Dec 2015 12:15:17 +0100 Subject: Remove Set Virtual Machine from doc, since the command itself has been removed. --- doc/refman/RefMan-com.tex | 6 ------ doc/refman/RefMan-oth.tex | 20 -------------------- 2 files changed, 26 deletions(-) diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 9862abb533..8bb1cc331b 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -87,7 +87,6 @@ code. The list of highlight tags can be retrieved with the {\tt -list-tags} command-line option of {\tt coqtop}. \subsection{By command line options\index{Options of the command line} -\label{vmoption} \label{coqoptions}} The following command-line options are recognized by the commands {\tt @@ -224,11 +223,6 @@ Add physical path {\em directory} to the {\ocaml} loadpath. \item[{\tt -no-hash-consing}] \mbox{} -\item[{\tt -vm}]\ - - This activates the use of the bytecode-based conversion algorithm - for the current session (see Section~\ref{SetVirtualMachine}). - \item[{\tt -image} {\em file}]\ This option sets the binary image to be used by {\tt coqc} to be {\em file} diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 4b2b8660c2..0a243308d5 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -1075,26 +1075,6 @@ perform a {\tt Ltac \ident\ := {\rm\sl convtactic}}. \SeeAlso sections \ref{Conversion-tactics} -\subsection{\tt Set Virtual Machine -\label{SetVirtualMachine} -\optindex{Virtual Machine}} - -This activates the bytecode-based conversion algorithm. - -\subsection{\tt Unset Virtual Machine -\optindex{Virtual Machine}} - -This deactivates the bytecode-based conversion algorithm. - -\subsection{\tt Test Virtual Machine -\optindex{Virtual Machine}} - -This tells if the bytecode-based conversion algorithm is -activated. The default behavior is to have the bytecode-based -conversion algorithm deactivated. - -\SeeAlso sections~\ref{vmcompute} and~\ref{vmoption}. - \section{Controlling the locality of commands} \subsection{{\tt Local}, {\tt Global} -- cgit v1.2.3 From 119d61453c6761f20b8862f47334bfb8fae0049e Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 11 Dec 2015 12:17:14 +0100 Subject: Document removal of Set Virtual Machine and -vm in CHANGES. --- CHANGES | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES b/CHANGES index 389572014e..f31f4efa88 100644 --- a/CHANGES +++ b/CHANGES @@ -24,6 +24,7 @@ Vernacular commands declaration of all polymorphic universes appearing in a definition when introducing it. - New command "Show id" to show goal named id. +- Option "Virtual Machine" removed. Tactics @@ -82,6 +83,7 @@ Tools - The -require and -load-vernac-object command-line options now take a logical path of a given library rather than a physical path, thus they behave like Require [Import] path. +- The -vm command-line option has been removed. Standard Library -- cgit v1.2.3 From 3c81c6c3b595ef06e0c01e51775aa0118f44e421 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 11 Dec 2015 17:59:42 +0100 Subject: Univs: Fix bug #4363, nested abstract. --- proofs/proof_global.ml | 3 ++- test-suite/bugs/closed/4363.v | 7 +++++++ 2 files changed, 9 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4363.v diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3d60ff217a..3edd34e5f6 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -333,7 +333,8 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = (* For vi2vo compilation proofs are computed now but we need to * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) - let ctx_body = restrict_universe_context ctx used_univs_body in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let ctx_body = restrict_universe_context ctx used_univs in (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in diff --git a/test-suite/bugs/closed/4363.v b/test-suite/bugs/closed/4363.v new file mode 100644 index 0000000000..75a9c9a041 --- /dev/null +++ b/test-suite/bugs/closed/4363.v @@ -0,0 +1,7 @@ +Set Printing Universes. +Definition foo : Type. +Proof. + assert (H : Set) by abstract (assert Type by abstract exact Type using bar; exact nat). + exact bar. +Defined. (* Toplevel input, characters 0-8: +Error: \ No newline at end of file -- cgit v1.2.3 From c6b75e1b693ab8c7af2efd1b93f04eab248e584c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 11 Dec 2015 19:28:04 +0100 Subject: Optimize occur_evar_upto_types, avoiding repeateadly looking into the same evar. --- pretyping/evarsolve.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index aeb2445d1c..fe26dcd282 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1286,10 +1286,16 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = | l -> evd let occur_evar_upto_types sigma n c = + let seen = ref Evar.Set.empty in let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur - | Evar e -> Option.iter occur_rec (existential_opt_value sigma e); - occur_rec (existential_type sigma e) + | Evar (sp,args as e) -> + if Evar.Set.mem sp !seen then + Array.iter occur_rec args + else ( + seen := Evar.Set.add sp !seen; + Option.iter occur_rec (existential_opt_value sigma e); + occur_rec (existential_type sigma e)) | _ -> iter_constr occur_rec c in try occur_rec c; false with Occur -> true -- cgit v1.2.3 From 72bb3992d912df33bac34f3a1c21989edcf9aa02 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 12 Dec 2015 14:53:00 +0100 Subject: Indexing and documenting some options. --- doc/refman/RefMan-ext.tex | 10 ++++++++++ doc/refman/RefMan-sch.tex | 6 ++++++ doc/refman/Universes.tex | 3 ++- 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index a718a26ea5..f2ab79dced 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -226,6 +226,7 @@ Definition c := {| y := 3; x := 5 |}. This syntax can be disabled globally for printing by \begin{quote} {\tt Unset Printing Records.} +\optindex{Printing Records} \end{quote} For a given type, one can override this using either \begin{quote} @@ -284,6 +285,9 @@ To deactivate the printing of projections, use {\tt Unset Printing Projections}. \subsection{Primitive Projections} +\optindex{Primitive Projections} +\optindex{Printing Primitive Projection Parameters} +\optindex{Printing Primitive Projection Compatibility} \index{Primitive projections} \label{prim-proj} @@ -314,6 +318,12 @@ for the usual defined ones. % - [pattern x at n], [rewrite x at n] and in general abstraction and selection % of occurrences may fail due to the disappearance of parameters. +For compatibility, the parameters still appear to the user when printing terms +even though they are absent in the actual AST manipulated by the kernel. This +can be changed by unsetting the {\tt Printing Primitive Projection Parameters} +flag. Further compatibility printing can be deactivated thanks to the +{\tt Printing Primitive Projection Compatibility} option which governs the +printing of pattern-matching over primitive records. \section{Variants and extensions of {\mbox{\tt match}} \label{Extensions-of-match} diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex index 571e16d578..53aa6b86ab 100644 --- a/doc/refman/RefMan-sch.tex +++ b/doc/refman/RefMan-sch.tex @@ -126,6 +126,8 @@ conclusion is {\tt (n:nat)(even n)->(Q n)}. \optindex{Boolean Equality Schemes} \optindex{Elimination Schemes} \optindex{Nonrecursive Elimination Schemes} +\optindex{Case Analysis Schemes} +\optindex{Decidable Equality Schemes} \label{set-nonrecursive-elimination-schemes} } @@ -139,6 +141,10 @@ and {\tt Record} (see~\ref{Record}) do not have an automatic declaration of the induction principles. It can be activated with the command {\tt Set Nonrecursive Elimination Schemes}. It can be deactivated again with {\tt Unset Nonrecursive Elimination Schemes}. + +In addition, the {\tt Case Analysis Schemes} flag governs the generation of +case analysis lemmas for inductive types, i.e. corresponding to the +pattern-matching term alone and without fixpoint. \\ You can also activate the automatic declaration of those Boolean equalities diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index ea3cca77ed..a08cd1475a 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -159,6 +159,7 @@ unification can have different unfolding behaviors on the same development with universe polymorphism switched on or off. \asection{Minimization} +\optindex{Universe Minimization ToSet} Universe polymorphism with cumulativity tends to generate many useless inclusion constraints in general. Typically at each application of a @@ -248,7 +249,7 @@ User-named universes are considered rigid for unification and are never minimized. \subsection{\tt Unset Strict Universe Declaration. - \optindex{StrictUniverseDeclaration} + \optindex{Strict Universe Declaration} \label{StrictUniverseDeclaration}} The command \texttt{Unset Strict Universe Declaration} allows one to -- cgit v1.2.3 From 0e4f4788f710d58754b1909395b1fe9d5e001d69 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 12 Dec 2015 18:16:01 +0100 Subject: Removing dead unsafe code in Genarg. --- lib/genarg.ml | 8 -------- lib/genarg.mli | 20 -------------------- 2 files changed, 28 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index 42458ecb31..149d872c52 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -225,11 +225,3 @@ let register_name0 t name = match t with let get_name0 name = String.Map.find name !arg0_names - -module Unsafe = -struct - -let inj tpe x = (tpe, x) -let prj (_, x) = x - -end diff --git a/lib/genarg.mli b/lib/genarg.mli index a269f92774..3a18581d7b 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -256,23 +256,3 @@ val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit val get_name0 : string -> string (** Return the absolute path of a given witness. *) - -(** {5 Unsafe loophole} *) - -module Unsafe : -sig - -(** Unsafe magic functions. Not for kids. This is provided here as a loophole to - escape this module. Do NOT use outside of the dedicated areas. NOT. EVER. *) - -val inj : argument_type -> Obj.t -> 'lev generic_argument -(** Injects an object as generic argument. !!!BEWARE!!! only do this as - [inj tpe x] where: - - 1. [tpe] is the reification of a [('a, 'b, 'c) genarg_type]; - 2. [x] has type ['a], ['b] or ['c] according to the return level ['lev]. *) - -val prj : 'lev generic_argument -> Obj.t -(** Recover the contents of a generic argument. *) - -end -- cgit v1.2.3 From 5550d920b831ec080cac236840132770bf1ba754 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sat, 28 Nov 2015 10:16:54 +0100 Subject: Extraction: avoid generating some blanks at end-of-line --- plugins/extraction/ocaml.ml | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 8c482b4b1d..45f5614af2 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -74,7 +74,7 @@ let preamble _ comment used_modules usf = (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) let sig_preamble _ comment used_modules usf = - pp_header_comment comment ++ fnl () ++ fnl () ++ + pp_header_comment comment ++ prlist pp_open used_modules ++ (if List.is_empty used_modules then mt () else fnl ()) ++ (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) @@ -524,13 +524,13 @@ let pp_decl = function let ids, def = try let ids,s = find_type_custom r in - pp_string_parameters ids, str "=" ++ spc () ++ str s + pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> pp_parameters l, - if t == Taxiom then str "(* AXIOM TO BE REALIZED *)" - else str "=" ++ spc () ++ pp_type false l t + if t == Taxiom then str " (* AXIOM TO BE REALIZED *)" + else str " =" ++ spc () ++ pp_type false l t in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + hov 2 (str "type " ++ ids ++ name ++ def) | Dterm (r, a, t) -> let def = if is_custom r then str (" = " ^ find_custom r) @@ -577,15 +577,15 @@ let pp_spec = function let ids, def = try let ids, s = find_type_custom r in - pp_string_parameters ids, str "= " ++ str s + pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> let ids = pp_parameters l in match ot with | None -> ids, mt () - | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" - | Some t -> ids, str "=" ++ spc () ++ pp_type false l t + | Some Taxiom -> ids, str " (* AXIOM TO BE REALIZED *)" + | Some t -> ids, str " =" ++ spc () ++ pp_type false l t in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + hov 2 (str "type " ++ ids ++ name ++ def) let pp_alias_spec ren = function | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } @@ -602,7 +602,7 @@ let rec pp_specif = function | (l,Spec s) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++ + hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_spec ren s with Not_found -> pp_spec s) @@ -610,15 +610,15 @@ let rec pp_specif = function let def = pp_module_type [] mt in let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++ + hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def') + fnl () ++ hov 1 (str ("module "^ren^" :") ++ fnl () ++ def') with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name @@ -641,7 +641,7 @@ and pp_module_type params = function let l = List.fold_left try_pp_specif [] sign in let l = List.rev l in pop_visible (); - str "sig " ++ fnl () ++ + str "sig" ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> @@ -672,7 +672,7 @@ let rec pp_structure_elem = function | (l,SEdecl d) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++ + hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_decl ren d with Not_found -> pp_decl d) @@ -686,8 +686,8 @@ let rec pp_structure_elem = function let def = pp_module_expr [] m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 - (str "module " ++ name ++ typ ++ str " = " ++ - (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ + (str "module " ++ name ++ typ ++ str " =" ++ + (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module "^ren^" = ") ++ name @@ -695,7 +695,7 @@ let rec pp_structure_elem = function | (l,SEmodtype m) -> let def = pp_module_type [] m in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name @@ -719,7 +719,7 @@ and pp_module_expr params = function let l = List.fold_left try_pp_structure_elem [] sel in let l = List.rev l in pop_visible (); - str "struct " ++ fnl () ++ + str "struct" ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" -- cgit v1.2.3 From e2915d2e615a271c90d9e8c8599a428ed15828b5 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sun, 29 Nov 2015 01:05:06 +0100 Subject: Extraction: fix for bug #4334 (use of delta_resolver in Extract_env) The ind_equiv field wasn't correctly set, due to some kernel names glitches (canonical vs. user). The fix is to take into account the delta_resolver while traversing module structures. --- plugins/extraction/extract_env.ml | 113 +++++++++++++++++++------------------- 1 file changed, 58 insertions(+), 55 deletions(-) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 0f846013b2..1d7f614564 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -78,56 +78,51 @@ module type VISIT = sig (* Add reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) val add_ref : global_reference -> unit + val add_kn : kernel_name -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit (* Test functions: is a particular object a needed dependency for the current extraction ? *) val needed_ind : mutual_inductive -> bool - val needed_con : constant -> bool + val needed_cst : constant -> bool val needed_mp : module_path -> bool val needed_mp_all : module_path -> bool end module Visit : VISIT = struct type must_visit = - { mutable ind : KNset.t; mutable con : KNset.t; - mutable mp : MPset.t; mutable mp_all : MPset.t } + { mutable kn : KNset.t; + mutable mp : MPset.t; + mutable mp_all : MPset.t } (* the imperative internal visit lists *) - let v = { ind = KNset.empty ; con = KNset.empty ; - mp = MPset.empty; mp_all = MPset.empty } + let v = { kn = KNset.empty; mp = MPset.empty; mp_all = MPset.empty } (* the accessor functions *) let reset () = - v.ind <- KNset.empty; - v.con <- KNset.empty; + v.kn <- KNset.empty; v.mp <- MPset.empty; v.mp_all <- MPset.empty - let needed_ind i = KNset.mem (user_mind i) v.ind - let needed_con c = KNset.mem (user_con c) v.con + let needed_ind i = KNset.mem (user_mind i) v.kn + let needed_cst c = KNset.mem (user_con c) v.kn let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all let needed_mp_all mp = MPset.mem mp v.mp_all let add_mp mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp let add_mp_all mp = - check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp; + check_loaded_modfile mp; + v.mp <- MPset.union (prefixes_mp mp) v.mp; v.mp_all <- MPset.add mp v.mp_all - let add_ind i = - let kn = user_mind i in - v.ind <- KNset.add kn v.ind; add_mp (modpath kn) - let add_con c = - let kn = user_con c in - v.con <- KNset.add kn v.con; add_mp (modpath kn) + let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn) let add_ref = function - | ConstRef c -> add_con c - | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_ind ind + | ConstRef c -> add_kn (user_con c) + | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_kn (user_mind ind) | VarRef _ -> assert false let add_decl_deps = decl_iter_references add_ref add_ref add_ref let add_spec_deps = spec_iter_references add_ref add_ref add_ref end let add_field_label mp = function - | (lab, SFBconst _) -> Visit.add_ref (ConstRef (Constant.make2 mp lab)) - | (lab, SFBmind _) -> Visit.add_ref (IndRef (MutInd.make2 mp lab, 0)) + | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make2 mp lab) | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab)) let rec add_labels mp = function @@ -193,36 +188,44 @@ let rec mp_of_mexpr = function | MEwith (seb,_) -> mp_of_mexpr seb | _ -> assert false +let no_delta = Mod_subst.empty_delta_resolver + let env_for_mtb_with_def env mp me idl = let struc = Modops.destr_nofunctor me in let l = Label.of_id (List.hd idl) in let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in let before = fst (List.split_when spot struc) in - Modops.add_structure mp before empty_delta_resolver env + Modops.add_structure mp before no_delta env + +let make_cst resolver mp l = + Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp l) + +let make_mind resolver mp l = + Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp l) (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) -let rec extract_structure_spec env mp = function +let rec extract_structure_spec env mp reso = function | [] -> [] | (l,SFBconst cb) :: msig -> - let kn = Constant.make2 mp l in - let s = extract_constant_spec env kn cb in - let specs = extract_structure_spec env mp msig in + let c = make_cst reso mp l in + let s = extract_constant_spec env c cb in + let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmind _) :: msig -> - let mind = MutInd.make2 mp l in + let mind = make_mind reso mp l in let s = Sind (mind, extract_inductive env mind) in - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mb.mod_mp mb in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mtb.mod_mp mtb in (l,Smodtype spec) :: specs @@ -244,7 +247,7 @@ and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all mp; MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) - | MEapply _ -> extract_msignature_spec env mp1 me_struct + | MEapply _ -> extract_msignature_spec env mp1 no_delta (*TODO*) me_struct and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> @@ -258,19 +261,19 @@ and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with extract_mexpression_spec env' mp1 (me_struct',me_alg')) | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m) -and extract_msignature_spec env mp1 = function +and extract_msignature_spec env mp1 reso = function | NoFunctor struc -> - let env' = Modops.add_structure mp1 struc empty_delta_resolver env in - MTsig (mp1, extract_structure_spec env' mp1 struc) + let env' = Modops.add_structure mp1 struc reso env in + MTsig (mp1, extract_structure_spec env' mp1 reso struc) | MoreFunctor (mbid, mtb, me) -> let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in MTfunsig (mbid, extract_mbody_spec env mp mtb, - extract_msignature_spec env' mp1 me) + extract_msignature_spec env' mp1 reso me) and extract_mbody_spec env mp mb = match mb.mod_type_alg with | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty) - | None -> extract_msignature_spec env mp mb.mod_type + | None -> extract_msignature_spec env mp mb.mod_delta mb.mod_type (* From a [structure_body] (i.e. a list of [structure_field_body]) to implementations. @@ -279,31 +282,31 @@ and extract_mbody_spec env mp mb = match mb.mod_type_alg with important: last to first ensures correct dependencies. *) -let rec extract_structure env mp ~all = function +let rec extract_structure env mp reso ~all = function | [] -> [] | (l,SFBconst cb) :: struc -> (try let vl,recd,struc = factor_fix env l cb struc in - let vc = Array.map (Constant.make2 mp) vl in - let ms = extract_structure env mp ~all struc in - let b = Array.exists Visit.needed_con vc in + let vc = Array.map (make_cst reso mp) vl in + let ms = extract_structure env mp reso ~all struc in + let b = Array.exists Visit.needed_cst vc in if all || b then let d = extract_fixpoint env vc recd in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> - let ms = extract_structure env mp ~all struc in - let c = Constant.make2 mp l in - let b = Visit.needed_con c in + let ms = extract_structure env mp reso ~all struc in + let c = make_cst reso mp l in + let b = Visit.needed_cst c in if all || b then let d = extract_constant env c cb in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) | (l,SFBmind mib) :: struc -> - let ms = extract_structure env mp ~all struc in - let mind = MutInd.make2 mp l in + let ms = extract_structure env mp reso ~all struc in + let mind = make_mind reso mp l in let b = Visit.needed_ind mind in if all || b then let d = Dind (mind, extract_inductive env mind) in @@ -311,14 +314,14 @@ let rec extract_structure env mp ~all = function else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SFBmodule mb) :: struc -> - let ms = extract_structure env mp ~all struc in + let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in let all' = all || Visit.needed_mp_all mp in if all' || Visit.needed_mp mp then (l,SEmodule (extract_module env mp ~all:all' mb)) :: ms else ms | (l,SFBmodtype mtb) :: struc -> - let ms = extract_structure env mp ~all struc in + let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then (l,SEmodtype (extract_mbody_spec env mp mtb)) :: ms @@ -332,7 +335,7 @@ and extract_mexpr env mp = function (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) - extract_msignature env mp ~all:true (expand_mexpr env mp me) + extract_msignature env mp no_delta ~all:true (expand_mexpr env mp me) | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp_all mp; Miniml.MEident mp @@ -350,17 +353,17 @@ and extract_mexpression env mp = function extract_mbody_spec env mp1 mtb, extract_mexpression env' mp me) -and extract_msignature env mp ~all = function +and extract_msignature env mp reso ~all = function | NoFunctor struc -> - let env' = Modops.add_structure mp struc empty_delta_resolver env in - Miniml.MEstruct (mp,extract_structure env' mp ~all struc) + let env' = Modops.add_structure mp struc reso env in + Miniml.MEstruct (mp,extract_structure env' mp reso ~all struc) | MoreFunctor (mbid, mtb, me) -> let mp1 = MPbound mbid in let env' = Modops.add_module_type mp1 mtb env in Miniml.MEfunctor (mbid, extract_mbody_spec env mp1 mtb, - extract_msignature env' mp ~all me) + extract_msignature env' mp reso ~all me) and extract_module env mp ~all mb = (* A module has an empty [mod_expr] when : @@ -376,8 +379,8 @@ and extract_module env mp ~all mb = (* This module has a signature, otherwise it would be FullStruct. We extract just the elements required by this signature. *) let () = add_labels mp mb.mod_type in - extract_msignature env mp ~all:false sign - | FullStruct -> extract_msignature env mp ~all mb.mod_type + extract_msignature env mp mb.mod_delta ~all:false sign + | FullStruct -> extract_msignature env mp mb.mod_delta ~all mb.mod_type in (* Slight optimization: for modules without explicit signatures ([FullStruct] case), we build the type out of the extracted @@ -399,7 +402,7 @@ let mono_environment refs mpl = let l = List.rev (environment_until None) in List.rev_map (fun (mp,struc) -> - mp, extract_structure env mp ~all:(Visit.needed_mp_all mp) struc) + mp, extract_structure env mp no_delta ~all:(Visit.needed_mp_all mp) struc) l (**************************************) @@ -650,7 +653,7 @@ let extraction_library is_rec m = let l = List.rev (environment_until (Some dir_m)) in let select l (mp,struc) = if Visit.needed_mp mp - then (mp, extract_structure env mp true struc) :: l + then (mp, extract_structure env mp no_delta true struc) :: l else l in let struc = List.fold_left select [] l in -- cgit v1.2.3 From a4d48ce98d7ae0cf07c653ed75700ed6f182936a Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 30 Nov 2015 16:40:46 +0100 Subject: Extraction: check for remaining implicits after dead code removal (fix #4243) --- plugins/extraction/modutil.ml | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 8158ac647e..53c9f59878 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -404,12 +404,16 @@ let optimize_struct to_appear struc = List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) struc in - ignore (struct_ast_search check_implicits opt_struc); - if library () then - List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc - else begin - reset_needed (); - List.iter add_needed (fst to_appear); - List.iter add_needed_mp (snd to_appear); - depcheck_struct opt_struc - end + let mini_struc = + if library () then + List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc + else + begin + reset_needed (); + List.iter add_needed (fst to_appear); + List.iter add_needed_mp (snd to_appear); + depcheck_struct opt_struc + end + in + ignore (struct_ast_search check_implicits mini_struc); + mini_struc -- cgit v1.2.3 From ec5455d7351c05a58ae99d5a300dc8576f8c9360 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 4 Dec 2015 18:39:47 +0100 Subject: Extraction: nicer implementation of Implicits Instead of the original hacks (embedding implicits in string msg in MLexn !) we now use a proper construction MLdummy (Kimplicit (r,i)) to replace the use of the i-th argument of constant or constructor r when this argument has been declared as implicit. A new option Set/Unset Extraction SafeImplicits controls what happens when some implicits still occur after an extraction : fail in safe mode, or otherwise produce some code nonetheless. This code is probably buggish if the implicits are actually used to do anything relevant (match, function call, etc), but it might also be fine if the implicits are just passed along. And anyway, this unsafe mode could help figure what's going on. Note: the MLdummy now expected a kill_reason, just as Tdummy. These kill_reason are now Ktype, Kprop (formerly Kother) and Kimplicit. Some minor refactoring on the fly. --- plugins/extraction/extract_env.ml | 4 +- plugins/extraction/extraction.ml | 70 ++++++++++++------------------ plugins/extraction/haskell.ml | 7 ++- plugins/extraction/json.ml | 2 +- plugins/extraction/miniml.mli | 15 ++++--- plugins/extraction/mlutil.ml | 90 +++++++++++++++++++++------------------ plugins/extraction/mlutil.mli | 5 ++- plugins/extraction/modutil.ml | 23 +++++----- plugins/extraction/ocaml.ml | 9 ++-- plugins/extraction/scheme.ml | 2 +- plugins/extraction/table.ml | 71 ++++++++++++++++++++---------- plugins/extraction/table.mli | 6 +-- 12 files changed, 166 insertions(+), 138 deletions(-) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 1d7f614564..3d32398ffd 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -498,8 +498,8 @@ let print_structure_to_file (fn,si,mo) dry struc = let d = descr () in reset_renaming_tables AllButExternal; let unsafe_needs = { - mldummy = struct_ast_search ((==) MLdummy) struc; - tdummy = struct_type_search Mlutil.isDummy struc; + mldummy = struct_ast_search Mlutil.isMLdummy struc; + tdummy = struct_type_search Mlutil.isTdummy struc; tunknown = struct_type_search ((==) Tunknown) struc; magic = if lang () != Haskell then false diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 1112c3b890..f4d14af624 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -91,7 +91,7 @@ exception NotDefault of kill_reason let check_default env t = match flag_of_type env t with | _,TypeScheme -> raise (NotDefault Ktype) - | Logic,_ -> raise (NotDefault Kother) + | Logic,_ -> raise (NotDefault Kprop) | _ -> () let is_info_scheme env t = match flag_of_type env t with @@ -103,7 +103,7 @@ let is_info_scheme env t = match flag_of_type env t with let rec type_sign env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> - (if is_info_scheme env t then Keep else Kill Kother) + (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] @@ -137,7 +137,7 @@ let rec type_sign_vl env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in - if not (is_info_scheme env t) then Kill Kother::s, vl + if not (is_info_scheme env t) then Kill Kprop::s, vl else Keep::s, (make_typvar n vl) :: vl | _ -> [],[] @@ -154,25 +154,12 @@ let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] - | sign::s -> - let sign' = - if sign == Keep && Int.List.mem i implicits - then Kill Kother else sign - in sign' :: add_impl (succ i) s + | Keep::s when Int.Set.mem i implicits -> + Kill (Kimplicit (r,i)) :: add_impl (i+1) s + | sign::s -> sign :: add_impl (i+1) s in add_impl (1+nb_params) s -(* Enriching a exception message *) - -let rec handle_exn r n fn_name = function - | MLexn s -> - (try Scanf.sscanf s "UNBOUND %d%!" - (fun i -> - assert ((0 < i) && (i <= n)); - MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) - with Scanf.Scan_failure _ | End_of_file -> MLexn s) - | a -> ast_map (handle_exn r n fn_name) a - (*S Management of type variable contexts. *) (* A De Bruijn variable context (db) is a context for translating Coq [Rel] @@ -285,10 +272,10 @@ let rec extract_type env db j c args = (match expand env mld with | Tdummy d -> Tdummy d | _ -> - let reason = if lvl == TypeScheme then Ktype else Kother in + let reason = if lvl == TypeScheme then Ktype else Kprop in Tarr (Tdummy reason, mld))) | Sort _ -> Tdummy Ktype (* The two logical cases. *) - | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kother + | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kprop | Rel n -> (match lookup_rel n env with | (_,Some t,_) -> extract_type env db j (lift n t) args @@ -458,7 +445,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) if p.ip_logical then raise (I Standard); if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); let typ = p.ip_types.(0) in - let l = List.filter (fun t -> not (isDummy (expand env t))) typ in + let l = List.filter (fun t -> not (isTdummy (expand env t))) typ in if not (keep_singleton ()) && Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); @@ -479,7 +466,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let mp = MutInd.modpath kn in let rec select_fields l typs = match l,typs with | [],[] -> [] - | _::l, typ::typs when isDummy (expand env typ) -> + | _::l, typ::typs when isTdummy (expand env typ) -> select_fields l typs | Anonymous::l, typ::typs -> None :: (select_fields l typs) @@ -655,7 +642,7 @@ and extract_maybe_term env mle mlt c = try check_default env (type_of env c); extract_term env mle mlt c [] with NotDefault d -> - put_magic (mlt, Tdummy d) MLdummy + put_magic (mlt, Tdummy d) (MLdummy d) (*s Generic way to deal with an application. *) @@ -723,11 +710,11 @@ and extract_cst_app env mle mlt kn u args = else mla with e when Errors.noncritical e -> mla in - (* For strict languages, purely logical signatures with at least - one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left + (* For strict languages, purely logical signatures lead to a dummy lam + (except when [Kill Ktype] everywhere). So a [MLdummy] is left accordingly. *) let optdummy = match sign_kind s_full with - | UnsafeLogicalSig when lang () != Haskell -> [MLdummy] + | UnsafeLogicalSig when lang () != Haskell -> [MLdummy Kprop] | _ -> [] in (* Different situations depending of the number of arguments: *) @@ -826,8 +813,8 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* Logical singleton case: *) (* [match c with C i j k -> t] becomes [t'] *) assert (Int.equal br_size 1); - let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in - let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in + let s = iterate (fun l -> Kill Kprop :: l) ni.(0) [] in + let mlt = iterate (fun t -> Tarr (Tdummy Kprop, t)) ni.(0) mlt in let e = extract_maybe_term env mle mlt br.(0) in snd (case_expunge s e) end @@ -851,8 +838,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) let ids,e = case_expunge s e in - let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in - (List.rev ids, Pusual r, e') + (List.rev ids, Pusual r, e) in if mi.ind_kind == Singleton then begin @@ -960,8 +946,6 @@ let extract_std_constant env kn body typ = let e = extract_term env mle t' c [] in (* Expunging term and type from dummy lambdas. *) let trm = term_expunge s (ids,e) in - let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm - in trm, type_expunge_from_sign env s t (* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) @@ -979,8 +963,8 @@ let extract_axiom env kn typ = let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in - let types = Array.make n (Tdummy Kother) - and terms = Array.make n MLdummy in + let types = Array.make n (Tdummy Kprop) + and terms = Array.make n (MLdummy Kprop) in let kns = Array.to_list vkn in current_fixpoints := kns; (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) @@ -1022,7 +1006,7 @@ let extract_constant env kn cb = in match flag_of_type env typ with | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype) - | (Logic,Default) -> warn_log (); Dterm (r, MLdummy, Tdummy Kother) + | (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop) | (Info,TypeScheme) -> (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () @@ -1047,7 +1031,7 @@ let extract_constant_spec env kn cb = let typ = Typeops.type_of_constant_type env cb.const_type in match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) - | (Logic, Default) -> Sval (r, Tdummy Kother) + | (Logic, Default) -> Sval (r, Tdummy Kprop) | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in (match cb.const_body with @@ -1075,8 +1059,8 @@ let extract_constr env c = reset_meta_count (); let typ = type_of env c in match flag_of_type env typ with - | (_,TypeScheme) -> MLdummy, Tdummy Ktype - | (Logic,_) -> MLdummy, Tdummy Kother + | (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype + | (Logic,_) -> MLdummy Kprop, Tdummy Kprop | (Info,Default) -> let mlt = extract_type env [] 1 typ [] in extract_term env Mlenv.empty mlt c [], mlt @@ -1090,7 +1074,7 @@ let extract_inductive env kn = | [] -> [] | t::l -> let l' = filter (succ i) l in - if isDummy (expand env t) || Int.List.mem i implicits then l' + if isTdummy (expand env t) || Int.Set.mem i implicits then l' else t::l' in filter (1+ind.ind_nparams) l in @@ -1102,11 +1086,11 @@ let extract_inductive env kn = (*s Is a [ml_decl] logical ? *) let logical_decl = function - | Dterm (_,MLdummy,Tdummy _) -> true + | Dterm (_,MLdummy _,Tdummy _) -> true | Dtype (_,[],Tdummy _) -> true | Dfix (_,av,tv) -> - (Array.for_all ((==) MLdummy) av) && - (Array.for_all isDummy tv) + (Array.for_all isMLdummy av) && + (Array.for_all isTdummy tv) | Dind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 37b4142073..530eb2ff89 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -200,8 +200,11 @@ let rec pp_expr par env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "Prelude.error" ++ spc () ++ qs s) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLdummy k -> + (* An [MLdummy] may be applied, but I don't really care. *) + (match msg_of_implicit k with + | "" -> str "__" + | s -> str "__" ++ spc () ++ pp_bracket_comment (str s)) | MLmagic a -> pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index 125dc86b82..df79c585e5 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -153,7 +153,7 @@ let rec json_expr env = function ("what", json_str "expr:exception"); ("msg", json_str s) ] - | MLdummy -> json_dict [("what", json_str "expr:dummy")] + | MLdummy _ -> json_dict [("what", json_str "expr:dummy")] | MLmagic a -> json_dict [ ("what", json_str "expr:coerce"); ("value", json_expr env a) diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index b7dee6cb14..681dceaa04 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -16,11 +16,16 @@ open Globnames object expects, and what these arguments will become in the ML object. *) -(* We eliminate from terms: 1) types 2) logical parts. - [Kother] stands both for logical or other reasons - (for instance user-declared implicit arguments w.r.t. extraction). *) +(* We eliminate from terms: + 1) types + 2) logical parts + 3) user-declared implicit arguments of a constant of constructor +*) -type kill_reason = Ktype | Kother +type kill_reason = + | Ktype + | Kprop + | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -118,7 +123,7 @@ and ml_ast = | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array | MLexn of string - | MLdummy + | MLdummy of kill_reason | MLaxiom | MLmagic of ml_ast diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 6fc1195fba..402370eece 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -299,10 +299,12 @@ let type_to_signature env t = let isKill = function Kill _ -> true | _ -> false -let isDummy = function Tdummy _ -> true | _ -> false +let isTdummy = function Tdummy _ -> true | _ -> false + +let isMLdummy = function MLdummy _ -> true | _ -> false let sign_of_id = function - | Dummy -> Kill Kother + | Dummy -> Kill Kprop | _ -> Keep (* Classification of signatures *) @@ -310,45 +312,44 @@ let sign_of_id = function type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) - | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) + | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) let rec sign_kind = function | [] -> EmptySig | Keep :: _ -> NonLogicalSig | Kill k :: s -> - match sign_kind s with - | NonLogicalSig -> NonLogicalSig - | UnsafeLogicalSig -> UnsafeLogicalSig - | SafeLogicalSig | EmptySig -> - if k == Kother then UnsafeLogicalSig else SafeLogicalSig + match k, sign_kind s with + | _, NonLogicalSig -> NonLogicalSig + | Ktype, (SafeLogicalSig | EmptySig) -> SafeLogicalSig + | _, _ -> UnsafeLogicalSig (* Removing the final [Keep] in a signature *) let rec sign_no_final_keeps = function | [] -> [] | k :: s -> - let s' = k :: sign_no_final_keeps s in - match s' with [Keep] -> [] | _ -> s' + match k, sign_no_final_keeps s with + | Keep, [] -> [] + | k, l -> k::l (*s Removing [Tdummy] from the top level of a ML type. *) let type_expunge_from_sign env s t = - let rec expunge s t = - if List.is_empty s then t else match t with - | Tmeta {contents = Some t} -> expunge s t - | Tarr (a,b) -> - let t = expunge (List.tl s) b in - if List.hd s == Keep then Tarr (a, t) else t - | Tglob (r,l) -> - (match env r with - | Some mlt -> expunge s (type_subst_list l mlt) - | None -> assert false) - | _ -> assert false + let rec expunge s t = match s, t with + | [], _ -> t + | Keep :: s, Tarr(a,b) -> Tarr (a, expunge s b) + | Kill _ :: s, Tarr(a,b) -> expunge s b + | _, Tmeta {contents = Some t} -> expunge s t + | _, Tglob (r,l) -> + (match env r with + | Some mlt -> expunge s (type_subst_list l mlt) + | None -> assert false) + | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in if lang () != Haskell && sign_kind s == UnsafeLogicalSig then - Tarr (Tdummy Kother, t) + Tarr (Tdummy Kprop, t) else t let type_expunge env t = @@ -385,7 +386,7 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLfix (i1, id1, t1), MLfix (i2, id2, t2) -> Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2 | MLexn e1, MLexn e2 -> String.equal e1 e2 -| MLdummy, MLdummy -> true +| MLdummy k1, MLdummy k2 -> k1 == k2 | MLaxiom, MLaxiom -> true | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | _ -> false @@ -420,7 +421,7 @@ let ast_iter_rel f = | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () in iter 0 (*s Map over asts. *) @@ -439,7 +440,7 @@ let ast_map f = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Map over asts, with binding depth as parameter. *) @@ -457,7 +458,7 @@ let ast_map_lift f n = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Iter over asts. *) @@ -471,7 +472,7 @@ let ast_iter f = function | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () (*S Operations concerning De Bruijn indices. *) @@ -507,7 +508,7 @@ let nb_occur_match = | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 in nb 1 (*s Lifting on terms. @@ -559,7 +560,7 @@ let gen_subst v d t = if i' < 1 then a else if i' <= Array.length v then match v.(i'-1) with - | None -> MLexn ("UNBOUND " ^ string_of_int i') + | None -> assert false | Some u -> ast_lift n u else MLrel (i+d) | a -> ast_map_lift subst n a @@ -813,8 +814,8 @@ let census_add, census_max, census_clean = try h := add k i !h with Not_found -> h := (k, Int.Set.singleton i) :: !h in - let maxf k = - let len = ref 0 and lst = ref Int.Set.empty and elm = ref k in + let maxf () = + let len = ref 0 and lst = ref Int.Set.empty and elm = ref MLaxiom in List.iter (fun (e, s) -> let n = Int.Set.cardinal s in @@ -843,7 +844,7 @@ let factor_branches o typ br = if o.opt_case_cst then (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); done; - let br_factor, br_set = census_max MLdummy in + let br_factor, br_set = census_max () in census_clean (); let n = Int.Set.cardinal br_set in if Int.equal n 0 then None @@ -926,7 +927,7 @@ let iota_gen br hd = in iota 0 hd let is_atomic = function - | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ -> true | _ -> false let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false @@ -998,7 +999,7 @@ and simpl_app o a = function let a' = List.map (ast_lift k) a in (l, p, simpl o (MLapp (t,a')))) br in simpl o (MLcase (typ,e,br')) - | (MLdummy | MLexn _) as e -> e + | (MLdummy _ | MLexn _) as e -> e (* We just discard arguments in those cases. *) | f -> MLapp (f,a) @@ -1049,20 +1050,26 @@ let rec select_via_bl l args = match l,args with (*s [kill_some_lams] removes some head lambdas according to the signature [bl]. This list is build on the identifier list model: outermost lambda is on the right. - [Rels] corresponding to removed lambdas are supposed not to occur, and + [Rels] corresponding to removed lambdas are not supposed to occur + (except maybe in the case of Kimplicit), and the other [Rels] are made correct via a [gen_subst]. Output is not directly a [ml_ast], compose with [named_lams] if needed. *) +let is_impl_kill = function Kill (Kimplicit _) -> true | _ -> false + let kill_some_lams bl (ids,c) = let n = List.length bl in let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in if Int.equal n n' then ids,c - else if Int.equal n' 0 then [],ast_lift (-n) c + else if Int.equal n' 0 && not (List.exists is_impl_kill bl) + then [],ast_lift (-n) c else begin let v = Array.make n None in let rec parse_ids i j = function | [] -> () | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l + | Kill (Kimplicit _ as k) :: l -> + v.(i) <- Some (MLdummy k); parse_ids (i+1) j l | Kill _ :: l -> parse_ids (i+1) j l in parse_ids 0 1 bl; select_via_bl bl ids, gen_subst v (n'-n) c @@ -1100,12 +1107,12 @@ let eta_expansion_sign s (ids,c) = let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l - | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l + | Kill k :: l -> abs (Dummy :: ids) (MLdummy k :: rels) (i+1) l in abs ids [] 1 s (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas - corresponding to [Del] in [s]. *) + corresponding to [Kill _] in [s]. *) let case_expunge s e = let m = List.length s in @@ -1123,8 +1130,9 @@ let term_expunge s (ids,c) = if List.is_empty s then c else let ids,c = kill_some_lams (List.rev s) (ids,c) in - if List.is_empty ids && lang () != Haskell && List.mem (Kill Kother) s then - MLlam (Dummy, ast_lift 1 c) + if List.is_empty ids && lang () != Haskell && + sign_kind s == UnsafeLogicalSig + then MLlam (Dummy, ast_lift 1 c) else named_lams ids c (*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and @@ -1267,7 +1275,7 @@ let rec ml_size = function | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t - | MLglob _ | MLrel _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 0a71d2c838..c380dfb3e3 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -67,7 +67,8 @@ val type_expunge : abbrev_map -> ml_type -> ml_type val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type val eq_ml_type : ml_type -> ml_type -> bool -val isDummy : ml_type -> bool +val isTdummy : ml_type -> bool +val isMLdummy : ml_ast -> bool val isKill : sign -> bool val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast @@ -125,8 +126,8 @@ exception Impossible type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) - | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) + | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) val sign_kind : signature -> sign_kind diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 53c9f59878..e8383bda59 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -100,7 +100,7 @@ let ast_iter_references do_term do_cons do_type a = Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ - | MLdummy | MLaxiom | MLmagic _ -> () + | MLdummy _ | MLaxiom | MLmagic _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = @@ -387,16 +387,15 @@ let is_prefix pre s = in is_prefix_aux 0 -let check_implicits = function - | MLexn s -> - if String.length s > 8 && (s.[0] == 'U' || s.[0] == 'I') then - begin - if is_prefix "UNBOUND" s then assert false; - if is_prefix "IMPLICIT" s then - error_non_implicit (String.sub s 9 (String.length s - 9)); - end; - false - | _ -> false +exception RemainingImplicit of kill_reason + +let check_for_remaining_implicits struc = + let check = function + | MLdummy (Kimplicit _ as k) -> raise (RemainingImplicit k) + | _ -> false + in + try ignore (struct_ast_search check struc) + with RemainingImplicit k -> err_or_warn_remaining_implicit k let optimize_struct to_appear struc = let subst = ref (Refmap'.empty : ml_ast Refmap'.t) in @@ -415,5 +414,5 @@ let optimize_struct to_appear struc = depcheck_struct opt_struc end in - ignore (struct_ast_search check_implicits mini_struc); + let () = check_for_remaining_implicits mini_struc in mini_struc diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 45f5614af2..257c6e9716 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -199,8 +199,11 @@ let rec pp_expr par env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLdummy k -> + (* An [MLdummy] may be applied, but I don't really care. *) + (match msg_of_implicit k with + | "" -> str "__" + | s -> str "__" ++ spc () ++ str ("(* "^s^" *)")) | MLmagic a -> pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) | MLaxiom -> @@ -352,7 +355,7 @@ and pp_function env t = | MLcase(Tglob(r,_),MLrel 1,pv) when not (is_coinductive r) && List.is_empty (get_record_fields r) && not (is_custom_match pv) -> - if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then + if not (ast_occurs 1 (MLcase(Tunknown,MLaxiom,pv))) then pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ v 0 (pp_pat env' pv) diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index cc8b6d8e79..4901cf1807 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -126,7 +126,7 @@ let rec pp_expr env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) paren (str "error" ++ spc () ++ qs s) - | MLdummy -> + | MLdummy _ -> str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> pp_expr env args a diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index a57c39eef1..63d792e363 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -401,16 +401,34 @@ let error_MPfile_as_mod mp b = "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) -let msg_non_implicit r n id = - let name = match id with - | Anonymous -> "" - | Name id -> "(" ^ Id.to_string id ^ ") " - in - "The " ^ (String.ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) - -let error_non_implicit msg = - err (str (msg ^ " still occurs after extraction.") ++ - fnl () ++ str "Please check the Extraction Implicit declarations.") +let argnames_of_global r = + let typ = Global.type_of_global_unsafe r in + let rels,_ = + decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in + List.rev_map fst rels + +let msg_of_implicit = function + | Kimplicit (r,i) -> + let name = match List.nth (argnames_of_global r) (i-1) with + | Anonymous -> "" + | Name id -> "(" ^ Id.to_string id ^ ") " + in + (String.ordinal i)^" argument "^name^"of "^(string_of_global r) + | Ktype | Kprop -> "" + +let error_remaining_implicit k = + let s = msg_of_implicit k in + err (str ("An implicit occurs after extraction : "^s^".") ++ fnl () ++ + str "Please check your Extraction Implicit declarations." ++ fnl() ++ + str "You might also try Unset Extraction SafeImplicits to force" ++ + fnl() ++ str "the extraction of unsafe code and review it manually.") + +let warning_remaining_implicit k = + let s = msg_of_implicit k in + msg_warning + (str ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++ + str "Extraction SafeImplicits is unset, extracting nonetheless," ++ fnl () + ++ str "but this code is potentially unsafe, please review it manually.") let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> @@ -635,32 +653,39 @@ let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) (*s Extraction Implicit *) +let safe_implicit = my_bool_option "SafeImplicits" true + +let err_or_warn_remaining_implicit k = + if safe_implicit () then + error_remaining_implicit k + else + warning_remaining_implicit k + type int_or_id = ArgInt of int | ArgId of Id.t let implicits_table = Summary.ref Refmap'.empty ~name:"ExtrImplicit" let implicits_of_global r = - try Refmap'.find r !implicits_table with Not_found -> [] + try Refmap'.find r !implicits_table with Not_found -> Int.Set.empty let add_implicits r l = - let typ = Global.type_of_global_unsafe r in - let rels,_ = - decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in - let names = List.rev_map fst rels in + let names = argnames_of_global r in let n = List.length names in - let check = function + let add_arg s = function | ArgInt i -> - if 1 <= i && i <= n then i + if 1 <= i && i <= n then Int.Set.add i s else err (int i ++ str " is not a valid argument number for " ++ safe_pr_global r) | ArgId id -> - (try List.index Name.equal (Name id) names - with Not_found -> - err (str "No argument " ++ pr_id id ++ str " for " ++ - safe_pr_global r)) + try + let i = List.index Name.equal (Name id) names in + Int.Set.add i s + with Not_found -> + err (str "No argument " ++ pr_id id ++ str " for " ++ + safe_pr_global r) in - let l' = List.map check l in - implicits_table := Refmap'.add r l' !implicits_table + let ints = List.fold_left add_arg Int.Set.empty l in + implicits_table := Refmap'.add r ints !implicits_table (* Registration of operations for rollback. *) diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 648f232114..a6734dae86 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -38,8 +38,8 @@ val error_MPfile_as_mod : module_path -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit val check_loaded_modfile : module_path -> unit -val msg_non_implicit : global_reference -> int -> Name.t -> string -val error_non_implicit : string -> 'a +val msg_of_implicit : kill_reason -> string +val err_or_warn_remaining_implicit : kill_reason -> unit val info_file : string -> unit @@ -166,7 +166,7 @@ val to_keep : global_reference -> bool (*s Table for implicits arguments *) -val implicits_of_global : global_reference -> int list +val implicits_of_global : global_reference -> Int.Set.t (*s Table for user-given custom ML extractions. *) -- cgit v1.2.3 From a275da6e67b91d9ccae0a952eb1feab2e122076e Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Sun, 6 Dec 2015 12:41:55 +0100 Subject: Extraction: documentation of the new option Unset Extraction SafeImplicits --- doc/refman/Extraction.tex | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 74c8374de4..a963662f64 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -198,6 +198,11 @@ this constant is not declared in the generated file. \asubsection{Extra elimination of useless arguments} +The following command provides some extra manual control on the +code elimination performed during extraction, in a way which +is independent but complementary to the main elimination +principles of extraction (logical parts and types). + \begin{description} \item \comindex{Extraction Implicit} {\tt Extraction Implicit} \qualid\ [ \ident$_1$ \dots\ \ident$_n$ ]. @@ -207,12 +212,27 @@ This experimental command allows declaring some arguments of be removed by extraction. Here \qualid\ can be any function or inductive constructor, and \ident$_i$ are the names of the concerned arguments. In fact, an argument can also be referred by a number -indicating its position, starting from 1. When an actual extraction -takes place, an error is raised if the {\tt Extraction Implicit} +indicating its position, starting from 1. +\end{description} + +When an actual extraction takes place, an error is normally raised if the +{\tt Extraction Implicit} declarations cannot be honored, that is if any of the implicited -variables still occurs in the final code. This declaration of useless -arguments is independent but complementary to the main elimination -principles of extraction (logical parts and types). +variables still occurs in the final code. This behavior can be relaxed +via the following option: + +\begin{description} +\item \optindex{Extraction SafeImplicits} {\tt Unset Extraction SafeImplicits.} + +Default is Set. When this option is Unset, a warning is emitted +instead of an error if some implicited variables still occur in the +final code of an extraction. This way, the extracted code may be +obtained nonetheless and reviewed manually to locate the source of the issue +(in the code, some comments mark the location of these remaining +implicited variables). +Note that this extracted code might not compile or run properly, +depending of the use of these remaining implicited variables. + \end{description} \asubsection{Realizing axioms}\label{extraction:axioms} -- cgit v1.2.3 From 7ae0748586fe8291f0666cce7bd39d7109471d08 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 13 Dec 2015 18:17:38 +0100 Subject: More code sharing between tactic notation and genarg interpretation. --- tactics/tacinterp.ml | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 966408939d..b2afba4af8 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1087,9 +1087,6 @@ let rec read_match_rule lfun ist env sigma = function (* misc *) -let mk_constr_value ist gl c = - let (sigma,c_interp) = pf_interp_constr ist gl c in - sigma, Value.of_constr c_interp let mk_open_constr_value ist gl c = let (sigma,c_interp) = pf_apply (interp_open_constr ist) gl c in sigma, Value.of_constr c_interp @@ -1215,6 +1212,8 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | QuantHypArgType | RedExprArgType | ConstrWithBindingsArgType | BindingsArgType + | ConstrArgType + | ListArgType ConstrArgType | OptArgType _ | PairArgType _ -> (** generic handler *) Ftactic.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1237,11 +1236,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | VarArgType -> Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x)) | GenArgType -> f (out_gen (glbwit wit_genarg) x) - | ConstrArgType -> - let (sigma,v) = - Tacmach.New.of_old (fun gl -> mk_constr_value ist gl (out_gen (glbwit wit_constr) x)) gl - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) | OpenConstrArgType -> let (sigma,v) = Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (out_gen (glbwit wit_open_constr) x))) gl in @@ -1252,15 +1246,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (out_gen (glbwit wit_constr_may_eval) x) in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - | ListArgType ConstrArgType -> - let wit = glbwit (wit_list wit_constr) in - let (sigma,l_interp) = Tacmach.New.of_old begin fun gl -> - Evd.MonadR.List.map_right - (fun c sigma -> mk_constr_value ist { gl with sigma=sigma } c) - (out_gen wit x) - (project gl) - end gl in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (in_gen (topwit (wit_list wit_genarg)) l_interp)) | ListArgType VarArgType -> let wit = glbwit (wit_list wit_var) in Ftactic.return ( -- cgit v1.2.3 From 123cbdfef1733a1786109bd1b97ccfa3f62c0d1c Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 00:33:29 +0100 Subject: Extraction: cleanup a hack (Pp.is_empty instead of Failure "empty phrase") --- plugins/extraction/haskell.ml | 3 +- plugins/extraction/ocaml.ml | 70 ++++++++++++++++++++----------------------- plugins/extraction/scheme.ml | 3 +- 3 files changed, 37 insertions(+), 39 deletions(-) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 530eb2ff89..dd66a6a98f 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -334,7 +334,8 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom r) && + match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 257c6e9716..259ec49c07 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -392,11 +392,11 @@ let pp_Dfix (rv,c,t) = (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in let rec pp init i = - if i >= Array.length rv then - (if init then failwith "empty phrase" else mt ()) + if i >= Array.length rv then mt () else let void = is_inline_custom rv.(i) || - (not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom rv.(i)) && + match c.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then pp init (i+1) else @@ -469,8 +469,8 @@ let pp_coind pl name = let pp_ind co kn ind = let prefix = if co then "__" else "" in - let some = ref false in - let init= ref (str "type ") in + let initkwd = str "type " in + let nextkwd = fnl () ++ str "and " in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else pp_global Type (IndRef (kn,i))) @@ -483,29 +483,20 @@ let pp_ind co kn ind = p.ip_types) ind.ind_packets in - let rec pp i = + let rec pp i kwd = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in - if is_custom (IndRef ip) then pp (i+1) - else begin - some := true; - if p.ip_logical then pp_logical_ind p ++ pp (i+1) - else - let s = !init in - begin - init := (fnl () ++ str "and "); - s ++ - (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ - pp_one_ind - prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ - pp (i+1) - end - end + if is_custom (IndRef ip) then pp (i+1) kwd + else if p.ip_logical then pp_logical_ind p ++ pp (i+1) kwd + else + kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ + pp_one_ind prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ + pp (i+1) nextkwd in - let st = pp 0 in if !some then st else failwith "empty phrase" + pp 0 initkwd (*s Pretty-printing of a declaration. *) @@ -518,8 +509,8 @@ let pp_mind kn i = | Standard -> pp_ind false kn i let pp_decl = function - | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase" - | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Dtype (r,_,_) when is_inline_custom r -> mt () + | Dterm (r,_,_) when is_inline_custom r -> mt () | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> let name = pp_global Type r in @@ -567,8 +558,8 @@ let pp_alias_decl ren = function rv let pp_spec = function - | Sval (r,_) when is_inline_custom r -> failwith "empty phrase" - | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Sval (r,_) when is_inline_custom r -> mt () + | Stype (r,_,_) when is_inline_custom r -> mt () | Sind (kn,i) -> pp_mind kn i | Sval (r,t) -> let def = pp_type false [] t in @@ -638,7 +629,8 @@ and pp_module_type params = function | MTsig (mp, sign) -> push_visible mp params; let try_pp_specif l x = - try pp_specif x :: l with Failure "empty phrase" -> l + let px = pp_specif x in + if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_specif *) let l = List.fold_left try_pp_specif [] sign in @@ -716,7 +708,8 @@ and pp_module_expr params = function | MEstruct (mp, sel) -> push_visible mp params; let try_pp_structure_elem l x = - try pp_structure_elem x :: l with Failure "empty phrase" -> l + let px = pp_structure_elem x in + if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_structure_elem *) let l = List.fold_left try_pp_structure_elem [] sel in @@ -726,26 +719,31 @@ and pp_module_expr params = function v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ fnl () ++ str "end" +let rec prlist_sep_nonempty sep f = function + | [] -> mt () + | [h] -> f h + | h::t -> + let e = f h in + let r = prlist_sep_nonempty sep f t in + if Pp.is_empty e then r + else e ++ sep () ++ r + let do_struct f s = - let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () - in let ppl (mp,sel) = push_visible mp []; - let p = prlist_strict pp sel in + let p = prlist_sep_nonempty fnl2 f sel in (* for monolithic extraction, we try to simulate the unavailability of [MPfile] in names by artificially nesting these [MPfile] *) (if modular () then pop_visible ()); p in - let p = prlist_strict ppl s in + let p = prlist_sep_nonempty fnl2 ppl s in (if not (modular ()) then repeat (List.length s) pop_visible ()); - p + p ++ fnl () let pp_struct s = do_struct pp_structure_elem s let pp_signature s = do_struct pp_specif s -let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () - let ocaml_descr = { keywords = keywords; file_suffix = ".ml"; @@ -757,5 +755,3 @@ let ocaml_descr = { pp_sig = pp_signature; pp_decl = pp_decl; } - - diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 4901cf1807..0b2a04d3f1 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -183,7 +183,8 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom r) && + match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else -- cgit v1.2.3 From 1e7f3425a8d83fd8606959ec81e91b8e05607b06 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 09:27:45 +0100 Subject: Extraction: fix a pretty-print issue Some explicit '\n' in Pp.str were interacting badly with Format boxes in Compcert, leading to right-flushed "sig..end" blocks in some .mli --- plugins/extraction/ocaml.ml | 31 +++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 259ec49c07..7efe0b4e1f 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -55,29 +55,36 @@ let keywords = "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] Id.Set.empty -let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") +(* Note: do not shorten [str "foo" ++ fnl ()] into [str "foo\n"], + the '\n' character interacts badly with the Format boxing mechanism *) + +let pp_open mp = str ("open "^ string_of_modfile mp) ++ fnl () let pp_comment s = str "(* " ++ hov 0 s ++ str " *)" let pp_header_comment = function | None -> mt () - | Some com -> pp_comment com ++ fnl () ++ fnl () + | Some com -> pp_comment com ++ fnl2 () + +let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () + +let pp_tdummy usf = + if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () + +let pp_mldummy usf = + if usf.mldummy then + str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl () + else mt () let preamble _ comment used_modules usf = pp_header_comment comment ++ - prlist pp_open used_modules ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++ - (if usf.mldummy then - str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n" - else mt ()) ++ - (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) + then_nl (prlist pp_open used_modules) ++ + then_nl (pp_tdummy usf ++ pp_mldummy usf) let sig_preamble _ comment used_modules usf = pp_header_comment comment ++ - prlist pp_open used_modules ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) + then_nl (prlist pp_open used_modules) ++ + then_nl (pp_tdummy usf) (*s The pretty-printer for Ocaml syntax*) -- cgit v1.2.3 From a2a81cec811a8257e47ceb1b9ea3de6d1c2607ee Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 09:57:50 +0100 Subject: Extraction: also get rid of explicit '\n' for haskell --- plugins/extraction/haskell.ml | 71 ++++++++++++++++++++++--------------------- 1 file changed, 37 insertions(+), 34 deletions(-) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index dd66a6a98f..00259750d6 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -35,56 +35,59 @@ let keywords = let pp_comment s = str "-- " ++ s ++ fnl () let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}" +(* Note: do not shorten [str "foo" ++ fnl ()] into [str "foo\n"], + the '\n' character interacts badly with the Format boxing mechanism *) + let preamble mod_name comment used_modules usf = - let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n") + let pp_import mp = str ("import qualified "^ string_of_modfile mp) ++ fnl () in (if not (usf.magic || usf.tunknown) then mt () else str "{-# OPTIONS_GHC -cpp -XMagicHash #-}" ++ fnl () ++ - str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}") - ++ fnl () ++ fnl () + str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}" ++ fnl2 ()) ++ (match comment with | None -> mt () - | Some com -> pp_bracket_comment com ++ fnl () ++ fnl ()) + | Some com -> pp_bracket_comment com ++ fnl2 ()) ++ str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ str "import qualified Prelude" ++ fnl () ++ - prlist pp_import used_modules ++ fnl () ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ + prlist pp_import used_modules ++ fnl () + ++ (if not (usf.magic || usf.tunknown) then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\nimport qualified GHC.Base\ -\nimport qualified GHC.Prim\ -\n#else\ -\n-- HUGS\ -\nimport qualified IOExts\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "import qualified GHC.Base" ++ fnl () ++ + str "import qualified GHC.Prim" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "import qualified IOExts" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.magic then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\nunsafeCoerce :: a -> b\ -\nunsafeCoerce = GHC.Base.unsafeCoerce#\ -\n#else\ -\n-- HUGS\ -\nunsafeCoerce :: a -> b\ -\nunsafeCoerce = IOExts.unsafeCoerce\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "unsafeCoerce :: a -> b" ++ fnl () ++ + str "unsafeCoerce = GHC.Base.unsafeCoerce#" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "unsafeCoerce :: a -> b" ++ fnl () ++ + str "unsafeCoerce = IOExts.unsafeCoerce" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.tunknown then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\ntype Any = GHC.Prim.Any\ -\n#else\ -\n-- HUGS\ -\ntype Any = ()\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "type Any = GHC.Prim.Any" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "type Any = ()" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.mldummy then mt () - else str "__ :: any" ++ fnl () ++ - str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) + else + str "__ :: any" ++ fnl () ++ + str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) let pp_abst = function | [] -> (mt ()) @@ -120,7 +123,7 @@ let rec pp_type par vl t = (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" | Tunknown -> str "Any" - | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" + | Taxiom -> str "() -- AXIOM TO BE REALIZED" ++ fnl () in hov 0 (pp_rec par t) @@ -323,7 +326,7 @@ let pp_decl = function prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s with Not_found -> prlist (fun id -> pr_id id ++ str " ") l ++ - if t == Taxiom then str "= () -- AXIOM TO BE REALIZED\n" + if t == Taxiom then str "= () -- AXIOM TO BE REALIZED" ++ fnl () else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () -- cgit v1.2.3 From d58957f63d36e2da41f6f839a2d94cb0db4c8125 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 14 Dec 2015 10:44:22 +0100 Subject: Remove some occurrences of Unix.opendir. --- lib/system.ml | 4 +--- tools/coqdep_common.ml | 5 +---- tools/ocamllibdep.mll | 25 ++++++++----------------- 3 files changed, 10 insertions(+), 24 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index b57c02a14f..b641aad91b 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -64,9 +64,7 @@ let apply_subdir f path name = | _ -> () let process_directory f path = - let dirh = Unix.opendir path in - try while true do apply_subdir f path (Unix.readdir dirh) done - with End_of_file -> Unix.closedir dirh + Array.iter (apply_subdir f path) (Sys.readdir path) let process_subdirectories f path = let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 221f3406b9..b66529bb38 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -574,15 +574,12 @@ let rec treat_file old_dirname old_name = match try (stat complete_name).st_kind with _ -> S_BLK with | S_DIR -> (if name.[0] <> '.' then - let dir=opendir complete_name in let newdirname = match dirname with | None -> name | Some d -> d//name in - try - while true do treat_file (Some newdirname) (readdir dir) done - with End_of_file -> closedir dir) + Array.iter (treat_file (Some newdirname)) (Sys.readdir complete_name)) | S_REG -> (match get_extension name [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with | (base,".v") -> diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 4e5edcf6c2..1bcbe7c0e8 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -98,23 +98,14 @@ let file_name s = function type dir = string option -(* Visits all the directories under [dir], including [dir], - or just [dir] if [recur=false] *) - -let rec add_directory add_file phys_dir = - let dirh = opendir phys_dir in - try - while true do - let f = readdir dirh in - (* we avoid all files and subdirs starting by '.' (e.g. .svn), - plus CVS and _darcs and any subdirs given via -exclude-dirs *) - if f.[0] <> '.' then - let phys_f = if phys_dir = "." then f else phys_dir//f in - match try (stat phys_f).st_kind with _ -> S_BLK with - | S_REG -> add_file phys_dir f - | _ -> () - done - with End_of_file -> closedir dirh +let add_directory add_file phys_dir = + Array.iter (fun f -> + (* we avoid all files starting by '.' *) + if f.[0] <> '.' then + let phys_f = if phys_dir = "." then f else phys_dir//f in + match try (stat phys_f).st_kind with _ -> S_BLK with + | S_REG -> add_file phys_dir f + | _ -> ()) (Sys.readdir phys_dir) let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; -- cgit v1.2.3 From b1cfb65fbf7c11cb5b9acc8039bcf5e36882a685 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 11:11:49 +0100 Subject: Extraction: cosmetically avoid generating spaces on empty lines --- plugins/extraction/extract_env.ml | 2 +- plugins/extraction/ocaml.ml | 19 ++++++++++++------- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 3d32398ffd..7014df83fd 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -458,7 +458,7 @@ let print_one_decl struc mp decl = push_visible mp []; let ans = d.pp_decl decl in pop_visible (); - ans + v 0 ans (*s Extraction of a ml struct to a file. *) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 7efe0b4e1f..6ff4c25ec4 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -388,9 +388,14 @@ and pp_fix par env i (ids,bl) args = fnl () ++ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) +(* Ad-hoc double-newline in v boxes, with enough negative whitespace + to avoid indenting the intermediate blank line *) + +let cut2 () = brk (0,-100000) ++ brk (0,0) + let pp_val e typ = hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ - str " **)") ++ fnl2 () + str " **)") ++ cut2 () (*s Pretty-printing of [Dfix] *) @@ -411,7 +416,7 @@ let pp_Dfix (rv,c,t) = if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) else pp_function (empty_env ()) c.(i) in - (if init then mt () else fnl2 ()) ++ + (if init then mt () else cut2 ()) ++ pp_val names.(i) t.(i) ++ str (if init then "let rec " else "and ") ++ names.(i) ++ def ++ pp false (i+1) @@ -644,7 +649,7 @@ and pp_module_type params = function let l = List.rev l in pop_visible (); str "sig" ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> let ids = pp_parameters (rename_tvars keywords vl) in @@ -723,7 +728,7 @@ and pp_module_expr params = function let l = List.rev l in pop_visible (); str "struct" ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" let rec prlist_sep_nonempty sep f = function @@ -738,14 +743,14 @@ let rec prlist_sep_nonempty sep f = function let do_struct f s = let ppl (mp,sel) = push_visible mp []; - let p = prlist_sep_nonempty fnl2 f sel in + let p = prlist_sep_nonempty cut2 f sel in (* for monolithic extraction, we try to simulate the unavailability of [MPfile] in names by artificially nesting these [MPfile] *) (if modular () then pop_visible ()); p in - let p = prlist_sep_nonempty fnl2 ppl s in + let p = prlist_sep_nonempty cut2 ppl s in (if not (modular ()) then repeat (List.length s) pop_visible ()); - p ++ fnl () + v 0 p ++ fnl () let pp_struct s = do_struct pp_structure_elem s -- cgit v1.2.3 From 9329cb508f336b48a2bf2e699886546158b6b4d8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Dec 2015 11:14:45 +0100 Subject: Test file for #4363 was not complete. --- test-suite/bugs/closed/4363.v | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test-suite/bugs/closed/4363.v b/test-suite/bugs/closed/4363.v index 75a9c9a041..9895548c1d 100644 --- a/test-suite/bugs/closed/4363.v +++ b/test-suite/bugs/closed/4363.v @@ -4,4 +4,6 @@ Proof. assert (H : Set) by abstract (assert Type by abstract exact Type using bar; exact nat). exact bar. Defined. (* Toplevel input, characters 0-8: -Error: \ No newline at end of file +Error: +The term "(fun _ : Set => bar) foo_subproof" has type +"Type@{Top.2}" while it is expected to have type "Type@{Top.1}". *) -- cgit v1.2.3 From 81ef6a6dc1bfc3db0e7df3e32b6446fc4d2c4008 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Dec 2015 11:22:54 +0100 Subject: Moved proof_admitted to its own file, named "AdmitAxiom.v". --- doc/stdlib/index-list.html.template | 1 + theories/Compat/AdmitAxiom.v | 15 +++++++++++++++ theories/Compat/Coq84.v | 4 ---- theories/Compat/vo.itarget | 1 + 4 files changed, 17 insertions(+), 4 deletions(-) create mode 100644 theories/Compat/AdmitAxiom.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 866193ffb4..292b2b36cc 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -617,6 +617,7 @@ through the Require Import command.

Compatibility wrappers for previous versions of Coq
+ theories/Compat/AdmitAxiom.v theories/Compat/Coq84.v theories/Compat/Coq85.v
diff --git a/theories/Compat/AdmitAxiom.v b/theories/Compat/AdmitAxiom.v new file mode 100644 index 0000000000..68607f6b2d --- /dev/null +++ b/theories/Compat/AdmitAxiom.v @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* add_require "Coq.Compat.Coq84" + | _ -> () + let compile_list = ref ([] : (bool * string) list) let glob_opt = ref false @@ -475,7 +480,7 @@ let parse_args arglist = |"-async-proofs-private-flags" -> Flags.async_proofs_private_flags := Some (next ()); |"-worker-id" -> set_worker_id opt (next ()) - |"-compat" -> Flags.compat_version := get_compat_version (next ()) + |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v |"-compile" -> add_compile false (next ()) |"-compile-verbose" -> add_compile true (next ()) |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true -- cgit v1.2.3 From 469cb750c6c1aa46f77b2a89a36f79f29aa97073 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Dec 2015 13:33:47 +0100 Subject: Revert PMP's fix of #2498, which introduces an incompatibility with lablgtk 2.14. Debian ships with lablgtk 2.16 only since a few months, so we apply the fix to trunk instead. This reverts commits: 490160d25d3caac1d2ea5beebbbebc959b1b3832. ef8718a7fd3bcd960d954093d8c636525e6cc492. 6f9cc3aca5bb0e5684268a7283796a9272ed5f9d. 901a9b29adf507370732aeafbfea6718c1842f1b. --- INSTALL.ide | 2 +- configure.ml | 50 +++++++++----------------------------------------- ide/preferences.ml | 31 ++++--------------------------- 3 files changed, 14 insertions(+), 69 deletions(-) diff --git a/INSTALL.ide b/INSTALL.ide index b651e77db4..6e41b2d051 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -39,7 +39,7 @@ COMPILATION REQUIREMENTS install GTK+ 2.x, should you need to force it for one reason or another.) - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2. - You need at least version 2.16. + You need at least version 2.14.2. Your distribution may contain precompiled packages. For example, for Debian, run diff --git a/configure.ml b/configure.ml index 3a55fb5707..51033c3d01 100644 --- a/configure.ml +++ b/configure.ml @@ -719,18 +719,10 @@ let operating_system, osdeplibs = (** * lablgtk2 and CoqIDE *) -type source = Manual | OCamlFind | Stdlib - -let get_source = function -| Manual -> "manually provided" -| OCamlFind -> "via ocamlfind" -| Stdlib -> "in OCaml library" - (** Is some location a suitable LablGtk2 installation ? *) -let check_lablgtkdir ?(fatal=false) src dir = +let check_lablgtkdir ?(fatal=false) msg dir = let yell msg = if fatal then die msg else (printf "%s\n" msg; false) in - let msg = get_source src in if not (dir_exists dir) then yell (sprintf "No such directory '%s' (%s)." dir msg) else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then @@ -744,11 +736,11 @@ let check_lablgtkdir ?(fatal=false) src dir = let get_lablgtkdir () = match !Prefs.lablgtkdir with | Some dir -> - let msg = Manual in + let msg = "manually provided" in if check_lablgtkdir ~fatal:true msg dir then dir, msg - else "", msg + else "", "" | None -> - let msg = OCamlFind in + let msg = "via ocamlfind" in let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in if d1 <> "" && check_lablgtkdir msg d1 then d1, msg else @@ -756,34 +748,10 @@ let get_lablgtkdir () = let d2,_ = tryrun "ocamlfind" ["query";"lablgtk2"] in if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg else - let msg = Stdlib in + let msg = "in OCaml library" in let d3 = camllib^"/lablgtk2" in if check_lablgtkdir msg d3 then d3, msg - else "", msg - -(** Detect and/or verify the Lablgtk2 version *) - -let check_lablgtk_version src dir = match src with -| Manual | Stdlib -> - let test accu f = - if accu then - let test = sprintf "grep -q -w %s %S/glib.mli" f dir in - Sys.command test = 0 - else false - in - let heuristics = [ - "convert_with_fallback"; - "wrap_poll_func"; (** Introduced in lablgtk 2.16 *) - ] in - let ans = List.fold_left test true heuristics in - if ans then printf "Warning: could not check the version of lablgtk2.\n"; - (ans, "an unknown version") -| OCamlFind -> - let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in - try - let vi = List.map s2i (numeric_prefix_list v) in - ([2; 16] <= vi, v) - with _ -> (false, v) + else "", "" let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -807,9 +775,9 @@ let check_coqide () = if !Prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in if dir = "" then set_ide No "LablGtk2 not found"; - let (ok, version) = check_lablgtk_version via dir in - let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in - if not ok then set_ide No (found^", but too old (required >= 2.16, found " ^ version ^ ")"); + let found = sprintf "LablGtk2 found (%s)" via in + let test = sprintf "grep -q -w convert_with_fallback %S/glib.mli" dir in + if Sys.command test <> 0 then set_ide No (found^" but too old"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; if !Prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); diff --git a/ide/preferences.ml b/ide/preferences.ml index 90862d0647..01ce454834 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -711,61 +711,38 @@ let configure ?(apply=(fun () -> ())) () = ~f:(fun s -> current.project_file_name <- s) current.project_file_name in - let update_modifiers prefix mds = - let change ~path ~key ~modi ~changed = - if CString.is_sub prefix path 0 then - ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path) - in - GtkData.AccelMap.foreach change - in let help_string = "restart to apply" in let the_valid_mod = str_to_mod_list current.modifiers_valid in let modifier_for_tactics = - let cb l = - current.modifier_for_tactics <- mod_list_to_str l; - update_modifiers "/Tactics/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l) ~help:help_string "Modifiers for Tactics Menu" (str_to_mod_list current.modifier_for_tactics) in let modifier_for_templates = - let cb l = - current.modifier_for_templates <- mod_list_to_str l; - update_modifiers "/Templates/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l) ~help:help_string "Modifiers for Templates Menu" (str_to_mod_list current.modifier_for_templates) in let modifier_for_navigation = - let cb l = - current.modifier_for_navigation <- mod_list_to_str l; - update_modifiers "/Navigation/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l) ~help:help_string "Modifiers for Navigation Menu" (str_to_mod_list current.modifier_for_navigation) in let modifier_for_display = - let cb l = - current.modifier_for_display <- mod_list_to_str l; - update_modifiers "/View/" l - in modifiers ~allow:the_valid_mod - ~f:cb + ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l) ~help:help_string "Modifiers for View Menu" (str_to_mod_list current.modifier_for_display) -- cgit v1.2.3 From 317858b7ad05764a2ce010354631443f219a4b9f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 14 Dec 2015 12:03:45 +0100 Subject: Updating CHANGES with an incompatibility. --- CHANGES | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGES b/CHANGES index 8cb5158753..b39d84ba57 100644 --- a/CHANGES +++ b/CHANGES @@ -14,7 +14,9 @@ Specification language Tactics - Syntax "destruct !hyp" changed to "destruct (hyp)", and similarly - for induction. + for induction (rare source of incompatibilities easily solvable by + removing parentheses around "hyp" when not for the purpose of keeping + the hypothesis). - Syntax "p/c" for on-the-fly application of a lemma c before introducing along pattern p changed to p%c1..%cn. The feature and syntax are in experimental stage. -- cgit v1.2.3 From fa08993b9330623c8cb259ac8ebff93ecce9c2f6 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 14 Dec 2015 14:04:12 +0100 Subject: CoqIDE: add 'you need to restart CoqIDE after changing shortcuts' message --- ide/preferences.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/ide/preferences.ml b/ide/preferences.ml index 01ce454834..8988dbc60b 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -754,6 +754,13 @@ let configure ?(apply=(fun () -> ())) () = "Allowed modifiers" the_valid_mod in + let modifier_notice = + let b = GPack.hbox () in + let _lbl = + GMisc.label ~markup:"You need to restart CoqIDE after changing these settings" + ~packing:b#add () in + custom b (fun () -> ()) true + in let cmd_editor = let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in combo @@ -855,7 +862,7 @@ let configure ?(apply=(fun () -> ())) () = [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; - modifier_for_templates; modifier_for_display; modifier_for_navigation]); + modifier_for_templates; modifier_for_display; modifier_for_navigation; modifier_notice]); Section("Misc", Some `ADD, misc)] in -- cgit v1.2.3 From 78c2ebe640e86e7357982e6e07b8121111a51fcc Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Dec 2015 15:16:35 +0100 Subject: Remove a mention of Set Virtual Machine in doc. --- doc/refman/RefMan-gal.tex | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index 0e758bcab6..fcccd9cb4b 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -496,9 +496,8 @@ arguments is used for making explicit the value of implicit arguments The expression ``{\term}~{\tt :}~{\type}'' is a type cast expression. It enforces the type of {\term} to be {\type}. -``{\term}~{\tt <:}~{\type}'' locally sets up the virtual machine (as if option -{\tt Virtual Machine} were on, see \ref{SetVirtualMachine}) for checking that -{\term} has type {\type}. +``{\term}~{\tt <:}~{\type}'' locally sets up the virtual machine for checking +that {\term} has type {\type}. \subsection{Inferable subterms \label{hole} -- cgit v1.2.3 From 7c645566ef64f09bd6c80007c9e66305ccb90659 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Dec 2015 15:16:46 +0100 Subject: Fix \label which was meants to be \ref in doc of CIC terms. --- doc/refman/RefMan-cic.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index e3e49e115d..1554ee04d3 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -24,7 +24,7 @@ written {\it ``x:T''}. Informally, {\it ``x:T''} can be thought as The types of types are {\em sorts}. Types and sorts are themselves terms so that terms, types and sorts are all components of a common syntactic language of terms which is described in -Section~\label{cic:terms} but, first, we describe sorts. +Section~\ref{cic:terms} but, first, we describe sorts. \subsection[Sorts]{Sorts\label{Sorts} \index{Sorts}} -- cgit v1.2.3 From f439001caa24671d03d8816964ceb8e483660e70 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 12:32:56 +0100 Subject: Adding compatibility flag for 8.5. Soon needing a more algebraic view at version numbers... --- lib/flags.ml | 13 ++++++++----- lib/flags.mli | 2 +- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/lib/flags.ml b/lib/flags.ml index 9a0d4b5ec1..96415ed263 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -101,18 +101,20 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_2 | V8_3 | V8_4 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current let compat_version = ref Current let version_strictly_greater v = match !compat_version, v with -| V8_2, (V8_2 | V8_3 | V8_4 | Current) -> false -| V8_3, (V8_3 | V8_4 | Current) -> false -| V8_4, (V8_4 | Current) -> false +| V8_2, (V8_2 | V8_3 | V8_4 | V8_5 | Current) -> false +| V8_3, (V8_3 | V8_4 | V8_5 | Current) -> false +| V8_4, (V8_4 | V8_5 | Current) -> false +| V8_5, (V8_5 | Current) -> false | Current, Current -> false | V8_3, V8_2 -> true | V8_4, (V8_2 | V8_3) -> true -| Current, (V8_2 | V8_3 | V8_4) -> true +| V8_5, (V8_2 | V8_3 | V8_4) -> true +| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> true let version_less_or_equal v = not (version_strictly_greater v) @@ -120,6 +122,7 @@ let pr_version = function | V8_2 -> "8.2" | V8_3 -> "8.3" | V8_4 -> "8.4" + | V8_5 -> "8.5" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index 29a0bbef01..cb92e1462d 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -55,7 +55,7 @@ val raw_print : bool ref val record_print : bool ref val univ_print : bool ref -type compat_version = V8_2 | V8_3 | V8_4 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current val compat_version : compat_version ref val version_strictly_greater : compat_version -> bool val version_less_or_equal : compat_version -> bool -- cgit v1.2.3 From 7d2f7e1665136f5d7a2882f733ae807e1a55dc7c Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 19:46:25 +0100 Subject: Extraction: propagate implicit args in inner fixpoint (bug #4243 part 2) In front of "let rec f x y = ... in f n m", if n is now an implicit argument, then the argument x of the inner fixpoint f is also considered as implicit. This optimization is rather ad-hoc, since we only handle MLapp(MLfix()) for now, and the implicit argument should be reused verbatim as argument. Note that it might happen that x cannot be implicit in f. But in this case we would have add an error message about n still occurring somewhere... At least this small heuristic was easy to add, and was sufficient to solve the part 2 of bug #4243. --- plugins/extraction/mlutil.ml | 61 +++++++++++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 24 deletions(-) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 402370eece..70249193e5 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1077,11 +1077,19 @@ let kill_some_lams bl (ids,c) = (*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or - if there is no lambda left at all. *) + if there is no lambda left at all. In addition, it now accepts a signature + that may mention some implicits. *) -let kill_dummy_lams c = +let rec merge_implicits ids s = match ids, s with + | [],_ -> [] + | _,[] -> List.map sign_of_id ids + | Dummy::ids, _::s -> Kill Kprop :: merge_implicits ids s + | _::ids, (Kill (Kimplicit _) as k)::s -> k :: merge_implicits ids s + | _::ids, _::s -> Keep :: merge_implicits ids s + +let kill_dummy_lams sign c = let ids,c = collect_lams c in - let bl = List.map sign_of_id ids in + let bl = merge_implicits ids (List.rev sign) in if not (List.memq Keep bl) then raise Impossible; let rec fst_kill n = function | [] -> raise Impossible @@ -1093,7 +1101,7 @@ let kill_dummy_lams c = let _, bl = List.chop skip bl in let c = named_lams ids_skip c in let ids',c = kill_some_lams bl (ids,c) in - ids, named_lams ids' c + (ids,bl), named_lams ids' c (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) @@ -1135,13 +1143,13 @@ let term_expunge s (ids,c) = then MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and - purge the args of [MLrel r] corresponding to a [dummy_name]. +(*s [kill_dummy_args (ids,bl) r t] looks for occurrences of [MLrel r] in [t] + and purge the args of [MLrel r] corresponding to a [Kill] in [bl]. It makes eta-expansion if needed. *) -let kill_dummy_args ids r t = +let kill_dummy_args (ids,bl) r t = let m = List.length ids in - let bl = List.rev_map sign_of_id ids in + let sign = List.rev bl in let rec found n = function | MLrel r' when Int.equal r' (r + n) -> true | MLmagic e -> found n e @@ -1152,41 +1160,46 @@ let kill_dummy_args ids r t = let k = max 0 (m - (List.length a)) in let a = List.map (killrec n) a in let a = List.map (ast_lift k) a in - let a = select_via_bl bl (a @ (eta_args k)) in + let a = select_via_bl sign (a @ (eta_args k)) in named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> - let a = select_via_bl bl (eta_args m) in + let a = select_via_bl sign (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e in killrec 0 t (*s The main function for local [dummy] elimination. *) +let sign_of_args a = + List.map (function MLdummy k -> Kill k | _ -> Keep) a + let rec kill_dummy = function | MLfix(i,fi,c) -> (try - let ids,c = kill_dummy_fix i c in - ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids 1 (MLrel 1)) + let k,c = kill_dummy_fix i c [] in + ast_subst (MLfix (i,fi,c)) (kill_dummy_args k 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in + (* Heuristics: if some arguments are implicit args, we try to + eliminate the corresponding arguments of the fixpoint *) (try - let ids,c = kill_dummy_fix i c in + let k,c = kill_dummy_fix i c (sign_of_args a) in let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in - let fake' = kill_dummy_args ids 1 fake in + let fake' = kill_dummy_args k 1 fake in ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try - let ids,c = kill_dummy_fix i c in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_fix i c [] in + let e = kill_dummy (kill_dummy_args k 1 e) in MLletin(id, MLfix(i,fi,c),e) with Impossible -> MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) @@ -1198,21 +1211,21 @@ and kill_dummy_hd = function | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy_hd (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy_hd (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a -and kill_dummy_fix i c = +and kill_dummy_fix i c s = let n = Array.length c in - let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in + let k,ci = kill_dummy_lams s (kill_dummy_hd c.(i)) in let c = Array.copy c in c.(i) <- ci; for j = 0 to (n-1) do - c.(j) <- kill_dummy (kill_dummy_args ids (n-i) c.(j)) + c.(j) <- kill_dummy (kill_dummy_args k (n-i) c.(j)) done; - ids,c + k,c (*s Putting things together. *) -- cgit v1.2.3 From 6ab322a9b0725aaa9fa6f457db061f2635598fe9 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 20:13:45 +0100 Subject: A test file for Extraction Implicit (including bugs #4243 and #4228) --- test-suite/success/extraction_impl.v | 82 ++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) create mode 100644 test-suite/success/extraction_impl.v diff --git a/test-suite/success/extraction_impl.v b/test-suite/success/extraction_impl.v new file mode 100644 index 0000000000..a72715f292 --- /dev/null +++ b/test-suite/success/extraction_impl.v @@ -0,0 +1,82 @@ + +(** Examples of extraction with manually-declared implicit arguments *) + +(** NB: we should someday check the produced code instead of + simply running the commands. *) + +(** Bug #4243, part 1 *) + +Inductive dnat : nat -> Type := +| d0 : dnat 0 +| ds : forall n m, n = m -> dnat n -> dnat (S n). + +Extraction Implicit ds [m]. + +Lemma dnat_nat: forall n, dnat n -> nat. +Proof. + intros n d. + induction d as [| n m Heq d IHn]. + exact 0. exact (S IHn). +Defined. + +Recursive Extraction dnat_nat. + +Extraction Implicit dnat_nat [n]. +Recursive Extraction dnat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint dnat_nat' n (d:dnat n) := + match d with + | d0 => 0 + | ds n m _ d => S (dnat_nat' n d) + end. + +Recursive Extraction dnat_nat'. + +Extraction Implicit dnat_nat' [n]. +Recursive Extraction dnat_nat'. + +(** Bug #4243, part 2 *) + +Inductive enat: nat -> Type := + e0: enat 0 +| es: forall n, enat n -> enat (S n). + +Lemma enat_nat: forall n, enat n -> nat. +Proof. + intros n e. + induction e as [| n e IHe]. + exact (O). + exact (S IHe). +Defined. + +Extraction Implicit es [n]. +Extraction Implicit enat_nat [n]. +Recursive Extraction enat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint enat_nat' n (e:enat n) : nat := + match e with + | e0 => 0 + | es n e => S (enat_nat' n e) + end. + +Extraction Implicit enat_nat' [n]. +Recursive Extraction enat_nat. + +(** Bug #4228 *) + +Module Food. +Inductive Course := +| main: nat -> Course +| dessert: nat -> Course. + +Inductive Meal : Course -> Type := +| one_course : forall n:nat, Meal (main n) +| two_course : forall n m, Meal (main n) -> Meal (dessert m). +Extraction Implicit two_course [n]. +End Food. + +Recursive Extraction Food.Meal. -- cgit v1.2.3 From c3aa4c065fac0e37d67ca001aec47b1c2138e648 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 20:29:45 +0100 Subject: extraction_impl.v: fix a typo --- test-suite/success/extraction_impl.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/success/extraction_impl.v b/test-suite/success/extraction_impl.v index a72715f292..dfdeff82ff 100644 --- a/test-suite/success/extraction_impl.v +++ b/test-suite/success/extraction_impl.v @@ -64,7 +64,7 @@ Fixpoint enat_nat' n (e:enat n) : nat := end. Extraction Implicit enat_nat' [n]. -Recursive Extraction enat_nat. +Recursive Extraction enat_nat'. (** Bug #4228 *) -- cgit v1.2.3 From 2ab8455cffef4097a441eb6befaa29f6f3076824 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 3 Jul 2015 21:25:15 +0200 Subject: Fixing little bug of coq_makefile with unterminated comment. Force failing when reaching end of file with unterminated comment when parsing Make (project) file. --- ide/project_file.ml4 | 1 + 1 file changed, 1 insertion(+) diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index f7279f9cfe..152f76cc0e 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -28,6 +28,7 @@ let rec parse_string = parser and parse_string2 = parser | [< ''"' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) + | [< >] -> raise Parsing_error and parse_skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> parse_skip_comment s -- cgit v1.2.3 From ce395ca02311bbe6ecc1b2782e74312272dd15ec Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 22:31:41 +0100 Subject: Extraction: allow basic beta-reduction even through a MLmagic (fix #2795) This fix only handles MLapp(MLmagic(MLlam...),...). Someday, we'll have to properly investigate the interaction between all the other optimizations and MLmagic. But well, at least this precise bug is fixed now. --- plugins/extraction/mlutil.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 70249193e5..bfd0794de2 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -987,6 +987,10 @@ and simpl_app o a = function | _ -> let a' = List.map (ast_lift 1) (List.tl a) in simpl o (MLletin (id, List.hd a, MLapp (t, a')))) + | MLmagic (MLlam (id,t)) -> + (* When we've at least one argument, we permute the magic + and the lambda, to simplify things a bit (see #2795) *) + simpl_app o a (MLlam (id,MLmagic t)) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) -- cgit v1.2.3 From 3c2dc887a8b4cae06a55f3b3ae2b6186a6056f1a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Dec 2015 10:43:54 +0100 Subject: Revert "Revert PMP's fix of #2498, which introduces an incompatibility with lablgtk" This reverts commit 469cb750c6c1aa46f77b2a89a36f79f29aa97073. --- INSTALL.ide | 2 +- configure.ml | 50 +++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 42 insertions(+), 10 deletions(-) diff --git a/INSTALL.ide b/INSTALL.ide index 6e41b2d051..b651e77db4 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -39,7 +39,7 @@ COMPILATION REQUIREMENTS install GTK+ 2.x, should you need to force it for one reason or another.) - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2. - You need at least version 2.14.2. + You need at least version 2.16. Your distribution may contain precompiled packages. For example, for Debian, run diff --git a/configure.ml b/configure.ml index 47721f778e..b8bb650b13 100644 --- a/configure.ml +++ b/configure.ml @@ -670,10 +670,18 @@ let operating_system, osdeplibs = (** * lablgtk2 and CoqIDE *) +type source = Manual | OCamlFind | Stdlib + +let get_source = function +| Manual -> "manually provided" +| OCamlFind -> "via ocamlfind" +| Stdlib -> "in OCaml library" + (** Is some location a suitable LablGtk2 installation ? *) -let check_lablgtkdir ?(fatal=false) msg dir = +let check_lablgtkdir ?(fatal=false) src dir = let yell msg = if fatal then die msg else (printf "%s\n" msg; false) in + let msg = get_source src in if not (dir_exists dir) then yell (sprintf "No such directory '%s' (%s)." dir msg) else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then @@ -687,11 +695,11 @@ let check_lablgtkdir ?(fatal=false) msg dir = let get_lablgtkdir () = match !Prefs.lablgtkdir with | Some dir -> - let msg = "manually provided" in + let msg = Manual in if check_lablgtkdir ~fatal:true msg dir then dir, msg - else "", "" + else "", msg | None -> - let msg = "via ocamlfind" in + let msg = OCamlFind in let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in if d1 <> "" && check_lablgtkdir msg d1 then d1, msg else @@ -699,10 +707,34 @@ let get_lablgtkdir () = let d2,_ = tryrun "ocamlfind" ["query";"lablgtk2"] in if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg else - let msg = "in OCaml library" in + let msg = Stdlib in let d3 = camllib^"/lablgtk2" in if check_lablgtkdir msg d3 then d3, msg - else "", "" + else "", msg + +(** Detect and/or verify the Lablgtk2 version *) + +let check_lablgtk_version src dir = match src with +| Manual | Stdlib -> + let test accu f = + if accu then + let test = sprintf "grep -q -w %s %S/glib.mli" f dir in + Sys.command test = 0 + else false + in + let heuristics = [ + "convert_with_fallback"; + "wrap_poll_func"; (** Introduced in lablgtk 2.16 *) + ] in + let ans = List.fold_left test true heuristics in + if ans then printf "Warning: could not check the version of lablgtk2.\n"; + (ans, "an unknown version") +| OCamlFind -> + let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in + try + let vi = List.map s2i (numeric_prefix_list v) in + ([2; 16] <= vi, v) + with _ -> (false, v) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -726,9 +758,9 @@ let check_coqide () = if !Prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in if dir = "" then set_ide No "LablGtk2 not found"; - let found = sprintf "LablGtk2 found (%s)" via in - let test = sprintf "grep -q -w convert_with_fallback %S/glib.mli" dir in - if Sys.command test <> 0 then set_ide No (found^" but too old"); + let (ok, version) = check_lablgtk_version via dir in + let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in + if not ok then set_ide No (found^", but too old (required >= 2.16, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; if !Prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); -- cgit v1.2.3 From 4b197ed247d1f30ff40fa59f85b070766f305bea Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 15 Dec 2015 11:15:00 +0100 Subject: Extraction: replace unused variable names by _ in funs and matchs (fix #2842) This is done via a unique pass which seems roughly linear in practice, even on big developments like CompCert. There's a List.nth in an env at each MLrel, that could be made logarithmic if necessary via Okasaki's skew list for instance. Another approach would be to keep names (as a form of documentation), but prefix them by _ to please OCaml's warnings. For now, let's be radical and use the _ pattern. --- plugins/extraction/mlutil.ml | 69 +++++++++++++++++++++++++++++++++++++++++++ plugins/extraction/mlutil.mli | 2 ++ plugins/extraction/modutil.ml | 6 ++-- 3 files changed, 75 insertions(+), 2 deletions(-) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index bfd0794de2..2b606bf13c 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -511,6 +511,75 @@ let nb_occur_match = | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 in nb 1 +(* Replace unused variables by _ *) + +let dump_unused_vars a = + let dump_id = function + | Dummy -> Dummy + | Id _ -> Id dummy_name + | Tmp _ -> Tmp dummy_name + in + let rec ren env a = match a with + | MLrel i -> + let () = (List.nth env (i-1)) := true in a + + | MLlam (id,b) -> + let occ_id = ref false in + let b' = ren (occ_id::env) b in + if !occ_id then if b' == b then a else MLlam(id,b') + else MLlam(dump_id id,b') + + | MLletin (id,b,c) -> + let occ_id = ref false in + let b' = ren env b in + let c' = ren (occ_id::env) c in + if !occ_id then + if b' == b && c' == c then a else MLletin(id,b',c') + else + (* 'let' without occurrence: shouldn't happen after simpl *) + MLletin(dump_id id,b',c') + + | MLcase (t,e,br) -> + let e' = ren env e in + let br' = Array.smartmap (ren_branch env) br in + if e' == e && br' == br then a else MLcase (t,e',br') + + | MLfix (i,ids,v) -> + let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in + let v' = Array.smartmap (ren env') v in + if v' == v then a else MLfix (i,ids,v') + + | MLapp (b,l) -> + let b' = ren env b and l' = List.smartmap (ren env) l in + if b' == b && l' == l then a else MLapp (b',l') + + | MLcons(t,r,l) -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLcons (t,r,l') + + | MLtuple l -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLtuple l' + + | MLmagic b -> + let b' = ren env b in + if b' == b then a else MLmagic b' + + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> a + + and ren_branch env ((ids,p,b) as tr) = + let occs = List.map (fun _ -> ref false) ids in + let b' = ren (List.rev_append occs env) b in + let ids' = + List.map2 + (fun id occ -> if !occ then id else dump_id id) + ids occs + in + if b' == b && List.equal eq_ml_ident ids ids' then tr + else (ids',p,b') + in + ren [] a + (*s Lifting on terms. [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index c380dfb3e3..c07cee7136 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -111,6 +111,8 @@ val ast_subst : ml_ast -> ml_ast -> ml_ast val ast_glob_subst : ml_ast Refmap'.t -> ml_ast -> ml_ast +val dump_unused_vars : ml_ast -> ml_ast + val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast val inline : global_reference -> ml_ast -> bool diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index e8383bda59..6f354b1ce5 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -263,10 +263,12 @@ let dfix_to_mlfix rv av i = order to preserve the global interface, later [depcheck_se] will get rid of them if possible *) +let optim_ast t = dump_unused_vars (normalize t) + let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> - let a = normalize (ast_glob_subst !s a) in + let a = optim_ast (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; let d = match optimize_fix a with @@ -276,7 +278,7 @@ let rec optim_se top to_appear s = function in (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> - let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in + let av = Array.map (fun a -> optim_ast (ast_glob_subst !s a)) av in (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do -- cgit v1.2.3 From 1aecaf88e5491d29b200515fc64ce3d479318758 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 11:47:38 +0100 Subject: Tactics: Generalizing the use of the experimental clearing modifier to all cases of rewrite. --- parsing/g_tactic.ml4 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 3d59b9b8db..3e4a6c6a1b 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -240,7 +240,7 @@ GEXTEND Gram [ [ n = natural -> (None,ElimOnAnonHyp n) | test_lpar_id_rpar; c = constr_with_bindings -> (Some false,induction_arg_of_constr c) - | c = constr_with_bindings -> (None,induction_arg_of_constr c) + | c = constr_with_bindings_arg -> on_snd induction_arg_of_constr c ] ] ; constr_with_bindings_arg: @@ -499,12 +499,12 @@ GEXTEND Gram [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ] ; rewriter : - [ [ "!"; c = constr_with_bindings -> (RepeatPlus,(None,c)) + [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) - | n = natural; "!"; c = constr_with_bindings -> (Precisely n,(None,c)) + | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) - | c = constr_with_bindings -> (Precisely 1, (None,c)) + | c = constr_with_bindings_arg -> (Precisely 1, c) ] ] ; oriented_rewriter : -- cgit v1.2.3 From 78896394b49b0d8b89c81378f9437e69a86b6363 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 12:22:29 +0100 Subject: Granting clear_flag in injection, even legacy mode. This is possible since the clear_flag is new. --- tactics/equality.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index 89d14fdc7b..92ebcb2724 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1356,7 +1356,7 @@ let postInjEqTac clear_flag ipats c n = then intro_patterns_bound_to n MoveLast ipats else intro_patterns_to MoveLast ipats in tclTHEN clear_tac intro_tac - | None -> tclIDTAC + | None -> apply_clear_request clear_flag false c let injEq clear_flag ipats = let l2r = -- cgit v1.2.3 From fa0b0bedf165812b170cedbce8a5b6cf94a5fadf Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 04:31:01 +0100 Subject: Simplifying documentation of "assert form as pat". --- doc/refman/RefMan-tac.tex | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 18bcd1af62..34b974381a 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -1249,18 +1249,9 @@ in the list of subgoals remaining to prove. introduction pattern (in particular, if {\intropattern} is {\ident}, the tactic behaves like \texttt{assert ({\ident} :\ {\form})}). - If {\intropattern} is a disjunctive/conjunctive - introduction pattern, the tactic behaves like \texttt{assert - {\form}} followed by a {\tt destruct} using this introduction pattern. - - If {\intropattern} is a rewriting intropattern pattern, the tactic - behaves like \texttt{assert {\form}} followed by a call to {\tt - subst} on the resulting hypothesis, if applicable, or to {\tt - rewrite} otherwise. - - If {\intropattern} is an injection intropattern pattern, the tactic - behaves like \texttt{assert {\form}} followed by {\tt injection} - using this introduction pattern. + If {\intropattern} is an action introduction pattern, the tactic + behaves like \texttt{assert {\form}} followed by the action done by + this introduction pattern. \item \texttt{assert {\form} as {\intropattern} by {\tac}} -- cgit v1.2.3 From 003fe3d5e60b8d89b28e718e3d048818caceb56a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 10:46:15 +0100 Subject: Adding a token "index" representing positions (1st, 2nd, etc.). --- parsing/g_prim.ml4 | 5 ++++- parsing/lexer.ml4 | 24 +++++++++++++++++++----- parsing/pcoq.ml | 1 + parsing/pcoq.mli | 1 + parsing/tok.ml | 7 +++++++ parsing/tok.mli | 1 + 6 files changed, 33 insertions(+), 6 deletions(-) diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 84da9c424c..b3cd939266 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -32,7 +32,7 @@ let my_int_of_string loc s = GEXTEND Gram GLOBAL: - bigint natural integer identref name ident var preident + bigint natural index integer identref name ident var preident fullyqualid qualid reference dirpath ne_lstring ne_string string pattern_ident pattern_identref by_notation smart_global; preident: @@ -113,6 +113,9 @@ GEXTEND Gram natural: [ [ i = INT -> my_int_of_string (!@loc) i ] ] ; + index: + [ [ i = INDEX -> my_int_of_string (!@loc) i ] ] + ; bigint: (* Negative numbers are dealt with specially *) [ [ i = INT -> (Bigint.of_string i) ] ] ; diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 23bd74da95..d7941bedb4 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -262,9 +262,23 @@ let rec ident_tail len = parser ident_tail (nstore n len s) s | _ -> len -let rec number len = parser - | [< ' ('0'..'9' as c); s >] -> number (store len c) s - | [< >] -> len +let check_no_char s = + match Stream.npeek 3 s with + | [_;_;('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_')] -> false + | [_;_;_] -> true + | [_;_] -> true + | _ -> assert false + +let rec number_or_index c len = parser + | [< ' ('0'..'9' as c); s >] -> number_or_index c (store len c) s + | [< s >] -> + match Stream.npeek 2 s with + | ['s';'t'] when c = '1' && check_no_char s -> njunk 2 s; false, len + | ['n';'d'] when c = '2' && check_no_char s -> njunk 2 s; false, len + | ['r';'d'] when c = '3' && check_no_char s -> njunk 2 s; false, len + | ['t';'h'] when not (len=1 && c='0') && check_no_char s -> + njunk 2 s; false, len + | _ -> true, len let rec string in_comments bp len = parser | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> @@ -513,9 +527,9 @@ let rec next_token = parser bp let id = get_buff len in comment_stop bp; (try find_keyword id s with Not_found -> IDENT id), (bp, ep) - | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> + | [< ' ('0'..'9' as c); (b,len) = number_or_index c (store 0 c) >] ep -> comment_stop bp; - (INT (get_buff len), (bp, ep)) + (if b then INT (get_buff len) else INDEX (get_buff len)), (bp, ep) | [< ''\"'; len = string None bp 0 >] ep -> comment_stop bp; (STRING (get_buff len), (bp, ep)) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 4565b87a01..df0d262062 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -298,6 +298,7 @@ module Prim = let preident = gec_gen (rawwit wit_pre_ident) "preident" let ident = gec_gen (rawwit wit_ident) "ident" let natural = gec_gen (rawwit wit_int) "natural" + let index = gec_gen (rawwit wit_int) "index" let integer = gec_gen (rawwit wit_int) "integer" let bigint = Gram.entry_create "Prim.bigint" let string = gec_gen (rawwit wit_string) "string" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index c224dbad9c..ad4d9e5019 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -173,6 +173,7 @@ module Prim : val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry val natural : int Gram.entry + val index : int Gram.entry val bigint : Bigint.bigint Gram.entry val integer : int Gram.entry val string : string Gram.entry diff --git a/parsing/tok.ml b/parsing/tok.ml index 12140f4036..427080788a 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -15,6 +15,7 @@ type t = | IDENT of string | FIELD of string | INT of string + | INDEX of string | STRING of string | LEFTQMARK | BULLET of string @@ -28,6 +29,7 @@ let equal t1 t2 = match t1, t2 with | IDENT s1, IDENT s2 -> CString.equal s1 s2 | FIELD s1, FIELD s2 -> CString.equal s1 s2 | INT s1, INT s2 -> CString.equal s1 s2 +| INDEX s1, INDEX s2 -> CString.equal s1 s2 | STRING s1, STRING s2 -> CString.equal s1 s2 | LEFTQMARK, LEFTQMARK -> true | BULLET s1, BULLET s2 -> CString.equal s1 s2 @@ -42,6 +44,7 @@ let extract_string = function | PATTERNIDENT s -> s | FIELD s -> s | INT s -> s + | INDEX s -> s | LEFTQMARK -> "?" | BULLET s -> s | EOI -> "" @@ -53,6 +56,7 @@ let to_string = function | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s | FIELD s -> Format.sprintf "FIELD %S" s | INT s -> Format.sprintf "INT %s" s + | INDEX s -> Format.sprintf "INDEX %s" s | STRING s -> Format.sprintf "STRING %S" s | LEFTQMARK -> "LEFTQMARK" | BULLET s -> Format.sprintf "STRING %S" s @@ -76,6 +80,7 @@ let of_pattern = function | "PATTERNIDENT", s -> PATTERNIDENT s | "FIELD", s -> FIELD s | "INT", s -> INT s + | "INDEX", s -> INDEX s | "STRING", s -> STRING s | "LEFTQMARK", _ -> LEFTQMARK | "BULLET", s -> BULLET s @@ -89,6 +94,7 @@ let to_pattern = function | PATTERNIDENT s -> "PATTERNIDENT", s | FIELD s -> "FIELD", s | INT s -> "INT", s + | INDEX s -> "INDEX", s | STRING s -> "STRING", s | LEFTQMARK -> "LEFTQMARK", "" | BULLET s -> "BULLET", s @@ -103,6 +109,7 @@ let match_pattern = | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) | "INT", "" -> (function INT s -> s | _ -> err ()) + | "INDEX", "" -> (function INDEX s -> s | _ -> err ()) | "STRING", "" -> (function STRING s -> s | _ -> err ()) | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) | "BULLET", "" -> (function BULLET s -> s | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index feee1983d0..3414de36bc 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -15,6 +15,7 @@ type t = | IDENT of string | FIELD of string | INT of string + | INDEX of string | STRING of string | LEFTQMARK | BULLET of string -- cgit v1.2.3 From 8b15e47a6b3ccae696da8e12dbad81ae0a740782 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Dec 2015 11:25:54 +0100 Subject: Changing the order of the goals generated by unshelve. --- tactics/extratactics.ml4 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 827d2e25a6..35efb0b657 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -867,10 +867,11 @@ END (* Unshelves the goal shelved by the tactic. *) TACTIC EXTEND unshelve -| [ "unshelve" tactic0(t) ] -> +| [ "unshelve" tactic1(t) ] -> [ Proofview.with_shelf (Tacinterp.eval_tactic t) >>= fun (gls, ()) -> - Proofview.Unsafe.tclNEWGOALS gls + Proofview.Unsafe.tclGETGOALS >>= fun ogls -> + Proofview.Unsafe.tclSETGOALS (gls @ ogls) ] END -- cgit v1.2.3 From a582737fc27da2c03c8c57c773fc4854c1e88d7a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 14:03:12 +0100 Subject: API: documenting context_chop and removing a duplicate. --- engine/termops.ml | 4 ++-- engine/termops.mli | 7 +++++++ pretyping/indrec.ml | 13 +------------ 3 files changed, 10 insertions(+), 14 deletions(-) diff --git a/engine/termops.ml b/engine/termops.ml index db0f1e4db5..c10c55220b 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -992,8 +992,8 @@ let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } let on_judgment_value f j = { j with uj_val = f j.uj_val } let on_judgment_type f j = { j with uj_type = f j.uj_type } -(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k - variables; skips let-in's *) +(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k non let-in + variables skips let-in's; let-in's in the middle are put in ctx2 *) let context_chop k ctx = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) diff --git a/engine/termops.mli b/engine/termops.mli index 87f74f7435..6083f1ab59 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -202,7 +202,14 @@ val ids_of_named_context : named_context -> Id.t list val ids_of_context : env -> Id.t list val names_of_rel_context : env -> names_context +(* [context_chop n Γ] returns (Γ₁,Γ₂) such that [Γ]=[Γ₂Γ₁], [Γ₁] has + [n] hypotheses, excluding local definitions, and [Γ₁], if not empty, + starts with an hypothesis (i.e. [Γ₁] has the form empty or [x:A;Γ₁'] *) val context_chop : int -> rel_context -> rel_context * rel_context + +(* [env_rel_context_chop n env] extracts out the [n] top declarations + of the rel_context part of [env], counting both local definitions and + hypotheses *) val env_rel_context_chop : int -> env -> env * rel_context (** Set of local names *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 8ea9a5f66a..3f21842e39 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -277,24 +277,13 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = in process_constr env 0 f (List.rev cstr.cs_args, recargs) - -(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k - variables *) -let context_chop k ctx = - let rec chop_aux acc = function - | (0, l2) -> (List.rev acc, l2) - | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t) - | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) - | (_, []) -> failwith "context_chop" - in chop_aux [] (k,ctx) - (* Main function *) let mis_make_indrec env sigma listdepkind mib u = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let evdref = ref sigma in let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in + Termops.context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in let nrec = List.length listdepkind in let depPvec = Array.make mib.mind_ntypes (None : (bool * constr) option) in -- cgit v1.2.3 From a4a0a47dce78a7d580e172331e7e1ee2881dc689 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 14:10:17 +0100 Subject: Fixing e7f7fc3e058 (wrong chop on contexts). This fixes test-suite. --- pretyping/inductiveops.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 82168f9c4a..f429c51eb8 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -308,7 +308,7 @@ let lift_constructor n cs = { let instantiate_params t params sign = let nnonrecpar = rel_context_nhyps sign - List.length params in (* Adjust the signature if recursively non-uniform parameters are not here *) - let _,sign = List.chop nnonrecpar sign in + let _,sign = context_chop nnonrecpar sign in let _,t = decompose_prod_n_assum (rel_context_length sign) t in let subst = subst_of_rel_context_instance sign params in substl subst t -- cgit v1.2.3 From cedcfc9bc386456f3fdd225f739706e4f7a2902c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Dec 2015 10:51:08 +0100 Subject: Refine tactic now shelves unifiable holes. The unshelve tactical can be used to get the shelved holes. This changes the proper ordering of holes though, so expect some broken scripts. Also, the test-suite is not fixed yet. --- tactics/extratactics.ml4 | 2 +- test-suite/bugs/closed/3685.v | 4 +- test-suite/bugs/closed/3686.v | 4 +- test-suite/bugs/closed/3699.v | 16 ++++---- theories/Logic/ClassicalFacts.v | 4 +- theories/Logic/Hurkens.v | 89 +++++++++++++++++++++-------------------- 6 files changed, 60 insertions(+), 59 deletions(-) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 35efb0b657..ca65f08ec0 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -357,7 +357,7 @@ let refine_tac {Glob_term.closure=closure;term=term} = Pretyping.ltac_idents = closure.Glob_term.idents; } in let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in - Tactics.New.refine ~unsafe:false update + Tactics.New.refine ~unsafe:false update <*> Proofview.shelve_unifiable end TACTIC EXTEND refine diff --git a/test-suite/bugs/closed/3685.v b/test-suite/bugs/closed/3685.v index a5bea34a98..7a0c3e6f1d 100644 --- a/test-suite/bugs/closed/3685.v +++ b/test-suite/bugs/closed/3685.v @@ -39,11 +39,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v index b650920b26..df5f667480 100644 --- a/test-suite/bugs/closed/3686.v +++ b/test-suite/bugs/closed/3686.v @@ -33,11 +33,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index 62137f0c06..aad0bb44d5 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -34,8 +34,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -47,8 +47,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. @@ -111,8 +111,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -124,8 +124,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index cdc3e04610..18faacbaf6 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -442,10 +442,10 @@ Section Proof_irrelevance_WEM_CC. Theorem wproof_irrelevance_cc : ~~(b1 = b2). Proof. intros h. - refine (let NB := exist (fun P=>~~P -> P) B _ in _). + unshelve (refine (let NB := exist (fun P=>~~P -> P) B _ in _)). { exact (fun _ => b1). } pose proof (NoRetractToNegativeProp.paradox NB p2b b2p (wp2p2 h) wp2p1) as paradox. - refine (let F := exist (fun P=>~~P->P) False _ in _). + unshelve (refine (let F := exist (fun P=>~~P->P) False _ in _)). { auto. } exact (paradox F). Qed. diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 4e582934af..5c87011e5c 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -266,7 +266,7 @@ End Paradox. (** The [paradox] tactic can be called as a shortcut to use the paradox. *) Ltac paradox h := - refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ));cycle 1. + unshelve (refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ))). End Generic. @@ -319,25 +319,26 @@ Proof. + cbn. exact (fun u F => forall x:u, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + + cbn. exact (fun F => u22u1 (forall x, F x)). + cbn. exact (fun _ x => u22u1_unit _ x). + cbn. exact (fun _ x => u22u1_counit _ x). - + cbn. intros **. now rewrite u22u1_coherent. (** Small universe *) + exact U0. (** The interpretation of the small universe is the image of [U0] in [U1]. *) + cbn. exact (fun X => u02u1 X). + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). + cbn. exact (u12u0 F). + cbn in h. exact (u12u0_counit _ h). + + cbn. easy. + + cbn. intros **. now rewrite u22u1_coherent. + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). Qed. End Paradox. @@ -381,7 +382,7 @@ Qed. Definition Forall {A:Type} (P:A->MProp) : MProp. Proof. - refine (exist _ _ _). + unshelve (refine (exist _ _ _)). + exact (forall x:A, El (P x)). + intros h x. eapply strength in h. @@ -411,27 +412,27 @@ Proof. + exact (fun _ => Forall). + cbn. exact (fun _ _ f => f). + cbn. exact (fun _ _ f => f). - + cbn. easy. + exact Forall. + cbn. exact (fun _ f => f). + cbn. exact (fun _ f => f). - + cbn. easy. (** Small universe *) + exact bool. + exact (fun b => El (b2p b)). + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + apply p2b. + exact B. + + cbn in h. auto. + + cbn. easy. + + cbn. easy. + cbn. auto. + cbn. intros * f. apply p2p1 in f. cbn in f. exact f. - + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + cbn. auto. + cbn. intros * f. apply p2p1 in f. cbn in f. exact f. - + apply p2b. - exact B. - + cbn in h. auto. Qed. End Paradox. @@ -469,18 +470,18 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem paradox : forall B:NProp, El B. Proof. intros B. - refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _));cycle 1. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + exact (fun P => ~~P). - + cbn. auto. - + cbn. auto. - + cbn. auto. + exact bool. + exact p2b. + exact b2p. - + auto. - + auto. + exact B. + exact h. + + cbn. auto. + + cbn. auto. + + cbn. auto. + + auto. + + auto. Qed. End Paradox. @@ -515,18 +516,18 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem mparadox : forall B:NProp, El B. Proof. intros B. - refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _));cycle 1. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + exact (fun P => P). - + cbn. auto. - + cbn. auto. - + cbn. auto. + exact bool. + exact p2b. + exact b2p. - + auto. - + auto. + exact B. + exact h. + + cbn. auto. + + cbn. auto. + + cbn. auto. + + auto. + + auto. Qed. End MParadox. @@ -548,8 +549,8 @@ Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). Theorem paradox : forall B:Prop, B. Proof. intros B. - refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ - (exist _ B (fun x => x))). + unshelve (refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ + (exist _ B (fun x => x)))). + intros p. red. red. exact (p2b (El p)). + cbn. intros b. red. exists (b2p b). exact (fun x => x). + cbn. intros [A H]. cbn. apply p2p1. @@ -596,7 +597,6 @@ Proof. + cbn. exact (fun u F => forall x, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + exact (fun F => forall A:Prop, F(up A)). + cbn. exact (fun F f A => f (up A)). + cbn. @@ -604,20 +604,21 @@ Proof. specialize (f (down A)). rewrite up_down in f. exact f. + + exact Prop. + + cbn. exact (fun X => X). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact P. + + exact h. + + cbn. easy. + cbn. intros F f A. destruct (up_down A). cbn. reflexivity. - + exact Prop. - + cbn. exact (fun X => X). - + cbn. exact (fun A P => forall x:A, P x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. exact (fun A P => forall x:A, P x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. exact P. - + exact h. Qed. End Paradox. @@ -664,37 +665,37 @@ Proof. + cbn. exact (fun X F => forall x:X, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + exact (fun F => forall x:A, F (up x)). + cbn. exact (fun _ f => fun x:A => f (up x)). + cbn. intros * f X. specialize (f (down X)). rewrite up_down in f. exact f. - + cbn. intros ? f X. - destruct (up_down X). cbn. - reflexivity. (** Small universe *) + exact A. (** The interpretation of [A] as a universe is [U]. *) + cbn. exact up. + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (down False). + + rewrite up_down in p. + exact p. + + cbn. easy. + + cbn. intros ? f X. + destruct (up_down X). cbn. + reflexivity. + cbn. intros ? ? f. rewrite up_down. exact f. + cbn. intros ? ? f. rewrite up_down in f. exact f. - + cbn. exact (fun _ F => down (forall x, up (F x))). + cbn. intros ? ? f. rewrite up_down. exact f. + cbn. intros ? ? f. rewrite up_down in f. exact f. - + cbn. exact (down False). - + rewrite up_down in p. - exact p. Qed. End Paradox. @@ -710,7 +711,7 @@ Module PropNeqType. Theorem paradox : Prop <> Type. Proof. intros h. - refine (TypeNeqSmallType.paradox _ _). + unshelve (refine (TypeNeqSmallType.paradox _ _)). + exact Prop. + easy. Qed. -- cgit v1.2.3 From a110ddfd6fc040a805de3f0ec2995b51ff301f5c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Dec 2015 11:31:13 +0100 Subject: Adding a test for the unshelve tactical. --- test-suite/success/unshelve.v | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 test-suite/success/unshelve.v diff --git a/test-suite/success/unshelve.v b/test-suite/success/unshelve.v new file mode 100644 index 0000000000..672222bdd6 --- /dev/null +++ b/test-suite/success/unshelve.v @@ -0,0 +1,11 @@ +Axiom F : forall (b : bool), b = true -> + forall (i : unit), i = i -> True. + +Goal True. +Proof. +unshelve (refine (F _ _ _ _)). ++ exact true. ++ exact tt. ++ exact (@eq_refl bool true). ++ exact (@eq_refl unit tt). +Qed. -- cgit v1.2.3 From 087c61eb7fcf17d4ef6ac5b40765e567b9cbcdc8 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 14:35:29 +0100 Subject: Fixing unexpected length of context in a typing function, detected by cleaning done in e8c47b652a0. It had no serious consequences except having whd-reduction blocked on a let-in when typing a return clause with let-ins in the arity (a priori resulting in return types of the form e.g. "(let x:=t in fun y => T) u" instead of T[x:=t;y:=u], if I'm not mistaking). This fixes 3210.v in test-suite. --- pretyping/typing.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 15abfefb15..2f9803b62f 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -111,7 +111,7 @@ let e_type_case_branches env evdref (ind,largs) pj c = let p = pj.uj_val in let univ = e_is_correct_arity env evdref c pj ind specif params in let lc = build_branches_type ind specif params p in - let n = (snd specif).Declarations.mind_nrealargs in + let n = (snd specif).Declarations.mind_nrealdecls in let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in (lc, ty, univ) -- cgit v1.2.3 From 7fa49442f30dceb7e403fb5dab660002dda7f6e9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 15:25:30 +0100 Subject: Fixing e3cefca41b about supposingly simplifying primitive projections typing. Had built the instance for substitution in the wrong context. --- kernel/indtypes.ml | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index a649ec81e8..11df40caf3 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -681,6 +681,7 @@ let used_section_variables env inds = keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) +let rel_list n m = Array.to_list (rel_vect n m) exception UndefinableExpansion @@ -695,12 +696,16 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params that typechecking projections requires just a substitution and not matching with a parameter context. *) let indty, paramsletsubst = - let inst = extended_rel_list 0 paramslet in - let subst = subst_of_rel_context_instance paramslet inst in + (* [ty] = [Ind inst] is typed in context [params] *) + let inst = extended_rel_vect 0 paramslet in + let ty = mkApp (mkIndU indu, inst) in + (* [Ind inst] is typed in context [params-wo-let] *) + let inst' = rel_list 0 nparamargs in + (* {params-wo-let |- subst:params] *) + let subst = subst_of_rel_context_instance paramslet inst' in + (* {params-wo-let, x:Ind inst' |- subst':(params,x:Ind inst)] *) let subst = (* For the record parameter: *) - mkRel 1 :: List.map (lift 1) subst - in - let ty = mkApp (mkIndU indu, Array.of_list inst) in + mkRel 1 :: List.map (lift 1) subst in ty, subst in let ci = -- cgit v1.2.3 From 3c535011374382bc205a68b1cb59cfa7247d544a Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 15 Dec 2015 17:46:25 +0100 Subject: Extraction: fix a few little glitches with my last commit (replacing unused vars by _) --- plugins/extraction/common.ml | 5 +---- plugins/extraction/haskell.ml | 6 +++++- plugins/extraction/mlutil.ml | 11 +++-------- plugins/extraction/modutil.ml | 11 +++++------ plugins/extraction/ocaml.ml | 6 +++++- 5 files changed, 19 insertions(+), 20 deletions(-) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 97f856944c..8cf3b8194c 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -171,10 +171,7 @@ let push_vars ids (db,avoid) = let ids',avoid' = rename_vars avoid ids in ids', (ids' @ db, avoid') -let get_db_name n (db,_) = - let id = List.nth db (pred n) in - if Id.equal id dummy_name then Id.of_string "__" else id - +let get_db_name n (db,_) = List.nth db (pred n) (*S Renamings of global objects. *) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 00259750d6..da7a4265e6 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -143,7 +143,11 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in apply (pr_id id) + let id = get_db_name n env in + (* Try to survive to the occurrence of a Dummy rel. + TODO: we should get rid of this hack (cf. #592) *) + let id = if Id.equal id dummy_name then Id.of_string "__" else id in + apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 2b606bf13c..eb3046f031 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -514,11 +514,6 @@ let nb_occur_match = (* Replace unused variables by _ *) let dump_unused_vars a = - let dump_id = function - | Dummy -> Dummy - | Id _ -> Id dummy_name - | Tmp _ -> Tmp dummy_name - in let rec ren env a = match a with | MLrel i -> let () = (List.nth env (i-1)) := true in a @@ -527,7 +522,7 @@ let dump_unused_vars a = let occ_id = ref false in let b' = ren (occ_id::env) b in if !occ_id then if b' == b then a else MLlam(id,b') - else MLlam(dump_id id,b') + else MLlam(Dummy,b') | MLletin (id,b,c) -> let occ_id = ref false in @@ -537,7 +532,7 @@ let dump_unused_vars a = if b' == b && c' == c then a else MLletin(id,b',c') else (* 'let' without occurrence: shouldn't happen after simpl *) - MLletin(dump_id id,b',c') + MLletin(Dummy,b',c') | MLcase (t,e,br) -> let e' = ren env e in @@ -572,7 +567,7 @@ let dump_unused_vars a = let b' = ren (List.rev_append occs env) b in let ids' = List.map2 - (fun id occ -> if !occ then id else dump_id id) + (fun id occ -> if !occ then id else Dummy) ids occs in if b' == b && List.equal eq_ml_ident ids ids' then tr diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 6f354b1ce5..c3dc286cd1 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -263,29 +263,28 @@ let dfix_to_mlfix rv av i = order to preserve the global interface, later [depcheck_se] will get rid of them if possible *) -let optim_ast t = dump_unused_vars (normalize t) - let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> - let a = optim_ast (ast_glob_subst !s a) in + let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; - let d = match optimize_fix a with + let d = match dump_unused_vars (optimize_fix a) with | MLfix (0, _, [|c|]) -> Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) | a -> Dterm (r, a, t) in (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> - let av = Array.map (fun a -> optim_ast (ast_glob_subst !s a)) av in + let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s done; - (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) + let av' = Array.map dump_unused_vars av in + (l,SEdecl (Dfix (rv, av', tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 6ff4c25ec4..8c86c77112 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -178,7 +178,11 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in apply (pr_id id) + let id = get_db_name n env in + (* Try to survive to the occurrence of a Dummy rel. + TODO: we should get rid of this hack (cf. #592) *) + let id = if Id.equal id dummy_name then Id.of_string "__" else id in + apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f -- cgit v1.2.3 From 34ea06f2f31cebf00bc7620fac34d963afe6a1dc Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 15 Dec 2015 14:54:07 +0100 Subject: Fix test-suite files after change in refine tactic. Change was introduced by cedcfc9bc386456f3fdd225f739706e4f7a2902c. --- test-suite/bugs/closed/4116.v | 6 +++--- test-suite/bugs/closed/931.v | 2 +- test-suite/bugs/closed/HoTT_coq_090.v | 2 +- test-suite/success/refine.v | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/test-suite/bugs/closed/4116.v b/test-suite/bugs/closed/4116.v index f808cb45e9..5932c9c56e 100644 --- a/test-suite/bugs/closed/4116.v +++ b/test-suite/bugs/closed/4116.v @@ -110,7 +110,7 @@ Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" := - refine (let __transparent_assert_hypothesis := (_ : type) in _); + unshelve refine (let __transparent_assert_hypothesis := (_ : type) in _); [ | ( let H := match goal with H := _ |- _ => constr:(H) end in @@ -321,7 +321,7 @@ Section Grothendieck. Definition Gcategory : PreCategory. Proof. - refine (@Build_PreCategory + unshelve refine (@Build_PreCategory Pair (fun s d => Gmorphism s d) Gidentity @@ -346,7 +346,7 @@ Section Grothendieck2. Instance iscategory_grothendieck_toset : IsCategory (Gcategory F). Proof. intros s d. - refine (isequiv_adjointify _ _ _ _). + unshelve refine (isequiv_adjointify _ _ _ _). { intro m. transparent assert (H' : (s.(c) = d.(c))). diff --git a/test-suite/bugs/closed/931.v b/test-suite/bugs/closed/931.v index e86b3be64e..ea3347a851 100644 --- a/test-suite/bugs/closed/931.v +++ b/test-suite/bugs/closed/931.v @@ -2,6 +2,6 @@ Parameter P : forall n : nat, n=n -> Prop. Goal Prop. refine (P _ _). - 2:instantiate (1:=0). + instantiate (1:=0). trivial. Qed. diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v index 5fa167038d..d77b9b63a2 100644 --- a/test-suite/bugs/closed/HoTT_coq_090.v +++ b/test-suite/bugs/closed/HoTT_coq_090.v @@ -84,7 +84,7 @@ Arguments transport {A} P {x y} p%path_scope u : simpl nomatch. Instance isequiv_path {A B : Type} (p : A = B) : IsEquiv (transport (fun X:Type => X) p) | 0. Proof. - refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); + unshelve refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); admit. Defined. diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 1e667884b8..352abb2af5 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -62,7 +62,7 @@ Abort. Goal (forall n : nat, n = 0 -> Prop) -> Prop. intro P. refine (P _ _). -2:reflexivity. +reflexivity. Abort. (* Submitted by Jacek Chrzaszcz (bug #1102) *) -- cgit v1.2.3 From 0a89d4805a29628c82b994958362dc9d92709020 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 15 Dec 2015 18:56:08 +0100 Subject: Extraction: more cautious use of intermediate result caching (fix #3923) During an extraction, a few tables are maintained to cache intermediate results. Due to modules, the kernel_name index for these caching tables aren't enough. For instance, in bug #3923, a constant is first transparent (from inside the module) then opaque (when seen from the signature). The previous protections were actually obsolete (tests via visible_con), we now checks that the constant_body is still the same. --- plugins/extraction/extraction.ml | 100 +++++++++++++-------------------------- plugins/extraction/table.ml | 48 +++++++++++++------ plugins/extraction/table.mli | 19 +++++--- test-suite/bugs/closed/3923.v | 33 +++++++++++++ 4 files changed, 111 insertions(+), 89 deletions(-) create mode 100644 test-suite/bugs/closed/3923.v diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index f4d14af624..2dc2420c46 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -201,36 +201,6 @@ let parse_ind_args si args relmax = | _ -> parse (i+1) (j+1) s) in parse 1 1 si -let oib_equal o1 o2 = - Id.equal o1.mind_typename o2.mind_typename && - List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && - begin - match o1.mind_arity, o2.mind_arity with - | RegularArity {mind_user_arity=c1; mind_sort=s1}, RegularArity {mind_user_arity=c2; mind_sort=s2} -> - eq_constr c1 c2 && Sorts.equal s1 s2 - | TemplateArity p1, TemplateArity p2 -> - let eq o1 o2 = Option.equal Univ.Level.equal o1 o2 in - List.equal eq p1.template_param_levels p2.template_param_levels && - Univ.Universe.equal p1.template_level p2.template_level - | _, _ -> false - end && - Array.equal Id.equal o1.mind_consnames o2.mind_consnames - -let eq_record x y = - Option.equal (Option.equal (fun (_, x, y) (_, x', y') -> Array.for_all2 eq_constant x x')) x y - -let mib_equal m1 m2 = - Array.equal oib_equal m1.mind_packets m1.mind_packets && - eq_record m1.mind_record m2.mind_record && - (m1.mind_finite : Decl_kinds.recursivity_kind) == m2.mind_finite && - Int.equal m1.mind_ntypes m2.mind_ntypes && - List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps && - Int.equal m1.mind_nparams m2.mind_nparams && - Int.equal m1.mind_nparams_rec m2.mind_nparams_rec && - List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && - (* Univ.UContext.eq *) m1.mind_universes == m2.mind_universes (** FIXME *) - (* m1.mind_universes = m2.mind_universes *) - (*S Extraction of a type. *) (* [extract_type env db c args] is used to produce an ML type from the @@ -360,14 +330,9 @@ and extract_type_scheme env db c p = and extract_ind env kn = (* kn is supposed to be in long form *) let mib = Environ.lookup_mind kn env in - try - (* For a same kn, we can get various bodies due to module substitutions. - We hence check that the mib has not changed from recording - time to retrieving time. Ideally we should also check the env. *) - let (mib0,ml_ind) = lookup_ind kn in - if not (mib_equal mib mib0) then raise Not_found; - ml_ind - with Not_found -> + match lookup_ind kn mib with + | Some ml_ind -> ml_ind + | None -> (* First, if this inductive is aliased via a Module, we process the original inductive if possible. When at toplevel of the monolithic case, we cannot do much @@ -523,28 +488,25 @@ and extract_type_cons env db dbmap c i = (*s Recording the ML type abbreviation of a Coq type scheme constant. *) and mlt_env env r = match r with + | IndRef _ | ConstructRef _ | VarRef _ -> None | ConstRef kn -> - (try - if not (visible_con kn) then raise Not_found; - match lookup_term kn with - | Dtype (_,vl,mlt) -> Some mlt + let cb = Environ.lookup_constant kn env in + match cb.const_body with + | Undef _ | OpaqueDef _ -> None + | Def l_body -> + match lookup_typedef kn cb with + | Some _ as o -> o + | None -> + let typ = Typeops.type_of_constant_type env cb.const_type + (* FIXME not sure if we should instantiate univs here *) in + match flag_of_type env typ with + | Info,TypeScheme -> + let body = Mod_subst.force_constr l_body in + let s = type_sign env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db body (List.length s) + in add_typedef kn cb t; Some t | _ -> None - with Not_found -> - let cb = Environ.lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type - (* FIXME not sure if we should instantiate univs here *) in - match cb.const_body with - | Undef _ | OpaqueDef _ -> None - | Def l_body -> - (match flag_of_type env typ with - | Info,TypeScheme -> - let body = Mod_subst.force_constr l_body in - let s,vl = type_sign_vl env typ in - let db = db_from_sign s in - let t = extract_type_scheme env db body (List.length s) - in add_term kn (Dtype (r, vl, t)); Some t - | _ -> None)) - | _ -> None and expand env = type_expand (mlt_env env) and type2signature env = type_to_signature (mlt_env env) @@ -555,16 +517,18 @@ let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env) (*s Extraction of the type of a constant. *) let record_constant_type env kn opt_typ = - try - if not (visible_con kn) then raise Not_found; - lookup_type kn - with Not_found -> - let typ = match opt_typ with - | None -> Typeops.type_of_constant_type env (lookup_constant kn env).const_type - | Some typ -> typ - in let mlt = extract_type env [] 1 typ [] - in let schema = (type_maxvar mlt, mlt) - in add_type kn schema; schema + let cb = lookup_constant kn env in + match lookup_cst_type kn cb with + | Some schema -> schema + | None -> + let typ = match opt_typ with + | None -> Typeops.type_of_constant_type env cb.const_type + | Some typ -> typ + in + let mlt = extract_type env [] 1 typ [] in + let schema = (type_maxvar mlt, mlt) in + let () = add_cst_type kn cb schema in + schema (*S Extraction of a term. *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 63d792e363..9feaea8cdb 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -72,8 +72,6 @@ let mp_length mp = | _ -> 1 in len mp -let visible_con kn = at_toplevel (base_mp (con_modpath kn)) - let rec prefixes_mp mp = match mp with | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') | _ -> MPset.singleton mp @@ -105,17 +103,30 @@ let labels_of_ref r = (* Theses tables are not registered within coq save/undo mechanism since we reset their contents at each run of Extraction *) -(*s Constants tables. *) +(* We use [constant_body] (resp. [mutual_inductive_body]) as checksum + to ensure that the table contents aren't outdated. *) -let terms = ref (Cmap_env.empty : ml_decl Cmap_env.t) -let init_terms () = terms := Cmap_env.empty -let add_term kn d = terms := Cmap_env.add kn d !terms -let lookup_term kn = Cmap_env.find kn !terms +(*s Constants tables. *) -let types = ref (Cmap_env.empty : ml_schema Cmap_env.t) -let init_types () = types := Cmap_env.empty -let add_type kn s = types := Cmap_env.add kn s !types -let lookup_type kn = Cmap_env.find kn !types +let typedefs = ref (Cmap_env.empty : (constant_body * ml_type) Cmap_env.t) +let init_typedefs () = typedefs := Cmap_env.empty +let add_typedef kn cb t = + typedefs := Cmap_env.add kn (cb,t) !typedefs +let lookup_typedef kn cb = + try + let (cb0,t) = Cmap_env.find kn !typedefs in + if cb0 == cb then Some t else None + with Not_found -> None + +let cst_types = + ref (Cmap_env.empty : (constant_body * ml_schema) Cmap_env.t) +let init_cst_types () = cst_types := Cmap_env.empty +let add_cst_type kn cb s = cst_types := Cmap_env.add kn (cb,s) !cst_types +let lookup_cst_type kn cb = + try + let (cb0,s) = Cmap_env.find kn !cst_types in + if cb0 == cb then Some s else None + with Not_found -> None (*s Inductives table. *) @@ -124,7 +135,14 @@ let inductives = let init_inductives () = inductives := Mindmap_env.empty let add_ind kn mib ml_ind = inductives := Mindmap_env.add kn (mib,ml_ind) !inductives -let lookup_ind kn = Mindmap_env.find kn !inductives +let lookup_ind kn mib = + try + let (mib0,ml_ind) = Mindmap_env.find kn !inductives in + if mib == mib0 then Some ml_ind + else None + with Not_found -> None + +let unsafe_lookup_ind kn = snd (Mindmap_env.find kn !inductives) let inductive_kinds = ref (Mindmap_env.empty : inductive_kind Mindmap_env.t) @@ -244,10 +262,10 @@ let safe_basename_of_global r = | ConstRef kn -> Label.to_id (con_label kn) | IndRef (kn,0) -> Label.to_id (mind_label kn) | IndRef (kn,i) -> - (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename + (try (unsafe_lookup_ind kn).ind_packets.(i).ip_typename with Not_found -> last_chance r) | ConstructRef ((kn,i),j) -> - (try (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) + (try (unsafe_lookup_ind kn).ind_packets.(i).ip_consnames.(j-1) with Not_found -> last_chance r) | VarRef _ -> assert false @@ -876,6 +894,6 @@ let extract_inductive r s l optstr = (*s Tables synchronization. *) let reset_tables () = - init_terms (); init_types (); init_inductives (); + init_typedefs (); init_cst_types (); init_inductives (); init_inductive_kinds (); init_recursors (); init_projs (); init_axioms (); init_opaques (); reset_modfile () diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index a6734dae86..916cf3ad6b 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -55,7 +55,6 @@ val string_of_modfile : module_path -> string val file_of_modfile : module_path -> string val is_toplevel : module_path -> bool val at_toplevel : module_path -> bool -val visible_con : constant -> bool val mp_length : module_path -> int val prefixes_mp : module_path -> MPset.t val common_prefix_from_list : @@ -65,14 +64,22 @@ val labels_of_ref : global_reference -> module_path * Label.t list (*s Some table-related operations *) -val add_term : constant -> ml_decl -> unit -val lookup_term : constant -> ml_decl +(* For avoiding repeated extraction of the same constant or inductive, + we use cache functions below. Indexing by constant name isn't enough, + due to modules we could have a same constant name but different + content. So we check that the [constant_body] hasn't changed from + recording time to retrieving time. Same for inductive : we store + [mutual_inductive_body] as checksum. In both case, we should ideally + also check the env *) -val add_type : constant -> ml_schema -> unit -val lookup_type : constant -> ml_schema +val add_typedef : constant -> constant_body -> ml_type -> unit +val lookup_typedef : constant -> constant_body -> ml_type option + +val add_cst_type : constant -> constant_body -> ml_schema -> unit +val lookup_cst_type : constant -> constant_body -> ml_schema option val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit -val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind +val lookup_ind : mutual_inductive -> mutual_inductive_body -> ml_ind option val add_inductive_kind : mutual_inductive -> inductive_kind -> unit val is_coinductive : global_reference -> bool diff --git a/test-suite/bugs/closed/3923.v b/test-suite/bugs/closed/3923.v new file mode 100644 index 0000000000..0aa029e73d --- /dev/null +++ b/test-suite/bugs/closed/3923.v @@ -0,0 +1,33 @@ +Module Type TRIVIAL. +Parameter t:Type. +End TRIVIAL. + +Module MkStore (Key : TRIVIAL). + +Module St : TRIVIAL. +Definition t := unit. +End St. + +End MkStore. + + + +Module Type CERTRUNTIMETYPES (B : TRIVIAL). + +Parameter cert_fieldstore : Type. +Parameter empty_fieldstore : cert_fieldstore. + +End CERTRUNTIMETYPES. + + + +Module MkCertRuntimeTypes (B : TRIVIAL) : CERTRUNTIMETYPES B. + +Module FieldStore := MkStore B. + +Definition cert_fieldstore := FieldStore.St.t. +Axiom empty_fieldstore : cert_fieldstore. + +End MkCertRuntimeTypes. + +Extraction MkCertRuntimeTypes. (* Was leading to an uncaught Not_found *) -- cgit v1.2.3 From 7212e6c4a742110138a268650a59a67ef28d0582 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 15 Dec 2015 21:15:42 +0100 Subject: Fix test suite after change in extraction. --- test-suite/output/Extraction_matchs_2413.out | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/output/Extraction_matchs_2413.out b/test-suite/output/Extraction_matchs_2413.out index 848abd0096..f738b0d091 100644 --- a/test-suite/output/Extraction_matchs_2413.out +++ b/test-suite/output/Extraction_matchs_2413.out @@ -4,7 +4,7 @@ let test1 b = b (** val test2 : bool -> bool **) -let test2 b = +let test2 _ = False (** val wrong_id : 'a1 hole -> 'a2 hole **) -- cgit v1.2.3 From 33742251e62a49c7996b96ca7077cf985627d14b Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 15 Dec 2015 23:15:02 +0100 Subject: Proof using: do not clear unused section hyps automatically The option is still there, but not documented since it is too dangerous. Hints and type classes instances are not taking cleared variables into account. --- CHANGES | 1 + doc/refman/RefMan-pro.tex | 14 +++++++------- proofs/proof_global.ml | 2 +- test-suite/success/proof_using.v | 3 ++- theories/Lists/List.v | 1 + 5 files changed, 12 insertions(+), 9 deletions(-) diff --git a/CHANGES b/CHANGES index b39d84ba57..a3cec81c1a 100644 --- a/CHANGES +++ b/CHANGES @@ -20,6 +20,7 @@ Tactics - Syntax "p/c" for on-the-fly application of a lemma c before introducing along pattern p changed to p%c1..%cn. The feature and syntax are in experimental stage. +- "Proof using" does not clear unused section variables. Changes from V8.5beta2 to V8.5beta3 =================================== diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 481afa8f87..ed1b79e56e 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -186,7 +186,7 @@ in Section~\ref{ProofWith}. \subsubsection{{\tt Proof using} options} \optindex{Default Proof Using} \optindex{Suggest Proof Using} -\optindex{Proof Using Clear Unused} +% \optindex{Proof Using Clear Unused} The following options modify the behavior of {\tt Proof using}. @@ -201,12 +201,12 @@ The following options modify the behavior of {\tt Proof using}. When {\tt Qed} is performed, suggest a {\tt using} annotation if the user did not provide one. -\variant{\tt Unset Proof Using Clear Unused.} - - When {\tt Proof using a} all section variables but for {\tt a} and - the variables used in the type of {\tt a} are cleared. - This option can be used to turn off this behavior. - +% \variant{\tt Unset Proof Using Clear Unused.} +% +% When {\tt Proof using a} all section variables but for {\tt a} and +% the variables used in the type of {\tt a} are cleared. +% This option can be used to turn off this behavior. +% \subsubsection[\tt Collection]{Name a set of section hypotheses for {\tt Proof using}} \comindex{Collection}\label{Collection} diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 3edd34e5f6..c32e02344d 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -254,7 +254,7 @@ let start_dependent_proof id ?pl str goals terminator = let get_used_variables () = (cur_pstate ()).section_vars let get_universe_binders () = (cur_pstate ()).universe_binders -let proof_using_auto_clear = ref true +let proof_using_auto_clear = ref false let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index c83f45e2a4..adaa05ad06 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -178,6 +178,7 @@ End Let. Check (test_let 3). +(* Disabled Section Clear. Variable a: nat. @@ -192,6 +193,6 @@ trivial. Qed. End Clear. - +*) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index fe18686e21..443dd683d2 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -970,6 +970,7 @@ Section Map. Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B), In y (flat_map f l) <-> exists x, In x l /\ In y (f x). Proof using A B. + clear Hfinjective. induction l; simpl; split; intros. contradiction. destruct H as (x,(H,_)); contradiction. -- cgit v1.2.3 From 0c60735279301d22ac3e03f862f86997cb85bce0 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 16 Dec 2015 00:59:38 +0100 Subject: Extraction: fixed beta-red with Obj.magic (#2795 again) + other simplifications Unfortunately, my first attempt at replacing (Obj.magic (fun x -> u) v) by ((fun x -> Obj.magic u) v) was badly typed, as seen in FingerTree: the argument v should also be magic now, otherwise it might not have the same type as x. This optimization is now correctly done, and to mitigate the potential inflation of Obj.magic, I've added a few simplification rules to avoid redundant magics, push them down inside terms, favor the form (Obj.magic f x y z), etc. --- plugins/extraction/mlutil.ml | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index eb3046f031..d06583010f 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1035,6 +1035,13 @@ let rec simpl o = function if ast_occurs_itvl 1 n c.(i) then MLfix (i, ids, Array.map (simpl o) c) else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) + | MLmagic(MLmagic _ as e) -> simpl o e + | MLmagic(MLapp (f,l)) -> simpl o (MLapp (MLmagic f, l)) + | MLmagic(MLletin(id,c,e)) -> simpl o (MLletin(id,c,MLmagic e)) + | MLmagic(MLcase(typ,e,br)) -> + let br' = Array.map (fun (ids,p,c) -> (ids,p,MLmagic c)) br in + simpl o (MLcase(typ,e,br')) + | MLmagic(MLexn _ as e) -> e | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) @@ -1053,8 +1060,17 @@ and simpl_app o a = function simpl o (MLletin (id, List.hd a, MLapp (t, a')))) | MLmagic (MLlam (id,t)) -> (* When we've at least one argument, we permute the magic - and the lambda, to simplify things a bit (see #2795) *) - simpl_app o a (MLlam (id,MLmagic t)) + and the lambda, to simplify things a bit (see #2795). + Alas, the 1st argument must also be magic then. *) + let a' = match a with + | MLmagic _ :: _ -> a + | e::a' -> MLmagic e::a' + | [] -> assert false + in + simpl_app o a' (MLlam (id,MLmagic t)) + | MLmagic _ as e -> + (* When the head is magic, no need for magic on args *) + MLapp (e, List.map (function MLmagic e -> e | e -> e) a) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) -- cgit v1.2.3 From 53ab313dcf7ae524a9a8312658c1e9869a4039f7 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 16 Dec 2015 11:43:53 +0100 Subject: Extraction: slightly better heuristic for Obj.magic simplifications On an application (f args) where the head is magic, we first remove Obj.magic on arguments before continuing with simplifications (that may push magic down inside the arguments). For instance, starting with ((Obj.magic f) (Obj.magic (g h))), we now end with ((Obj.magic f) (g h)) instead of ((Obj.magic f) ((Obj.magic g) h))) as before. --- plugins/extraction/mlutil.ml | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index d06583010f..62724f2119 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1013,9 +1013,20 @@ let expand_linear_let o id e = (* Some beta-iota reductions + simplifications. *) +let rec unmagic = function MLmagic e -> unmagic e | e -> e +let is_magic = function MLmagic _ -> true | _ -> false +let magic_hd a = match a with + | MLmagic _ :: _ -> a + | e :: a -> MLmagic e :: a + | [] -> assert false + let rec simpl o = function | MLapp (f, []) -> simpl o f - | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f) + | MLapp (MLapp(f,a),a') -> simpl o (MLapp(f,a@a')) + | MLapp (f, a) -> + (* When the head of the application is magic, no need for magic on args *) + let a = if is_magic f then List.map unmagic a else a in + simpl_app o (List.map (simpl o) a) (simpl o f) | MLcase (typ,e,br) -> let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in simpl_case o typ br (simpl o e) @@ -1047,7 +1058,6 @@ let rec simpl o = function (* invariant : list [a] of arguments is non-empty *) and simpl_app o a = function - | MLapp (f',a') -> simpl_app o (a'@a) f' | MLlam (Dummy,t) -> simpl o (MLapp (ast_pop t, List.tl a)) | MLlam (id,t) -> (* Beta redex *) @@ -1062,15 +1072,7 @@ and simpl_app o a = function (* When we've at least one argument, we permute the magic and the lambda, to simplify things a bit (see #2795). Alas, the 1st argument must also be magic then. *) - let a' = match a with - | MLmagic _ :: _ -> a - | e::a' -> MLmagic e::a' - | [] -> assert false - in - simpl_app o a' (MLlam (id,MLmagic t)) - | MLmagic _ as e -> - (* When the head is magic, no need for magic on args *) - MLapp (e, List.map (function MLmagic e -> e | e -> e) a) + simpl_app o (magic_hd a) (MLlam (id,MLmagic t)) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) -- cgit v1.2.3 From b8d1e84e9326df34383e5e5c8c5842cb7013b935 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 16 Dec 2015 18:30:32 +0100 Subject: Add a "simple refine" variant of "refine" that does not call "shelve_unifiable". --- CHANGES | 14 +++++++++----- doc/refman/RefMan-tac.tex | 17 +++++++++++++---- tactics/extratactics.ml4 | 11 ++++++++--- 3 files changed, 30 insertions(+), 12 deletions(-) diff --git a/CHANGES b/CHANGES index a3cec81c1a..df2fc967dd 100644 --- a/CHANGES +++ b/CHANGES @@ -1,11 +1,12 @@ Changes from V8.5beta3 ====================== -Vernacular commands -- Flag -compat 8.4 now loads Coq.Compat.Coq84. The standard way of putting Coq - in v8.4 compatibility mode is to pass the command line flag "-compat 8.4". It - can be followed by "-require Coq.Compat.AdmitAxiom" if 8.4 behavior of admit is - needed, in which case it uses an axiom. +Tools + +- Flag "-compat 8.4" now loads Coq.Compat.Coq84. The standard way of + putting Coq in v8.4 compatibility mode is to pass the command line flag + "-compat 8.4". It can be followed by "-require Coq.Compat.AdmitAxiom" + if the 8.4 behavior of admit is needed, in which case it uses an axiom. Specification language @@ -21,6 +22,9 @@ Tactics introducing along pattern p changed to p%c1..%cn. The feature and syntax are in experimental stage. - "Proof using" does not clear unused section variables. +- "refine" has been changed back to the 8.4 behavior of shelving subgoals + that occur in other subgoals. The "refine" tactic of 8.5beta2 has been + renamed "simple refine"; it does not shelve any subgoal. Changes from V8.5beta2 to V8.5beta3 =================================== diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 3a3877105b..d90a027295 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -219,8 +219,10 @@ difference: the user can leave some holes (denoted by \texttt{\_} or {\tt (\_:\type)}) in the term. {\tt refine} will generate as many subgoals as there are holes in the term. The type of holes must be either synthesized by the system or declared by an -explicit cast like \verb|(_:nat->Prop)|. This low-level -tactic can be useful to advanced users. +explicit cast like \verb|(_:nat->Prop)|. Any subgoal that occurs in other +subgoals is automatically shelved, as if calling {\tt shelve\_unifiable} +(see Section~\ref{shelve}). +This low-level tactic can be useful to advanced users. \Example @@ -256,6 +258,13 @@ Defined. which type cannot be inferred. Put a cast around it. \end{ErrMsgs} +\begin{Variants} +\item {\tt simple refine \term}\tacindex{simple refine} + + This tactic behaves like {\tt refine}, but it does not shelve any + subgoal. It does not perform any beta-reduction either. +\end{Variants} + \subsection{\tt apply \term} \tacindex{apply} \label{apply} @@ -4964,8 +4973,8 @@ back into focus with the command {\tt Unshelve} (Section~\ref{unshelve}). \begin{Variants} \item \texttt{shelve\_unifiable}\tacindex{shelve\_unifiable} - Shelves only these goals under focused which are mentioned in other goals. - Goals which appear in the type of other goals can be solve by unification. + Shelves only the goals under focus that are mentioned in other goals. + Goals that appear in the type of other goals can be solved by unification. \Example \begin{coq_example} diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index ca65f08ec0..e06997029d 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -345,7 +345,7 @@ END (**********************************************************************) (* Refine *) -let refine_tac {Glob_term.closure=closure;term=term} = +let refine_tac simple {Glob_term.closure=closure;term=term} = Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -357,11 +357,16 @@ let refine_tac {Glob_term.closure=closure;term=term} = Pretyping.ltac_idents = closure.Glob_term.idents; } in let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in - Tactics.New.refine ~unsafe:false update <*> Proofview.shelve_unifiable + let refine = Proofview.Refine.refine ~unsafe:false update in + if simple then refine + else refine <*> + Tactics.New.reduce_after_refine <*> + Proofview.shelve_unifiable end TACTIC EXTEND refine - [ "refine" uconstr(c) ] -> [ refine_tac c ] +| [ "refine" uconstr(c) ] -> [ refine_tac false c ] +| [ "simple" "refine" uconstr(c) ] -> [ refine_tac true c ] END (**********************************************************************) -- cgit v1.2.3 From 793cf771e18be3d44d3fcf89998dec50fb8229f3 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 16 Dec 2015 21:33:03 +0100 Subject: FIx parsing of tactic "simple refine". --- tactics/extratactics.ml4 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index e06997029d..1d594aa7c9 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -366,6 +366,9 @@ let refine_tac simple {Glob_term.closure=closure;term=term} = TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> [ refine_tac false c ] +END + +TACTIC EXTEND simple_refine | [ "simple" "refine" uconstr(c) ] -> [ refine_tac true c ] END -- cgit v1.2.3 From 8913baad8de063f5a215a342d04929ac75d75c28 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 16 Dec 2015 22:28:35 +0100 Subject: Update version numbers and magic numbers for 8.5rc1 release. --- CHANGES | 4 ++-- configure.ml | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/CHANGES b/CHANGES index df2fc967dd..b30bcc662d 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,5 @@ -Changes from V8.5beta3 -====================== +Changes from V8.5beta3 to V8.5 +============================== Tools diff --git a/configure.ml b/configure.ml index 51033c3d01..044e78c09d 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.5beta3" -let coq_macos_version = "8.4.93" (** "[...] should be a string comprised of +let coq_version = "8.5rc1" +let coq_macos_version = "8.5.0" (** "[...] should be a string comprised of three non-negative, period-separed integers [...]" *) -let vo_magic = 8493 -let state_magic = 58503 +let vo_magic = 8500 +let state_magic = 58500 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] -- cgit v1.2.3 From 04394d4f17bff1739930ddca5d31cb9bb031078b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 16 Dec 2015 22:37:32 +0100 Subject: Updating credits. --- doc/refman/RefMan-pre.tex | 73 +++++++++++++++++++++++++++++++++++------------ 1 file changed, 54 insertions(+), 19 deletions(-) diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index f45072ca43..e0dc496666 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -956,20 +956,20 @@ Ltac language dependent subgoals, deep backtracking and multiple goal handling, along with miscellaneous features and an improved potential for future modifications. Dependent subgoals allow statements in a goal to mention the proof of another. Proofs of unsolved subgoals -appear as existential variables. Primitive backtracking make it +appear as existential variables. Primitive backtracking makes it possible to write a tactic with several possible outcomes which are tried successively when subsequent tactics fail. Primitives are also available to control the backtracking behavior of tactics. Multiple goal handling paves the way for smarter automation tactics. It is currently used for simple goal manipulation such as goal reordering. -The way Coq processes a document in batch and interactive mode has +The way {\Coq} processes a document in batch and interactive mode has been redesigned by Enrico Tassi with help from Bruno Barras. Opaque proofs, the text between Proof and Qed, can be processed asynchronously, decoupling the checking of definitions and statements from the checking of proofs. It improves the responsiveness of interactive development, since proofs can be processed in the -background. Similarly compilation of a file can be split into two +background. Similarly, compilation of a file can be split into two phases: the first one checking only definitions and statements and the second one checking proofs. A file resulting from the first phase~--~with the .vio extension~--~can be already Required. All .vio @@ -977,13 +977,13 @@ files can be turned into complete .vo files in parallel. The same infrastructure also allows terminating tactics to be run in parallel on a set of goals via the \verb=par:= goal selector. -CoqIDE was modified to cope with asynchronous checking of the -document. Its source code was also made separate from that of Coq, so -that CoqIDE no longer has a special status among user interfaces, -paving the way for decoupling its release cycle from that of Coq in +{\CoqIDE} was modified to cope with asynchronous checking of the +document. Its source code was also made separate from that of {\Coq}, so +that {\CoqIDE} no longer has a special status among user interfaces, +paving the way for decoupling its release cycle from that of {\Coq} in the future. -Carst Tankink developed a Coq back end for user interfaces built on +Carst Tankink developed a {\Coq} back-end for user interfaces built on Makarius Wenzel's Prover IDE framework (PIDE), like PIDE/jEdit (with help from Makarius Wenzel) or PIDE/Coqoon (with help from Alexander Faithfull and Jesper Bengtson). The development of such features was @@ -1017,7 +1017,7 @@ principles such as propositional extensionality and univalence, thanks to Maxime Dénès and Bruno Barras. To ensure compatibility with the univalence axiom, a new flag ``-indices-matter'' has been implemented, taking into account the universe levels of indices when computing the -levels of inductive types. This supports using Coq as a tool to explore +levels of inductive types. This supports using {\Coq} as a tool to explore the relations between homotopy theory and type theory. Maxime Dénès and Benjamin Grégoire developed an implementation of @@ -1025,17 +1025,23 @@ conversion test and normal form computation using the OCaml native compiler. It complements the virtual machine conversion offering much faster computation for expensive functions. -{\Coq} 8.5 also comes with a bunch of many various smaller-scale changes -and improvements regarding the different components of the system. +{\Coq} 8.5 also comes with a bunch of many various smaller-scale +changes and improvements regarding the different components of the +system. We shall only list a few of them. + +Pierre Boutillier developed an improved tactic for simplification of +expressions called {\tt cbn}. -Maxime Dénès maintained the bytecode-based reduction machine. +Maxime Dénès maintained the bytecode-based reduction machine. Pierre +Letouzey maintained the extraction mechanism. Pierre-Marie Pédrot has extended the syntax of terms to, experimentally, allow holes in terms to be solved by a locally specified tactic. Existential variables are referred to by identifiers rather than mere -numbers, thanks to Hugo Herbelin. +numbers, thanks to Hugo Herbelin who also improved the tactic language +here and there. Error messages for universe inconsistencies have been improved by Matthieu Sozeau. Error messages for unification and type inference @@ -1043,14 +1049,43 @@ failures have been improved by Hugo Herbelin, Pierre-Marie Pédrot and Arnaud Spiwack. Pierre Courtieu contributed new features for using {\Coq} through Proof -General and for better interactive experience (bullets, Search etc). - -A distribution channel for Coq packages using the Opam tool has been -developed by Thomas Braibant and Guillaume Claret. +General and for better interactive experience (bullets, Search, etc). + +The efficiency of the whole system has been significantly improved +thanks to contributions from Pierre-Marie Pédrot. + +A distribution channel for {\Coq} packages using the OPAM tool has +been initiated by Thomas Braibant and developed by Guillaume Claret, +with contributions by Enrico Tassi and feedback from Hugo Herbelin. + +Packaging tools were provided by Pierre Letouzey and Enrico Tassi +(Windows), Pierre Boutillier, Matthieu Sozeau and Maxime Dénès (MacOS +X). Maxime Dénès improved significantly the testing and benchmarking +support. + +Many power users helped to improve the design of the new features via +the bug tracker, the coq development mailing list or the coq-club +mailing list. Special thanks are going to the users who contributed +patches and intensive brain-storming, starting with Jason Gross, +Jonathan Leivent, Greg Malecha, Clément Pit-Claudel, Marc Lasson, +Lionel Rieg. It would however be impossible to mention with precision +all names of people who to some extent influenced the development. + +Version 8.5 is one of the most important release of {\Coq}. Its +development spanned over about 3 years and a half with about one year +of beta-testing. General maintenance during part or whole of this +period has been done by Pierre Boutillier, Pierre Courtieu, Maxime +Dénès, Hugo Herbelin, Pierre Letouzey, Guillaume Melquiond, +Pierre-Marie Pédrot, Matthieu Sozeau, Arnaud Spiwack, Enrico Tassi as +well as Bruno Barras, Yves Bertot, Frédéric Besson, Xavier Clerc, +Pierre Corbineau, Jean-Christophe Filliâtre, Julien Forest, Sébastien +Hinderer, Assia Mahboubi, Jean-Marc Notin, Yann Régis-Gianas, François +Ripault, Carst Tankink. Maxime Dénès brilliantly coordinated the +release process. \begin{flushright} -Paris, January 2015\\ -Hugo Herbelin \& Matthieu Sozeau\\ +Paris, January 2015, revised December 2015,\\ +Hugo Herbelin, Matthieu Sozeau and the {\Coq} development team\\ \end{flushright} -- cgit v1.2.3 From 597e5dd737dd235222798153b2342ae609519348 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 16 Dec 2015 20:03:45 +0100 Subject: Getting rid of some hardwired generic arguments. --- grammar/argextend.ml4 | 4 ---- grammar/q_coqast.ml4 | 4 ---- interp/constrarg.ml | 12 ++++++++---- lib/genarg.ml | 12 ------------ lib/genarg.mli | 4 ---- printing/pptactic.ml | 40 +++++++++++++--------------------------- tactics/tacintern.ml | 19 +++++++------------ tactics/tacinterp.ml | 51 ++++++++++++++++++++------------------------------- tactics/tacsubst.ml | 19 ++++++------------- 9 files changed, 54 insertions(+), 111 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 08651de640..a49291d947 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -33,14 +33,10 @@ let rec make_wit loc = function | IntOrVarArgType -> <:expr< Constrarg.wit_int_or_var >> | IdentArgType -> <:expr< Constrarg.wit_ident >> | VarArgType -> <:expr< Constrarg.wit_var >> - | QuantHypArgType -> <:expr< Constrarg.wit_quant_hyp >> | GenArgType -> <:expr< Constrarg.wit_genarg >> | ConstrArgType -> <:expr< Constrarg.wit_constr >> | ConstrMayEvalArgType -> <:expr< Constrarg.wit_constr_may_eval >> - | RedExprArgType -> <:expr< Constrarg.wit_red_expr >> | OpenConstrArgType -> <:expr< Constrarg.wit_open_constr >> - | ConstrWithBindingsArgType -> <:expr< Constrarg.wit_constr_with_bindings >> - | BindingsArgType -> <:expr< Constrarg.wit_bindings >> | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> | PairArgType (t1,t2) -> diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index dd97107f72..be438b54a5 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -226,11 +226,7 @@ let rec mlexpr_of_argtype loc = function | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >> | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> - | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >> - | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> - | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >> - | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >> | Genarg.GenArgType -> <:expr< Genarg.GenArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> diff --git a/interp/constrarg.ml b/interp/constrarg.ml index a7241399e0..a67143b005 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -36,7 +36,7 @@ let wit_var = unsafe_of_type VarArgType let wit_ref = Genarg.make0 None "ref" -let wit_quant_hyp = unsafe_of_type QuantHypArgType +let wit_quant_hyp = Genarg.make0 None "quant_hyp" let wit_genarg = unsafe_of_type GenArgType @@ -51,14 +51,14 @@ let wit_uconstr = Genarg.make0 None "uconstr" let wit_open_constr = unsafe_of_type OpenConstrArgType -let wit_constr_with_bindings = unsafe_of_type ConstrWithBindingsArgType +let wit_constr_with_bindings = Genarg.make0 None "constr_with_bindings" -let wit_bindings = unsafe_of_type BindingsArgType +let wit_bindings = Genarg.make0 None "bindings" let wit_hyp_location_flag : 'a Genarg.uniform_genarg_type = Genarg.make0 None "hyp_location_flag" -let wit_red_expr = unsafe_of_type RedExprArgType +let wit_red_expr = Genarg.make0 None "redexpr" let wit_clause_dft_concl = Genarg.make0 None "clause_dft_concl" @@ -71,4 +71,8 @@ let () = register_name0 wit_tactic "Constrarg.wit_tactic"; register_name0 wit_sort "Constrarg.wit_sort"; register_name0 wit_uconstr "Constrarg.wit_uconstr"; + register_name0 wit_red_expr "Constrarg.wit_red_expr"; register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl"; + register_name0 wit_quant_hyp "Constrarg.wit_quant_hyp"; + register_name0 wit_bindings "Constrarg.wit_bindings"; + register_name0 wit_constr_with_bindings "Constrarg.wit_constr_with_bindings"; diff --git a/lib/genarg.ml b/lib/genarg.ml index 149d872c52..8712eda8e1 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -18,11 +18,7 @@ type argument_type = | GenArgType | ConstrArgType | ConstrMayEvalArgType - | QuantHypArgType | OpenConstrArgType - | ConstrWithBindingsArgType - | BindingsArgType - | RedExprArgType | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type @@ -35,11 +31,7 @@ let rec argument_type_eq arg1 arg2 = match arg1, arg2 with | GenArgType, GenArgType -> true | ConstrArgType, ConstrArgType -> true | ConstrMayEvalArgType, ConstrMayEvalArgType -> true -| QuantHypArgType, QuantHypArgType -> true | OpenConstrArgType, OpenConstrArgType -> true -| ConstrWithBindingsArgType, ConstrWithBindingsArgType -> true -| BindingsArgType, BindingsArgType -> true -| RedExprArgType, RedExprArgType -> true | ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 | OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 | PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) -> @@ -54,11 +46,7 @@ let rec pr_argument_type = function | GenArgType -> str "genarg" | ConstrArgType -> str "constr" | ConstrMayEvalArgType -> str "constr_may_eval" -| QuantHypArgType -> str "qhyp" | OpenConstrArgType -> str "open_constr" -| ConstrWithBindingsArgType -> str "constr_with_bindings" -| BindingsArgType -> str "bindings" -| RedExprArgType -> str "redexp" | ListArgType t -> pr_argument_type t ++ spc () ++ str "list" | OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" | PairArgType (t1, t2) -> diff --git a/lib/genarg.mli b/lib/genarg.mli index 3a18581d7b..2dcaa789f7 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -190,11 +190,7 @@ type argument_type = | GenArgType | ConstrArgType | ConstrMayEvalArgType - | QuantHypArgType | OpenConstrArgType - | ConstrWithBindingsArgType - | BindingsArgType - | RedExprArgType | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 97917d2c72..dfb8837eca 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -275,15 +275,7 @@ module Make | ConstrMayEvalArgType -> pr_may_eval prc prlc (pr_or_by_notation prref) prpat (out_gen (rawwit wit_constr_may_eval) x) - | QuantHypArgType -> pr_quantified_hypothesis (out_gen (rawwit wit_quant_hyp) x) - | RedExprArgType -> - pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat) - (out_gen (rawwit wit_red_expr) x) | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x)) - | ConstrWithBindingsArgType -> - pr_with_bindings prc prlc (out_gen (rawwit wit_constr_with_bindings) x) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen (rawwit wit_bindings) x) | ListArgType _ -> let list_unpacker wit l = let map x = pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x) in @@ -320,17 +312,7 @@ module Make pr_may_eval prc prlc (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat (out_gen (glbwit wit_constr_may_eval) x) - | QuantHypArgType -> - pr_quantified_hypothesis (out_gen (glbwit wit_quant_hyp) x) - | RedExprArgType -> - pr_red_expr - (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat) - (out_gen (glbwit wit_red_expr) x) | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x)) - | ConstrWithBindingsArgType -> - pr_with_bindings prc prlc (out_gen (glbwit wit_constr_with_bindings) x) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen (glbwit wit_bindings) x) | ListArgType _ -> let list_unpacker wit l = let map x = pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x) in @@ -363,16 +345,7 @@ module Make | GenArgType -> pr_top_generic prc prlc prtac prpat (out_gen (topwit wit_genarg) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x) - | QuantHypArgType -> pr_quantified_hypothesis (out_gen (topwit wit_quant_hyp) x) - | RedExprArgType -> - pr_red_expr (prc,prlc,pr_evaluable_reference,prpat) - (out_gen (topwit wit_red_expr) x) | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x)) - | ConstrWithBindingsArgType -> - let (c,b) = (out_gen (topwit wit_constr_with_bindings) x).Evd.it in - pr_with_bindings prc prlc (c,b) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen (topwit wit_bindings) x).Evd.it | ListArgType _ -> let list_unpacker wit l = let map x = pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x) in @@ -1461,6 +1434,19 @@ let () = (fun (c,_) -> Printer.pr_glob_constr c) Printer.pr_closed_glob ; + Genprint.register_print0 Constrarg.wit_red_expr + (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) + (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) + (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); + Genprint.register_print0 Constrarg.wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + Genprint.register_print0 Constrarg.wit_bindings + (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) + (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + (fun { Evd.it = it } -> pr_bindings_no_with pr_constr pr_lconstr it); + Genprint.register_print0 Constrarg.wit_constr_with_bindings + (pr_with_bindings pr_constr_expr pr_lconstr_expr) + (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + (fun { Evd.it = it } -> pr_with_bindings pr_constr pr_lconstr it); Genprint.register_print0 Stdarg.wit_int int int int; Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index b5a3633715..ac1229f2f7 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -739,16 +739,8 @@ and intern_genarg ist x = map_raw wit_constr intern_constr ist x | ConstrMayEvalArgType -> map_raw wit_constr_may_eval intern_constr_may_eval ist x - | QuantHypArgType -> - map_raw wit_quant_hyp intern_quantified_hypothesis ist x - | RedExprArgType -> - map_raw wit_red_expr intern_red_expr ist x | OpenConstrArgType -> map_raw wit_open_constr (fun ist -> on_snd (intern_constr ist)) ist x - | ConstrWithBindingsArgType -> - map_raw wit_constr_with_bindings intern_constr_with_bindings ist x - | BindingsArgType -> - map_raw wit_bindings intern_bindings ist x | ListArgType _ -> let list_unpacker wit l = let map x = @@ -848,10 +840,13 @@ let () = let () = Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); - Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)) - -let () = - Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)) + Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); + Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); + Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_red_expr (lift intern_red_expr); + Genintern.register_intern0 wit_bindings (lift intern_bindings); + Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); + () (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index b2afba4af8..6ac16bd76a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1209,9 +1209,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacAlias (loc,s,l) -> let body = Tacenv.interp_alias s in let rec f x = match genarg_tag x with - | QuantHypArgType | RedExprArgType - | ConstrWithBindingsArgType - | BindingsArgType | ConstrArgType | ListArgType ConstrArgType | OptArgType _ | PairArgType _ -> (** generic handler *) @@ -1630,29 +1627,12 @@ and interp_genarg ist env sigma concl gl x = let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (out_gen (glbwit wit_constr_may_eval) x) in evdref := sigma; in_gen (topwit wit_constr_may_eval) c_interp - | QuantHypArgType -> - in_gen (topwit wit_quant_hyp) - (interp_declared_or_quantified_hypothesis ist env sigma - (out_gen (glbwit wit_quant_hyp) x)) - | RedExprArgType -> - let (sigma,r_interp) = - interp_red_expr ist env !evdref (out_gen (glbwit wit_red_expr) x) - in - evdref := sigma; - in_gen (topwit wit_red_expr) r_interp | OpenConstrArgType -> let expected_type = WithoutTypeConstraint in in_gen (topwit wit_open_constr) (interp_open_constr ~expected_type ist env !evdref (snd (out_gen (glbwit wit_open_constr) x))) - | ConstrWithBindingsArgType -> - in_gen (topwit wit_constr_with_bindings) - (pack_sigma (interp_constr_with_bindings ist env !evdref - (out_gen (glbwit wit_constr_with_bindings) x))) - | BindingsArgType -> - in_gen (topwit wit_bindings) - (pack_sigma (interp_bindings ist env !evdref (out_gen (glbwit wit_bindings) x))) | ListArgType ConstrArgType -> let (sigma,v) = interp_genarg_constr_list ist env !evdref x in evdref := sigma; @@ -2314,15 +2294,27 @@ let () = let () = declare_uniform wit_pre_ident +let lift f = (); fun ist gl x -> (project gl, f ist (pf_env gl) (project gl) x) +let lifts f = (); fun ist gl x -> f ist (pf_env gl) (project gl) x + +let interp_bindings' ist gl bl = + let (sigma, bl) = interp_bindings ist (pf_env gl) (project gl) bl in + (project gl, pack_sigma (sigma, bl)) + +let interp_constr_with_bindings' ist gl c = + let (sigma, c) = interp_constr_with_bindings ist (pf_env gl) (project gl) c in + (project gl, pack_sigma (sigma, c)) + let () = - let interp ist gl ref = (project gl, interp_reference ist (pf_env gl) (project gl) ref) in - Geninterp.register_interp0 wit_ref interp; - let interp ist gl pat = interp_intro_pattern ist (pf_env gl) (project gl) pat in - Geninterp.register_interp0 wit_intro_pattern interp; - let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) (project gl) pat) in - Geninterp.register_interp0 wit_clause_dft_concl interp; - let interp ist gl s = interp_sort (project gl) s in - Geninterp.register_interp0 wit_sort interp + Geninterp.register_interp0 wit_ref (lift interp_reference); + Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); + Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); + Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); + Geninterp.register_interp0 wit_tacvalue (fun ist gl c -> project gl, c); + Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); + Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + Geninterp.register_interp0 wit_bindings interp_bindings'; + Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings' let () = let interp ist gl tac = @@ -2336,9 +2328,6 @@ let () = project gl , interp_uconstr ist (pf_env gl) c ) -let () = - Geninterp.register_interp0 wit_tacvalue (fun ist gl c -> project gl, c) - (***************************************************************************) (* Other entry points *) diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index f5b6c3250d..6d32aa81b9 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -289,21 +289,9 @@ and subst_genarg subst (x:glob_generic_argument) = in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) | ConstrMayEvalArgType -> in_gen (glbwit wit_constr_may_eval) (subst_raw_may_eval subst (out_gen (glbwit wit_constr_may_eval) x)) - | QuantHypArgType -> - in_gen (glbwit wit_quant_hyp) - (subst_declared_or_quantified_hypothesis subst - (out_gen (glbwit wit_quant_hyp) x)) - | RedExprArgType -> - in_gen (glbwit wit_red_expr) (subst_redexp subst (out_gen (glbwit wit_red_expr) x)) | OpenConstrArgType -> in_gen (glbwit wit_open_constr) ((),subst_glob_constr subst (snd (out_gen (glbwit wit_open_constr) x))) - | ConstrWithBindingsArgType -> - in_gen (glbwit wit_constr_with_bindings) - (subst_glob_with_bindings subst (out_gen (glbwit wit_constr_with_bindings) x)) - | BindingsArgType -> - in_gen (glbwit wit_bindings) - (subst_bindings subst (out_gen (glbwit wit_bindings) x)) | ListArgType _ -> let list_unpacker wit l = let map x = @@ -340,4 +328,9 @@ let () = Genintern.register_subst0 wit_tactic subst_tactic; Genintern.register_subst0 wit_sort (fun _ v -> v); Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); - Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c) + Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_red_expr subst_redexp; + Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; + Genintern.register_subst0 wit_bindings subst_bindings; + Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; + () -- cgit v1.2.3 From 39b13903e7a6824f4405f61bb4b41a30cfbd0b3c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 9 Dec 2015 12:30:32 +0100 Subject: CLEANUP: in the Reduction module --- engine/evd.ml | 4 ++-- kernel/reduction.ml | 50 ++++++++++++++++------------------------------- kernel/reduction.mli | 19 ++++-------------- pretyping/reductionops.ml | 8 ++++---- 4 files changed, 27 insertions(+), 54 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index 425b67e080..2060141644 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -926,10 +926,10 @@ let update_sigma_env evd env = let test_conversion_gen env evd pb t u = match pb with | Reduction.CONV -> - Reduction.trans_conv_universes + Reduction.conv_universes full_transparent_state ~evars:(existential_opt_value evd) env (UState.ugraph evd.universes) t u - | Reduction.CUMUL -> Reduction.trans_conv_leq_universes + | Reduction.CUMUL -> Reduction.conv_leq_universes full_transparent_state ~evars:(existential_opt_value evd) env (UState.ugraph evd.universes) t u diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 33beca28a4..8c9be0edd3 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -126,7 +126,7 @@ let whd_betadeltaiota_nolet env t = (* Conversion utility functions *) type 'a conversion_function = env -> 'a -> 'a -> unit -type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a trans_conversion_function = ?reds:Names.transparent_state -> 'a conversion_function type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit type 'a trans_universe_conversion_function = Names.transparent_state -> 'a universe_conversion_function @@ -616,7 +616,7 @@ let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } -let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 = +let fconv_universes reds cv_pb l2r evars env univs t1 t2 = let b = if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 @@ -627,38 +627,22 @@ let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 = () (* Profiling *) -let trans_fconv_universes = +let fconv_universes = if Flags.profile then - let trans_fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in - Profile.profile8 trans_fconv_universes_key trans_fconv_universes - else trans_fconv_universes - -let trans_fconv reds cv_pb l2r evars env = - trans_fconv_universes reds cv_pb l2r evars env (universes env) - -let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None) -let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars -let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars - -let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = - trans_fconv_universes reds CONV l2r evars -let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = - trans_fconv_universes reds CUMUL l2r evars - -let fconv = trans_fconv full_transparent_state - -let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) -let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars -let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars - -let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = - Array.fold_left2_i - (fun i _ t1 t2 -> - try conv_leq ~l2r ~evars env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i)) - () - v1 - v2 + let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in + Profile.profile8 fconv_universes_key fconv_universes + else fconv_universes + +let fconv ?(reds=full_transparent_state) cv_pb l2r evars env = + fconv_universes reds cv_pb l2r evars env (universes env) + +let conv ?(l2r=false) ?(evars=fun _->None) ?(reds=full_transparent_state) = + fconv ~reds CONV l2r evars + +let conv_universes ?(l2r=false) ?(evars=fun _->None) reds = + fconv_universes reds CONV l2r evars +let conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = + fconv_universes reds CUMUL l2r evars let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = let (s, _) = diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 7db7e57bb5..304046a1dc 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -27,7 +27,7 @@ exception NotConvertible exception NotConvertibleVect of int type 'a conversion_function = env -> 'a -> 'a -> unit -type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a trans_conversion_function = ?reds:Names.transparent_state -> 'a conversion_function type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit type 'a trans_universe_conversion_function = Names.transparent_state -> 'a universe_conversion_function @@ -58,25 +58,14 @@ val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t -> val checked_universes : UGraph.t universe_compare val inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare -val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function -val trans_conv : +val conv : ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function -val trans_conv_leq : - ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function -val trans_conv_universes : +val conv_universes : ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function -val trans_conv_leq_universes : +val conv_leq_universes : ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function -val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function -val conv : - ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function -val conv_leq : - ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function -val conv_leq_vecti : - ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function - (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index d5a93230f3..03e7f26420 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1264,8 +1264,8 @@ let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = with Reduction.NotConvertible -> false | e when is_anomaly e -> report_anomaly e -let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma -let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma +let is_trans_conv reds env sigma = test_trans_conversion Reduction.conv_universes reds env sigma +let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq let is_conv = is_trans_conv full_transparent_state @@ -1274,8 +1274,8 @@ let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = let f = match pb with - | Reduction.CONV -> Reduction.trans_conv_universes - | Reduction.CUMUL -> Reduction.trans_conv_leq_universes + | Reduction.CONV -> Reduction.conv_universes + | Reduction.CUMUL -> Reduction.conv_leq_universes in try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true with Reduction.NotConvertible -> false -- cgit v1.2.3 From 57a90691e4a64853113ab38487a5406a32c8c117 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 9 Dec 2015 15:22:08 +0100 Subject: CLEANUP: in the Reductionops module --- pretyping/evarconv.ml | 2 +- pretyping/reductionops.ml | 12 +++++------- pretyping/reductionops.mli | 10 +++------- 3 files changed, 9 insertions(+), 15 deletions(-) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 60d92f4beb..955bfa1656 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1099,7 +1099,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | Some evd -> Success evd | None -> UnifFailure (evd, ConversionFailed (env,term1,term2))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> - let f env evd pbty x y = is_trans_fconv pbty ts env evd x y in + let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in Success (solve_refl ~can_drop:true f env evd (position_problem true pbty) evk1 args1 args2) | Evar ev1, Evar ev2 -> diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 03e7f26420..97f35fbd39 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1264,13 +1264,11 @@ let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = with Reduction.NotConvertible -> false | e when is_anomaly e -> report_anomaly e -let is_trans_conv reds env sigma = test_trans_conversion Reduction.conv_universes reds env sigma -let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma -let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq - -let is_conv = is_trans_conv full_transparent_state -let is_conv_leq = is_trans_conv_leq full_transparent_state -let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq +let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_universes reds env sigma +let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma +let is_fconv ?(reds=full_transparent_state) = function + | Reduction.CONV -> is_conv ~reds + | Reduction.CUMUL -> is_conv_leq ~reds let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = let f = match pb with diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index d5a844847c..43c98bbd47 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -251,13 +251,9 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val is_conv : env -> evar_map -> constr -> constr -> bool -val is_conv_leq : env -> evar_map -> constr -> constr -> bool -val is_fconv : conv_pb -> env -> evar_map -> constr -> constr -> bool - -val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool (** [check_conv] Checks universe constraints only. pb defaults to CUMUL and ts to a full transparent state. -- cgit v1.2.3 From 672f8ee0c96584735294641bb4b8760e25197b80 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 14 Dec 2015 12:52:49 +0100 Subject: CLEANUP: in the Reduction module --- engine/evd.ml | 12 ++++++------ kernel/nativeconv.mli | 2 +- kernel/reduction.ml | 44 ++++++++++++++++++++++---------------------- kernel/reduction.mli | 26 +++++++++++--------------- kernel/vconv.mli | 2 +- pretyping/reductionops.ml | 14 +++++++------- 6 files changed, 48 insertions(+), 52 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index 2060141644..6651ff5f63 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -926,12 +926,12 @@ let update_sigma_env evd env = let test_conversion_gen env evd pb t u = match pb with | Reduction.CONV -> - Reduction.conv_universes - full_transparent_state ~evars:(existential_opt_value evd) env - (UState.ugraph evd.universes) t u - | Reduction.CUMUL -> Reduction.conv_leq_universes - full_transparent_state ~evars:(existential_opt_value evd) env - (UState.ugraph evd.universes) t u + Reduction.conv env + ~evars:((existential_opt_value evd), (UState.ugraph evd.universes)) + t u + | Reduction.CUMUL -> Reduction.conv_leq env + ~evars:((existential_opt_value evd), (UState.ugraph evd.universes)) + t u let test_conversion env d pb t u = try test_conversion_gen env d pb t u; true diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli index 4dddb9fd30..abc9e3a3ca 100644 --- a/kernel/nativeconv.mli +++ b/kernel/nativeconv.mli @@ -11,7 +11,7 @@ open Nativelambda (** This module implements the conversion test by compiling to OCaml code *) -val native_conv : conv_pb -> evars -> types conversion_function +val native_conv : conv_pb -> evars -> types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 8c9be0edd3..95bea92926 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -125,11 +125,15 @@ let whd_betadeltaiota_nolet env t = (********************************************************************) (* Conversion utility functions *) -type 'a conversion_function = env -> 'a -> 'a -> unit -type 'a trans_conversion_function = ?reds:Names.transparent_state -> 'a conversion_function -type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit -type 'a trans_universe_conversion_function = - Names.transparent_state -> 'a universe_conversion_function + +(* functions of this type are called from the kernel *) +type 'a kernel_conversion_function = env -> 'a -> 'a -> unit + +(* functions of this type can be called from outside the kernel *) +type 'a extended_conversion_function = + ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?evars:((existential->constr option) * UGraph.t) -> + 'a -> 'a -> unit exception NotConvertible exception NotConvertibleVect of int @@ -616,7 +620,7 @@ let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } -let fconv_universes reds cv_pb l2r evars env univs t1 t2 = +let fconv cv_pb l2r reds env evars univs t1 t2 = let b = if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 @@ -627,22 +631,16 @@ let fconv_universes reds cv_pb l2r evars env univs t1 t2 = () (* Profiling *) -let fconv_universes = +let fconv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = + let evars, univs = evars in if Flags.profile then let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in - Profile.profile8 fconv_universes_key fconv_universes - else fconv_universes + Profile.profile8 fconv_universes_key fconv cv_pb l2r reds env evars univs + else fconv cv_pb l2r reds env evars univs -let fconv ?(reds=full_transparent_state) cv_pb l2r evars env = - fconv_universes reds cv_pb l2r evars env (universes env) +let conv = fconv CONV -let conv ?(l2r=false) ?(evars=fun _->None) ?(reds=full_transparent_state) = - fconv ~reds CONV l2r evars - -let conv_universes ?(l2r=false) ?(evars=fun _->None) reds = - fconv_universes reds CONV l2r evars -let conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = - fconv_universes reds CUMUL l2r evars +let conv_leq = fconv CUMUL let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = let (s, _) = @@ -676,17 +674,19 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta infer_conv_universes CUMUL l2r evars ts env univs t1 t2 (* This reference avoids always having to link C code with the kernel *) -let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None)) -let set_vm_conv f = vm_conv := f +let vm_conv = ref (fun cv_pb env -> + fconv cv_pb env ~evars:((fun _->None), universes env)) + +let set_vm_conv (f:conv_pb -> Term.types kernel_conversion_function) = vm_conv := f let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> Pp.msg_warning (Pp.str "Bytecode compilation failed, falling back to standard conversion"); - fconv cv_pb false (fun _->None) env t1 t2 + fconv cv_pb env t1 t2 let default_conv cv_pb ?(l2r=false) env t1 t2 = - fconv cv_pb false (fun _ -> None) env t1 t2 + fconv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL (* diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 304046a1dc..f7a8d88c27 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -26,11 +26,11 @@ val nf_betaiota : env -> constr -> constr exception NotConvertible exception NotConvertibleVect of int -type 'a conversion_function = env -> 'a -> 'a -> unit -type 'a trans_conversion_function = ?reds:Names.transparent_state -> 'a conversion_function -type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit -type 'a trans_universe_conversion_function = - Names.transparent_state -> 'a universe_conversion_function +type 'a kernel_conversion_function = env -> 'a -> 'a -> unit +type 'a extended_conversion_function = + ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?evars:((existential->constr option) * UGraph.t) -> + 'a -> 'a -> unit type conv_pb = CONV | CUMUL @@ -58,13 +58,9 @@ val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t -> val checked_universes : UGraph.t universe_compare val inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare -val conv : - ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function +val conv : constr extended_conversion_function -val conv_universes : - ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function -val conv_leq_universes : - ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function +val conv_leq : types extended_conversion_function (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) @@ -77,11 +73,11 @@ val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> Names.transparent_state -> (constr,'a) generic_conversion_function (** option for conversion *) -val set_vm_conv : (conv_pb -> types conversion_function) -> unit -val vm_conv : conv_pb -> types conversion_function +val set_vm_conv : (conv_pb -> types kernel_conversion_function) -> unit +val vm_conv : conv_pb -> types kernel_conversion_function -val default_conv : conv_pb -> ?l2r:bool -> types conversion_function -val default_conv_leq : ?l2r:bool -> types conversion_function +val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function +val default_conv_leq : ?l2r:bool -> types kernel_conversion_function (************************************************************************) diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 49e5d23e63..acf4c408f3 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -12,7 +12,7 @@ open Reduction (********************************************************************** s conversion functions *) -val vm_conv : conv_pb -> types conversion_function +val vm_conv : conv_pb -> types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 97f35fbd39..3f02e4bfb1 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1256,26 +1256,26 @@ let report_anomaly _ = let e = Errors.push e in iraise e -let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = +let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in - let _ = f ~evars reds env (Evd.universes sigma) x y in + let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in true with Reduction.NotConvertible -> false | e when is_anomaly e -> report_anomaly e -let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_universes reds env sigma -let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq_universes reds env sigma +let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv reds env sigma +let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq reds env sigma let is_fconv ?(reds=full_transparent_state) = function | Reduction.CONV -> is_conv ~reds | Reduction.CUMUL -> is_conv_leq ~reds let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = let f = match pb with - | Reduction.CONV -> Reduction.conv_universes - | Reduction.CUMUL -> Reduction.conv_leq_universes + | Reduction.CONV -> Reduction.conv + | Reduction.CUMUL -> Reduction.conv_leq in - try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true + try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true with Reduction.NotConvertible -> false | Univ.UniverseInconsistency _ -> false | e when is_anomaly e -> report_anomaly e -- cgit v1.2.3 From d2f0997b7fddf3aa2f738e016d41663bf6595f61 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 17 Dec 2015 13:29:14 +0100 Subject: ALPHA-CONVERSION: in the "Reduction" module: fconv --> gen_conv --- kernel/reduction.ml | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 95bea92926..de124299bb 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -620,7 +620,7 @@ let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } -let fconv cv_pb l2r reds env evars univs t1 t2 = +let gen_conv cv_pb l2r reds env evars univs t1 t2 = let b = if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 @@ -631,16 +631,16 @@ let fconv cv_pb l2r reds env evars univs t1 t2 = () (* Profiling *) -let fconv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = +let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = let evars, univs = evars in if Flags.profile then let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in - Profile.profile8 fconv_universes_key fconv cv_pb l2r reds env evars univs - else fconv cv_pb l2r reds env evars univs + Profile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs + else gen_conv cv_pb l2r reds env evars univs -let conv = fconv CONV +let conv = gen_conv CONV -let conv_leq = fconv CUMUL +let conv_leq = gen_conv CUMUL let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = let (s, _) = @@ -675,7 +675,7 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta (* This reference avoids always having to link C code with the kernel *) let vm_conv = ref (fun cv_pb env -> - fconv cv_pb env ~evars:((fun _->None), universes env)) + gen_conv cv_pb env ~evars:((fun _->None), universes env)) let set_vm_conv (f:conv_pb -> Term.types kernel_conversion_function) = vm_conv := f let vm_conv cv_pb env t1 t2 = @@ -683,10 +683,10 @@ let vm_conv cv_pb env t1 t2 = !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> Pp.msg_warning (Pp.str "Bytecode compilation failed, falling back to standard conversion"); - fconv cv_pb env t1 t2 + gen_conv cv_pb env t1 t2 let default_conv cv_pb ?(l2r=false) env t1 t2 = - fconv cv_pb env t1 t2 + gen_conv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL (* -- cgit v1.2.3 From f24543a02db80e2c4ab3065564fabb9b7d485a2f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 17 Dec 2015 13:30:50 +0100 Subject: ALPHA-CONVERSION: in the "Reduction" module: clos_fconv --> clos_gen_conv --- kernel/reduction.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index de124299bb..bf2ee27077 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -537,7 +537,7 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible -let clos_fconv trans cv_pb l2r evars env univs t1 t2 = +let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs @@ -627,7 +627,7 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = in if b then () else - let _ = clos_fconv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in + let _ = clos_gen_conv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in () (* Profiling *) @@ -644,7 +644,7 @@ let conv_leq = gen_conv CUMUL let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = let (s, _) = - clos_fconv reds cv_pb l2r evars env univs t1 t2 + clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in s let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = @@ -655,7 +655,7 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = if b then cstrs else let univs = ((univs, Univ.Constraint.empty), inferred_universes) in - let ((_,cstrs), _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in + let ((_,cstrs), _) = clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in cstrs (* Profiling *) -- cgit v1.2.3 From a17891fdc314d0fe5246ab785268e2005a8c98b2 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 17 Dec 2015 18:33:14 +0100 Subject: spawn: fix leak of file descriptors The interesting manifestation of the bug was Unix.select returning no error but the empty list of descriptors, as if a timeout did happen. --- lib/spawn.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lib/spawn.ml b/lib/spawn.ml index 851c6a2235..01f6a4f8d3 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -175,7 +175,7 @@ let is_alive p = p.alive let uid { pid; } = string_of_int pid let unixpid { pid; } = pid -let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) = +let kill ({ pid = unixpid; oob_resp; oob_req; cin; cout; alive; watch } as p) = p.alive <- false; if not alive then prerr_endline "This process is already dead" else begin try @@ -183,6 +183,8 @@ let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) = output_death_sentence (uid p) oob_req; close_in_noerr cin; close_out_noerr cout; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; p.watch <- None with e -> prerr_endline ("kill: "^Printexc.to_string e) end @@ -247,13 +249,15 @@ let is_alive p = p.alive let uid { pid; } = string_of_int pid let unixpid { pid = pid; } = pid -let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) = +let kill ({ pid = unixpid; oob_req; oob_resp; cin; cout; alive } as p) = p.alive <- false; if not alive then prerr_endline "This process is already dead" else begin try output_death_sentence (uid p) oob_req; close_in_noerr cin; close_out_noerr cout; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; with e -> prerr_endline ("kill: "^Printexc.to_string e) end -- cgit v1.2.3 From 840cefca77a48ad68641539cd26d8d2e8c9dc031 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 17 Dec 2015 20:32:09 +0100 Subject: (Partial) fix for bug #4453: raise an error instead of an anomaly. --- pretyping/typing.ml | 18 +++++++++++++++--- test-suite/bugs/closed/4453.v | 8 ++++++++ 2 files changed, 23 insertions(+), 3 deletions(-) create mode 100644 test-suite/bugs/closed/4453.v diff --git a/pretyping/typing.ml b/pretyping/typing.ml index fb5927dbf7..db980e455a 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -144,8 +144,13 @@ let e_judge_of_cast env evdref cj k tj = { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } -(* The typing machine without information, without universes but with - existential variables. *) +let enrich_env env evdref = + let penv = Environ.pre_env env in + let penv' = Pre_env.({ penv with env_stratification = + { penv.env_stratification with env_universes = Evd.universes !evdref } }) in + Environ.env_of_pre_env penv' + +(* The typing machine with universes and existential variables. *) (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) @@ -264,6 +269,7 @@ and execute_recdef env evdref (names,lar,vdef) = and execute_array env evdref = Array.map (execute env evdref) let check env evdref c t = + let env = enrich_env env evdref in let j = execute env evdref c in if not (Evarconv.e_cumul env evdref j.uj_type t) then error_actual_type env j (nf_evar !evdref t) @@ -271,12 +277,15 @@ let check env evdref c t = (* Type of a constr *) let unsafe_type_of env evd c = - let j = execute env (ref evd) c in + let evdref = ref evd in + let env = enrich_env env evdref in + let j = execute env evdref c in j.uj_type (* Sort of a type *) let sort_of env evdref c = + let env = enrich_env env evdref in let j = execute env evdref c in let a = e_type_judgment env evdref j in a.utj_type @@ -285,6 +294,7 @@ let sort_of env evdref c = let type_of ?(refresh=false) env evd c = let evdref = ref evd in + let env = enrich_env env evdref in let j = execute env evdref c in (* side-effect on evdref *) if refresh then @@ -292,6 +302,7 @@ let type_of ?(refresh=false) env evd c = else !evdref, j.uj_type let e_type_of ?(refresh=false) env evdref c = + let env = enrich_env env evdref in let j = execute env evdref c in (* side-effect on evdref *) if refresh then @@ -301,6 +312,7 @@ let e_type_of ?(refresh=false) env evdref c = else j.uj_type let solve_evars env evdref c = + let env = enrich_env env evdref in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) nf_evar !evdref c diff --git a/test-suite/bugs/closed/4453.v b/test-suite/bugs/closed/4453.v new file mode 100644 index 0000000000..009dd5e3ca --- /dev/null +++ b/test-suite/bugs/closed/4453.v @@ -0,0 +1,8 @@ + +Section Foo. +Variable A : Type. +Lemma foo : A -> True. now intros _. Qed. +Goal Type -> True. +rename A into B. +intros A. +Fail apply foo. -- cgit v1.2.3 From eee16239f6b00400c8a13b787c310bcb11c37afe Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Dec 2015 12:06:24 +0100 Subject: Tying the loop in tactic printing API. --- dev/top_printers.ml | 3 +- printing/pptactic.ml | 76 +++++++++++++++++++++++++++++++----------------- printing/pptacticsig.mli | 45 +++++++--------------------- printing/ppvernac.ml | 8 +---- tactics/tacinterp.ml | 4 +-- 5 files changed, 62 insertions(+), 74 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b3b1ae0e91..0e90026122 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -468,9 +468,8 @@ let pp_generic_argument arg = let prgenarginfo arg = let tpe = pr_argument_type (genarg_tag arg) in - let pr_gtac _ x = Pptactic.pr_glob_tactic (Global.env()) x in try - let data = Pptactic.pr_top_generic pr_constr pr_lconstr pr_gtac pr_constr_pattern arg in + let data = Pptactic.pr_top_generic (Global.env ()) arg in str "" with _any -> str "" diff --git a/printing/pptactic.ml b/printing/pptactic.ml index dfb8837eca..4d14cae7a7 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -265,12 +265,12 @@ module Make let with_evars ev s = if ev then "e" ^ s else s - let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = + let rec pr_raw_generic_rec prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with | IntOrVarArgType -> pr_or_var int (out_gen (rawwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x) - | GenArgType -> pr_raw_generic prc prlc prtac prpat prref (out_gen (rawwit wit_genarg) x) + | GenArgType -> pr_raw_generic_rec prc prlc prtac prpat prref (out_gen (rawwit wit_genarg) x) | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) | ConstrMayEvalArgType -> pr_may_eval prc prlc (pr_or_by_notation prref) prpat @@ -278,14 +278,14 @@ module Make | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = - let map x = pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x) in + let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in pr_sequence map (raw l) in hov 0 (list_unpack { list_unpacker } x) | OptArgType _ -> let opt_unpacker wit o = match raw o with | None -> mt () - | Some x -> pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x) + | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in hov 0 (opt_unpack { opt_unpacker } x) | PairArgType _ -> @@ -293,7 +293,7 @@ module Make let p, q = raw o in let p = in_gen (rawwit wit1) p in let q = in_gen (rawwit wit2) q in - pr_sequence (pr_raw_generic prc prlc prtac prpat prref) [p; q] + pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q] in hov 0 (pair_unpack { pair_unpacker } x) | ExtraArgType s -> @@ -301,12 +301,12 @@ module Make with Not_found -> Genprint.generic_raw_print x - let rec pr_glb_generic prc prlc prtac prpat x = + let rec pr_glb_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with | IntOrVarArgType -> pr_or_var int (out_gen (glbwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x) - | GenArgType -> pr_glb_generic prc prlc prtac prpat (out_gen (glbwit wit_genarg) x) + | GenArgType -> pr_glb_generic_rec prc prlc prtac prpat (out_gen (glbwit wit_genarg) x) | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) | ConstrMayEvalArgType -> pr_may_eval prc prlc @@ -315,14 +315,14 @@ module Make | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = - let map x = pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x) in + let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in pr_sequence map (glb l) in hov 0 (list_unpack { list_unpacker } x) | OptArgType _ -> let opt_unpacker wit o = match glb o with | None -> mt () - | Some x -> pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x) + | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in hov 0 (opt_unpack { opt_unpacker } x) | PairArgType _ -> @@ -330,32 +330,32 @@ module Make let p, q = glb o in let p = in_gen (glbwit wit1) p in let q = in_gen (glbwit wit2) q in - pr_sequence (pr_glb_generic prc prlc prtac prpat) [p; q] + pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in hov 0 (pair_unpack { pair_unpacker } x) | ExtraArgType s -> try pi2 (String.Map.find s !genarg_pprule) prc prlc prtac x with Not_found -> Genprint.generic_glb_print x - let rec pr_top_generic prc prlc prtac prpat x = + let rec pr_top_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with | IntOrVarArgType -> pr_or_var int (out_gen (topwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) | VarArgType -> pr_id (out_gen (topwit wit_var) x) - | GenArgType -> pr_top_generic prc prlc prtac prpat (out_gen (topwit wit_genarg) x) + | GenArgType -> pr_top_generic_rec prc prlc prtac prpat (out_gen (topwit wit_genarg) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x) | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = - let map x = pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x) in + let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in pr_sequence map (top l) in hov 0 (list_unpack { list_unpacker } x) | OptArgType _ -> let opt_unpacker wit o = match top o with | None -> mt () - | Some x -> pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x) + | Some x -> pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in hov 0 (opt_unpack { opt_unpacker } x) | PairArgType _ -> @@ -363,7 +363,7 @@ module Make let p, q = top o in let p = in_gen (topwit wit1) p in let q = in_gen (topwit wit2) q in - pr_sequence (pr_top_generic prc prlc prtac prpat) [p; q] + pr_sequence (pr_top_generic_rec prc prlc prtac prpat) [p; q] in hov 0 (pair_unpack { pair_unpacker } x) | ExtraArgType s -> @@ -415,19 +415,19 @@ module Make with Not_found -> KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" - let pr_raw_extend prc prlc prtac prpat = - pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference) - let pr_glob_extend prc prlc prtac prpat = - pr_extend_gen (pr_glb_generic prc prlc prtac prpat) - let pr_extend prc prlc prtac prpat = - pr_extend_gen (pr_top_generic prc prlc prtac prpat) + let pr_raw_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference) + let pr_glob_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_glb_generic_rec prc prlc prtac prpat) + let pr_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_top_generic_rec prc prlc prtac prpat) let pr_raw_alias prc prlc prtac prpat = - pr_alias_gen (pr_raw_generic prc prlc prtac prpat pr_reference) + pr_alias_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference) let pr_glob_alias prc prlc prtac prpat = - pr_alias_gen (pr_glb_generic prc prlc prtac prpat) + pr_alias_gen (pr_glb_generic_rec prc prlc prtac prpat) let pr_alias prc prlc prtac prpat = - pr_alias_gen (pr_top_generic prc prlc prtac prpat) + pr_alias_gen (pr_top_generic_rec prc prlc prtac prpat) (**********************************************************************) (* The tactic printer *) @@ -1282,7 +1282,7 @@ module Make pr_reference = pr_reference; pr_name = pr_lident; pr_generic = Genprint.generic_raw_print; - pr_extend = pr_raw_extend pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; + pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; } in make_pr_tac @@ -1313,7 +1313,7 @@ module Make pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; pr_generic = Genprint.generic_glb_print; - pr_extend = pr_glob_extend + pr_extend = pr_glob_extend_rec (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); pr_alias = pr_glob_alias @@ -1355,7 +1355,7 @@ module Make pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; pr_generic = Genprint.generic_top_print; - pr_extend = pr_extend + pr_extend = pr_extend_rec (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) (pr_glob_tactic_level env) pr_constr_pattern; pr_alias = pr_alias @@ -1370,6 +1370,28 @@ module Make in prtac n t + let pr_raw_generic env = pr_raw_generic_rec + pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference + + let pr_glb_generic env = pr_glb_generic_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + + let pr_top_generic env = pr_top_generic_rec + (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) + (pr_glob_tactic_level env) pr_constr_pattern + + let pr_raw_extend env = pr_raw_extend_rec + pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr + + let pr_glob_extend env = pr_glob_extend_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + + let pr_extend env = pr_extend_rec + (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) + (pr_glob_tactic_level env) pr_constr_pattern + let pr_tactic env = pr_tactic_level env ltop end diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 1631bda377..1c17d04928 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -32,45 +32,20 @@ module type Pp = sig val pr_clauses : bool option -> ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - val pr_raw_generic : - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (Libnames.reference -> std_ppcmds) -> rlevel generic_argument -> - std_ppcmds - - val pr_glb_generic : - (glob_constr_and_expr -> Pp.std_ppcmds) -> - (glob_constr_and_expr -> Pp.std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (glob_constr_pattern_and_expr -> std_ppcmds) -> - glevel generic_argument -> std_ppcmds - - val pr_top_generic : - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (Pattern.constr_pattern -> std_ppcmds) -> - tlevel generic_argument -> - std_ppcmds - - val pr_raw_extend: - (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> int -> + + val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + + val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + + val pr_top_generic : env -> tlevel generic_argument -> std_ppcmds + + val pr_raw_extend: env -> int -> ml_tactic_entry -> raw_generic_argument list -> std_ppcmds - val pr_glob_extend: - (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (glob_constr_pattern_and_expr -> std_ppcmds) -> int -> + val pr_glob_extend: env -> int -> ml_tactic_entry -> glob_generic_argument list -> std_ppcmds - val pr_extend : - (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (constr_pattern -> std_ppcmds) -> int -> + val pr_extend : env -> int -> ml_tactic_entry -> typed_generic_argument list -> std_ppcmds val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 72b9cafe3f..d79fb45618 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -79,13 +79,7 @@ module Make | VernacEndSubproof -> str"" | _ -> str"." - let pr_gen t = - pr_raw_generic - pr_constr_expr - pr_lconstr_expr - pr_raw_tactic_level - pr_constr_expr - pr_reference t + let pr_gen t = pr_raw_generic (Global.env ()) t let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 6ac16bd76a..3295b932b9 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -60,9 +60,7 @@ let push_appl appl args = | UnnamedAppl -> UnnamedAppl | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) let pr_generic arg = - let pr_gtac _ x = Pptactic.pr_glob_tactic (Global.env()) x in - try - Pptactic.pr_top_generic pr_constr pr_lconstr pr_gtac pr_constr_pattern arg + try Pptactic.pr_top_generic (Global.env ()) arg with e when Errors.noncritical e -> str"" let pr_appl h vs = Pptactic.pr_ltac_constant h ++ spc () ++ -- cgit v1.2.3 From e2a67cbbbd17fa262b37903a97b0adf2d109bf06 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 11:00:44 +0100 Subject: COMMENTS: added to the "Names" module. --- kernel/names.ml | 9 ++++++--- kernel/names.mli | 29 +++++++++++++++++------------ 2 files changed, 23 insertions(+), 15 deletions(-) diff --git a/kernel/names.ml b/kernel/names.ml index 9e4e8cd61d..0de752c7c5 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -23,6 +23,7 @@ open Util (** {6 Identifiers } *) +(** Representation and operations on identifiers. *) module Id = struct type t = string @@ -74,10 +75,12 @@ struct end - +(** Representation and operations on identifiers that are allowed to be anonymous + (i.e. "_" in concrete syntax). *) module Name = struct - type t = Name of Id.t | Anonymous + type t = Anonymous (** anonymous identifier *) + | Name of Id.t (** non-anonymous identifier *) let compare n1 n2 = match n1, n2 with | Anonymous, Anonymous -> 0 @@ -117,8 +120,8 @@ struct end -type name = Name.t = Name of Id.t | Anonymous (** Alias, to import constructors. *) +type name = Name.t = Anonymous | Name of Id.t (** {6 Various types based on identifiers } *) diff --git a/kernel/names.mli b/kernel/names.mli index c5a7d8f3cc..b128fe3351 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -10,30 +10,33 @@ open Util (** {6 Identifiers } *) +(** Representation and operations on identifiers. *) module Id : sig type t - (** Type of identifiers *) + (** Values of this type represent (Coq) identifiers. *) val equal : t -> t -> bool - (** Equality over identifiers *) + (** Equality over identifiers. *) val compare : t -> t -> int - (** Comparison over identifiers *) + (** Comparison over identifiers. *) val hash : t -> int - (** Hash over identifiers *) + (** Hash over identifiers. *) val is_valid : string -> bool - (** Check that a string may be converted to an identifier. *) + (** Check that a string may be converted to an identifier. + @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val of_string : string -> t - (** Converts a string into an identifier. May raise [UserError _] if the - string is not valid, or echo a warning if it contains invalid identifier - characters. *) + (** Converts a string into an identifier. + @raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters. + @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val of_string_soft : string -> t - (** Same as {!of_string} except that no warning is ever issued. *) + (** Same as {!of_string} except that no warning is ever issued. + @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val to_string : t -> string (** Converts a identifier into an string. *) @@ -58,10 +61,12 @@ sig end +(** Representation and operations on identifiers that are allowed to be anonymous + (i.e. "_" in concrete syntax). *) module Name : sig - type t = Name of Id.t | Anonymous - (** A name is either undefined, either an identifier. *) + type t = Anonymous (** anonymous identifier *) + | Name of Id.t (** non-anonymous identifier *) val compare : t -> t -> int (** Comparison over names. *) @@ -79,7 +84,7 @@ end (** {6 Type aliases} *) -type name = Name.t = Name of Id.t | Anonymous +type name = Name.t = Anonymous | Name of Id.t type variable = Id.t type module_ident = Id.t -- cgit v1.2.3 From 75d74cd7d124f244882b9c4ed200eac144dcbc43 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 8 Dec 2015 12:49:01 +0100 Subject: COMMENTS: added to the "Predicate" module In the original version, ocamldoc markup wasn't used properly thus ocamldoc output did not in all places make sense. This commit makes sure that the documentation of the Predicate module is as clear as the documentation of the Set module (in the standard library). --- lib/predicate.ml | 9 +++--- lib/predicate.mli | 85 +++++++++++++++++++++++++++++++++---------------------- 2 files changed, 56 insertions(+), 38 deletions(-) diff --git a/lib/predicate.ml b/lib/predicate.ml index a60b3dadd4..1aa7db6af1 100644 --- a/lib/predicate.ml +++ b/lib/predicate.ml @@ -10,8 +10,6 @@ (* *) (************************************************************************) -(* Sets over ordered types *) - module type OrderedType = sig type t @@ -43,9 +41,10 @@ module Make(Ord: OrderedType) = struct module EltSet = Set.Make(Ord) - (* when bool is false, the denoted set is the complement of - the given set *) type elt = Ord.t + + (* (false, s) represents a set which is equal to the set s + (true, s) represents a set which is equal to the complement of set s *) type t = bool * EltSet.t let elements (b,s) = (b, EltSet.elements s) @@ -84,6 +83,7 @@ module Make(Ord: OrderedType) = let diff s1 s2 = inter s1 (complement s2) + (* assumes the set is infinite *) let subset s1 s2 = match (s1,s2) with ((false,p1),(false,p2)) -> EltSet.subset p1 p2 @@ -91,6 +91,7 @@ module Make(Ord: OrderedType) = | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2) | ((true,_),(false,_)) -> false + (* assumes the set is infinite *) let equal (b1,s1) (b2,s2) = b1=b2 && EltSet.equal s1 s2 diff --git a/lib/predicate.mli b/lib/predicate.mli index bcc89e7275..cee3b0bd39 100644 --- a/lib/predicate.mli +++ b/lib/predicate.mli @@ -1,67 +1,84 @@ +(** Infinite sets over a chosen [OrderedType]. -(** Module [Pred]: sets over infinite ordered types with complement. *) - -(** This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses the Set library. *) + All operations over sets are purely applicative (no side-effects). + *) +(** Input signature of the functor [Make]. *) module type OrderedType = sig type t - val compare: t -> t -> int + (** The type of the elements in the set. + + The chosen [t] {b must be infinite}. *) + + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that: + - [f e1 e2] is zero if the elements [e1] and [e2] are equal, + - [f e1 e2] is strictly negative if [e1] is smaller than [e2], + - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + *) end - (** The input signature of the functor [Pred.Make]. - [t] is the type of the set elements. - [compare] is a total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is - the generic structural comparison function [compare]. *) module type S = sig type elt - (** The type of the set elements. *) + (** The type of the elements in the set. *) + type t - (** The type of sets. *) + (** The type of sets. *) + val empty: t - (** The empty set. *) + (** The empty set. *) + val full: t - (** The whole type. *) + (** The set of all elements (of type [elm]). *) + val is_empty: t -> bool - (** Test whether a set is empty or not. *) + (** Test whether a set is empty or not. *) + val is_full: t -> bool - (** Test whether a set contains the whole type or not. *) + (** Test whether a set contains the whole type or not. *) + val mem: elt -> t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) + (** [mem x s] tests whether [x] belongs to the set [s]. *) + val singleton: elt -> t - (** [singleton x] returns the one-element set containing only [x]. *) + (** [singleton x] returns the one-element set containing only [x]. *) + val add: elt -> t -> t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], then [s] is returned unchanged. *) + val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) + except [x]. If [x] was not in [s], then [s] is returned unchanged. *) + val union: t -> t -> t + (** Set union. *) + val inter: t -> t -> t + (** Set intersection. *) + val diff: t -> t -> t + (** Set difference. *) + val complement: t -> t - (** Union, intersection, difference and set complement. *) + (** Set complement. *) + val equal: t -> t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) + the set [s2]. *) + val elements: t -> bool * elt list (** Gives a finite representation of the predicate: if the boolean is false, then the predicate is given in extension. if it is true, then the complement is given *) end -module Make(Ord: OrderedType): (S with type elt = Ord.t) - (** Functor building an implementation of the set structure - given a totally ordered type. *) +(** The [Make] functor constructs an implementation for any [OrderedType]. *) +module Make (Ord : OrderedType) : (S with type elt = Ord.t) -- cgit v1.2.3 From e181c9b043e64342c1e51763f4fe88c78bc4736d Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 12:20:47 +0100 Subject: CLEANUP: Vernacexpr.vernac_expr Originally, "VernacTime" and "VernacRedirect" were defined like this: type vernac_expr = ... | VernacTime of vernac_list | VernacRedirect of string * vernac_list ... where type vernac_list = located_vernac_expr list Currently, that list always contained one and only one element. So I propose changing the definition of these two variants in the following way: | VernacTime of located_vernac_expr | VernacRedirect of string * located_vernac_expr which covers all our current needs and enforces the invariant related to the number of commands that are part of the "VernacTime" and "VernacRedirect" variants. --- intf/vernacexpr.mli | 9 +++------ parsing/g_vernac.ml4 | 9 +++------ printing/ppvernac.ml | 15 +++++---------- stm/stm.ml | 4 ++-- stm/texmacspp.ml | 8 ++++---- stm/vernac_classifier.ml | 11 ++--------- toplevel/vernac.ml | 8 ++++---- toplevel/vernacentries.ml | 19 ++++++++----------- 8 files changed, 31 insertions(+), 52 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 99264dbe0a..32c0f29751 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -287,8 +287,8 @@ type module_binder = bool option * lident list * module_ast_inl type vernac_expr = (* Control *) | VernacLoad of verbose_flag * string - | VernacTime of vernac_list - | VernacRedirect of string * vernac_list + | VernacTime of located_vernac_expr + | VernacRedirect of string * located_vernac_expr | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr | VernacError of exn (* always fails *) @@ -386,8 +386,7 @@ type vernac_expr = | VernacBackTo of int (* Commands *) - | VernacDeclareTacticDefinition of - (rec_flag * (reference * bool * raw_tactic_expr) list) + | VernacDeclareTacticDefinition of (reference * bool * raw_tactic_expr) list | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list | VernacHints of obsolete_locality * string list * hints_expr @@ -455,8 +454,6 @@ type vernac_expr = | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr -and vernac_list = located_vernac_expr list - and located_vernac_expr = Loc.t * vernac_expr (* A vernac classifier has to tell if a command: diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 1f9f57f698..975dee934f 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -89,8 +89,8 @@ let default_command_entry = GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST - [ [ IDENT "Time"; l = vernac_list -> VernacTime l - | IDENT "Redirect"; s = ne_string; l = vernac_list -> VernacRedirect (s, l) + [ [ IDENT "Time"; c = located_vernac -> VernacTime c + | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c) | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v @@ -128,9 +128,6 @@ GEXTEND Gram | c = subprf -> c ] ] ; - vernac_list: - [ [ c = located_vernac -> [c] ] ] - ; vernac_aux: LAST [ [ prfcom = default_command_entry -> prfcom ] ] ; @@ -806,7 +803,7 @@ GEXTEND Gram command: [ [ IDENT "Ltac"; l = LIST1 tacdef_body SEP "with" -> - VernacDeclareTacticDefinition (true, l) + VernacDeclareTacticDefinition l | IDENT "Comments"; l = LIST0 comment -> VernacComments l diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index d79fb45618..0f065e251b 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -635,10 +635,10 @@ module Make else spc() ++ qs s ) - | VernacTime v -> - return (keyword "Time" ++ spc() ++ pr_vernac_list v) - | VernacRedirect (s, v) -> - return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_list v) + | VernacTime (_,v) -> + return (keyword "Time" ++ spc() ++ pr_vernac v) + | VernacRedirect (s, (_,v)) -> + return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac v) | VernacTimeout(n,v) -> return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac v) | VernacFail v -> @@ -1030,7 +1030,7 @@ module Make return (keyword "Cd" ++ pr_opt qs s) (* Commands *) - | VernacDeclareTacticDefinition (rc,l) -> + | VernacDeclareTacticDefinition l -> let pr_tac_body (id, redef, body) = let idl, body = match body with @@ -1262,11 +1262,6 @@ module Make | VernacEndSubproof -> return (str "}") - and pr_vernac_list l = - hov 2 (str"[" ++ spc() ++ - prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l - ++ spc() ++ str"]") - and pr_extend s cl = let pr_arg a = try pr_gen a diff --git a/stm/stm.ml b/stm/stm.ml index ea669b1596..e0e7875036 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -86,7 +86,7 @@ let vernac_interp ?proof id ?route { verbose; loc; expr } = | VernacResetName _ | VernacResetInitial | VernacBack _ | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime el | VernacRedirect (_,el) -> List.for_all (fun (_,e) -> internal_command e) el + | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> internal_command e | _ -> false in if internal_command expr then begin prerr_endline ("ignoring " ^ string_of_ppcmds(pr_vernac expr)) @@ -1501,7 +1501,7 @@ end = struct (* {{{ *) let e, etac, time, fail = let rec find time fail = function | VernacSolve(_,_,re,b) -> re, b, time, fail - | VernacTime [_,e] | VernacRedirect (_,[_,e]) -> find true fail e + | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e | VernacFail e -> find time true e | _ -> errorlabstrm "Stm" (str"unsupported") in find false false e in Hooks.call Hooks.with_fail fail (fun () -> diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index b912080413..95aaea6f00 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -487,12 +487,12 @@ let rec tmpp v loc = (* Control *) | VernacLoad (verbose,f) -> xmlWithLoc loc "load" ["verbose",string_of_bool verbose;"file",f] [] - | VernacTime l -> + | VernacTime (loc,e) -> xmlApply loc (Element("time",[],[]) :: - List.map (fun(loc,e) ->tmpp e loc) l) - | VernacRedirect (s, l) -> + [tmpp e loc]) + | VernacRedirect (s, (loc,e)) -> xmlApply loc (Element("redirect",["path", s],[]) :: - List.map (fun(loc,e) ->tmpp e loc) l) + [tmpp e loc]) | VernacTimeout (s,e) -> xmlApply loc (Element("timeout",["val",string_of_int s],[]) :: [tmpp e loc]) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index a898c687be..32358c592b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -86,7 +86,7 @@ let rec classify_vernac e = make_polymorphic (classify_vernac e) else classify_vernac e | VernacTimeout (_,e) -> classify_vernac e - | VernacTime e | VernacRedirect (_, e) -> classify_vernac_list e + | VernacTime (_,e) | VernacRedirect (_, (_,e)) -> classify_vernac e | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ @@ -175,7 +175,7 @@ let rec classify_vernac e = | VernacRegister _ | VernacNameSectionHypSet _ | VernacComments _ -> VtSideff [], VtLater - | VernacDeclareTacticDefinition (_,l) -> + | VernacDeclareTacticDefinition l -> let open Libnames in VtSideff (List.map (function | (Ident (_,r),_,_) -> r @@ -217,13 +217,6 @@ let rec classify_vernac e = | VernacExtend (s,l) -> try List.assoc s !classifiers l () with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)) - and classify_vernac_list = function - (* spiwack: It would be better to define a monoid on classifiers. - So that the classifier of the list would be the composition of - the classifier of the individual commands. Currently: special - case for singleton lists.*) - | [_,c] -> static_classifier c - | l -> VtUnknown,VtNow in let res = static_classifier e in if Flags.is_universe_polymorphism () then diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index a0cd618e99..f61129045b 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -27,9 +27,9 @@ let rec is_navigation_vernac = function | VernacBacktrack _ | VernacBackTo _ | VernacBack _ -> true - | VernacRedirect (_, l) | VernacTime l -> - List.exists - (fun (_,c) -> is_navigation_vernac c) l (* Time Back* is harmless *) + | VernacRedirect (_, (_,c)) + | VernacTime (_,c) -> + is_navigation_vernac c (* Time Back* is harmless *) | c -> is_deep_navigation_vernac c and is_deep_navigation_vernac = function @@ -229,7 +229,7 @@ let rec vernac_com verbose checknav (loc,com) = checknav loc com; if do_beautify () then pr_new_syntax loc (Some com); if !Flags.time then display_cmd_header loc com; - let com = if !Flags.time then VernacTime [loc,com] else com in + let com = if !Flags.time then VernacTime (loc,com) else com in interp com with reraise -> let (reraise, info) = Errors.push reraise in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index b3512ffde6..2f435adfec 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -972,7 +972,7 @@ let make_absolute_name ident repl = in NewTac id -let register_ltac local isrec tacl = +let register_ltac local tacl = let map (ident, repl, body) = let name = make_absolute_name ident repl in (name, body) @@ -983,8 +983,7 @@ let register_ltac local isrec tacl = | UpdateTac _ -> accu | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu in - if isrec then List.fold_left fold [] rfun - else [] + List.fold_left fold [] rfun in let ist = Tacintern.make_empty_glob_sign () in let map (name, body) = @@ -1010,9 +1009,9 @@ let register_ltac local isrec tacl = in List.iter iter defs -let vernac_declare_tactic_definition locality (x,def) = +let vernac_declare_tactic_definition locality def = let local = make_module_locality locality in - register_ltac local x def + register_ltac local def let vernac_create_hintdb locality id b = let local = make_module_locality locality in @@ -2132,11 +2131,11 @@ let interp ?(verbosely=true) ?proof (loc,c) = | VernacTimeout (n,v) -> current_timeout := Some n; aux ?locality ?polymorphism isprogcmd v - | VernacRedirect (s, v) -> - Pp.with_output_to_file s (aux_list ?locality ?polymorphism isprogcmd) v; - | VernacTime v -> + | VernacRedirect (s, (_,v)) -> + Pp.with_output_to_file s (aux false) v + | VernacTime (_,v) -> System.with_time !Flags.time - (aux_list ?locality ?polymorphism isprogcmd) v; + (aux ?locality ?polymorphism isprogcmd) v; | VernacLoad (_,fname) -> vernac_load (aux false) fname | c -> check_vernac_supports_locality c locality; @@ -2164,8 +2163,6 @@ let interp ?(verbosely=true) ?proof (loc,c) = Flags.program_mode := orig_program_mode; ignore (Flags.use_polymorphic_flag ()); iraise e - and aux_list ?locality ?polymorphism isprogcmd l = - List.iter (aux false) (List.map snd l) in if verbosely then Flags.verbosely (aux false) c else aux false c -- cgit v1.2.3 From 98065338c54717fd2d7aa887e8693acdc1cff5ba Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 12:33:58 +0100 Subject: COMMENTS: added to some variants of the "Constr.kind_of_term" type. --- kernel/constr.mli | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/kernel/constr.mli b/kernel/constr.mli index 5a370d31d8..70f1699314 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -93,8 +93,9 @@ val mkLambda : Name.t * types * constr -> constr (** Constructs the product [let x = t1 : t2 in t3] *) val mkLetIn : Name.t * constr * types * constr -> constr -(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application - {% $(f~t_1~\dots~t_n)$ %}. *) +(** [mkApp (f, [|t1; ...; tN|]] constructs the application + {%html:(f t1 ... tn)%} + {%latex:$(f~t_1\dots f_n)$%}. *) val mkApp : constr * constr array -> constr val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses @@ -181,10 +182,13 @@ type ('constr, 'types) kind_of_term = | Evar of 'constr pexistential | Sort of Sorts.t | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr - | App of 'constr * 'constr array + | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) + | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) + | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *) + | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. + The {!mkApp} constructor also enforces the following invariant: + - [F] itself is not {!App} + - and [[|P1;..;Pn|]] is not empty. *) | Const of constant puniverses | Ind of inductive puniverses | Construct of constructor puniverses -- cgit v1.2.3 From ca42472322013714050b98756aeaa222908fbe67 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 12:54:58 +0100 Subject: COMMENTS: updated in the "Option" module. --- lib/option.ml | 4 ++-- lib/option.mli | 16 ++++++++-------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/lib/option.ml b/lib/option.ml index 9ea1a76982..2f6e8365bb 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -41,8 +41,8 @@ let hash f = function exception IsNone -(** [get x] returns [y] where [x] is [Some y]. It raises IsNone - if [x] equals [None]. *) +(** [get x] returns [y] where [x] is [Some y]. + @raise [IsNone] if [x] equals [None]. *) let get = function | Some y -> y | _ -> raise IsNone diff --git a/lib/option.mli b/lib/option.mli index d9ad0e119f..4a8114177f 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -34,8 +34,8 @@ val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int (** Lift a hash to option types. *) val hash : ('a -> int) -> 'a option -> int -(** [get x] returns [y] where [x] is [Some y]. It raises IsNone - if [x] equals [None]. *) +(** [get x] returns [y] where [x] is [Some y]. + @raise IsNone if [x] equals [None]. *) val get : 'a option -> 'a (** [make x] returns [Some x]. *) @@ -54,7 +54,7 @@ val flatten : 'a option option -> 'a option val append : 'a option -> 'a option -> 'a option -(** {6 "Iterators"} ***) +(** {6 "Iterators"} *) (** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing otherwise. *) @@ -63,8 +63,8 @@ val iter : ('a -> unit) -> 'a option -> unit exception Heterogeneous (** [iter2 f x y] executes [f z w] if [x] equals [Some z] and [y] equals - [Some w]. It does nothing if both [x] and [y] are [None]. And raises - [Heterogeneous] otherwise. *) + [Some w]. It does nothing if both [x] and [y] are [None]. + @raise Heterogeneous otherwise. *) val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit (** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *) @@ -78,8 +78,8 @@ val smartmap : ('a -> 'a) -> 'a option -> 'a option val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b (** [fold_left2 f a x y] is [f z w] if [x] is [Some z] and [y] is [Some w]. - It is [a] if both [x] and [y] are [None]. Otherwise it raises - [Heterogeneous]. *) + It is [a] if both [x] and [y] are [None]. + @raise Heterogeneous otherwise. *) val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) @@ -91,7 +91,7 @@ val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option (** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) val cata : ('a -> 'b) -> 'b -> 'a option -> 'b -(** {6 More Specific Operations} ***) +(** {6 More Specific Operations} *) (** [default a x] is [y] if [x] is [Some y] and [a] otherwise. *) val default : 'a -> 'a option -> 'a -- cgit v1.2.3 From 5174ee7e118d2bc57fc2d8a6619101735af79b16 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 12:55:40 +0100 Subject: COMMENTS: added to the "Unicode" module. --- lib/unicode.ml | 7 ++++++- lib/unicode.mli | 22 ++++++++++++++++------ 2 files changed, 22 insertions(+), 7 deletions(-) diff --git a/lib/unicode.ml b/lib/unicode.ml index 1765e93dcd..05998bb804 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -18,7 +18,7 @@ exception Unsupported to simplify the masking process. (This choice seems to be a good trade-off between speed and space after some benchmarks.) *) -(* A 256ko table, initially filled with zeros. *) +(* A 256 KiB table, initially filled with zeros. *) let table = Array.make (1 lsl 17) 0 (* Associate a 2-bit pattern to each status at position [i]. @@ -147,6 +147,11 @@ let utf8_of_unicode n = s end +(* If [s] is some UTF-8 encoded string + and [i] is a position of some UTF-8 character within [s] + then [next_utf8 s i] returns [(j,n)] where: + - [j] indicates the position of the next UTF-8 character + - [n] represents the UTF-8 character at index [i] *) let next_utf8 s i = let err () = invalid_arg "utf8" in let l = String.length s - i in diff --git a/lib/unicode.mli b/lib/unicode.mli index 098f6c919d..eb75f00c28 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -10,19 +10,29 @@ type status = Letter | IdentPart | Symbol +(** This exception is raised when UTF-8 the input string contains unsupported UTF-8 characters. *) exception Unsupported -(** Classify a unicode char into 3 classes, or raise [Unsupported] *) +(** Classify a unicode char into 3 classes. + @raise Unsupported if the input string contains unsupported UTF-8 characters. *) val classify : int -> status -(** Check whether a given string be used as a legal identifier. - - [None] means yes - - [Some (b,s)] means no, with explanation [s] and severity [b] *) +(** Return [None] if a given string can be used as a (Coq) identifier. + Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. + @raise Unsupported if the input string contains unsupported UTF-8 characters. *) val ident_refutation : string -> (bool * string) option -(** First char of a string, converted to lowercase *) +(** First char of a string, converted to lowercase + @raise Unsupported if the input string contains unsupported UTF-8 characters. + @raise Assert_failure if the input string is empty. *) val lowercase_first_char : string -> string -(** For extraction, turn a unicode string into an ascii-only one *) +(** Return [true] if all UTF-8 characters in the input string are just plain ASCII characters. + Returns [false] otherwise. *) val is_basic_ascii : string -> bool + +(** [ascii_of_ident s] maps UTF-8 string to a string composed solely from ASCII characters. + Those UTF-8 characters which do not have their ASCII counterparts are + translated to ["__Uxxxx_"] where {i xxxx} are four hexadecimal digits. + @raise Unsupported if the input string contains unsupported UTF-8 characters. *) val ascii_of_ident : string -> string -- cgit v1.2.3 From ee3d0f32051d98bdba2a4ad2234966a2fa30a8ec Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 14:27:20 +0100 Subject: ALPHA-CONVERSION: in "parsing/g_vernac.ml4" file --- parsing/g_vernac.ml4 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 975dee934f..2c9894dad2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -174,13 +174,13 @@ GEXTEND Gram ; END -let test_plurial_form = function +let test_plural_form = function | [(_,([_],_))] -> Flags.if_verbose msg_warning (strbrk "Keywords Variables/Hypotheses/Parameters expect more than one assumption") | _ -> () -let test_plurial_form_types = function +let test_plural_form_types = function | [([_],_)] -> Flags.if_verbose msg_warning (strbrk "Keywords Implicit Types expect more than one type") @@ -201,7 +201,7 @@ GEXTEND Gram | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> - test_plurial_form bl; + test_plural_form bl; VernacAssumption (stre, nl, bl) | d = def_token; id = pidentref; b = def_body -> VernacDefinition (d, id, b) @@ -733,7 +733,7 @@ GEXTEND Gram VernacReserve bl | IDENT "Implicit"; IDENT "Types"; bl = reserv_list -> - test_plurial_form_types bl; + test_plural_form_types bl; VernacReserve bl | IDENT "Generalizable"; -- cgit v1.2.3 From 722d369d1bd5a0f65b401f24d6500d5496b8e8ab Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:14:59 +0100 Subject: COMMENTS: added to some variants of the "Constrexpr.prim_token" type. --- intf/constrexpr.mli | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 79f4e99e1f..6543db6a17 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -32,7 +32,9 @@ type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) -type prim_token = Numeral of Bigint.bigint | String of string +type prim_token = + | Numeral of Bigint.bigint (** representation of integer literals that appear in Coq scripts. *) + | String of string type raw_cases_pattern_expr = | RCPatAlias of Loc.t * raw_cases_pattern_expr * Id.t -- cgit v1.2.3 From 7a373e3853256b518d8ccb69fa6282211d500e0c Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:21:38 +0100 Subject: COMMENTS: added to some variants of "Glob_term.glob_constr" type. --- intf/glob_term.mli | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/intf/glob_term.mli b/intf/glob_term.mli index 32cf9eaf13..dfcd4a67d3 100644 --- a/intf/glob_term.mli +++ b/intf/glob_term.mli @@ -29,9 +29,14 @@ type cases_pattern = | PatCstr of Loc.t * constructor * cases_pattern list * Name.t (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) +(** Representation of an internalized (or in other words globalized) term. *) type glob_constr = | GRef of (Loc.t * global_reference * glob_level list option) + (** An identifier that represents a reference to an object defined + either in the (global) environment or in the (local) context. *) | GVar of (Loc.t * Id.t) + (** An identifier that cannot be regarded as "GRef". + Bound variables are typically represented this way. *) | GEvar of Loc.t * existential_name * (Id.t * glob_constr) list | GPatVar of Loc.t * (bool * patvar) (** Used for patterns only *) | GApp of Loc.t * glob_constr * glob_constr list @@ -39,8 +44,7 @@ type glob_constr = | GProd of Loc.t * Name.t * binding_kind * glob_constr * glob_constr | GLetIn of Loc.t * Name.t * glob_constr * glob_constr | GCases of Loc.t * case_style * glob_constr option * tomatch_tuples * cases_clauses - (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in - [MatchStyle]) *) + (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) | GLetTuple of Loc.t * Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr | GIf of Loc.t * glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr -- cgit v1.2.3 From e4423ce78823ad9dd8c726e31de712e67a91893a Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:22:49 +0100 Subject: COMMENTS: added to some variants of "Misctypes.glob_sort_gen" type. --- intf/misctypes.mli | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 5c11119ed8..65c7dccf2a 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -43,7 +43,10 @@ type 'id move_location = (** Sorts *) -type 'a glob_sort_gen = GProp | GSet | GType of 'a +type 'a glob_sort_gen = + | GProp (** representation of [Prop] literal *) + | GSet (** representation of [Set] literal *) + | GType of 'a (** representation of [Type] literal *) type sort_info = string Loc.located list type level_info = string Loc.located option -- cgit v1.2.3 From 9e8a9ab17d4467a4aa40f31eaef0800703d31418 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:24:18 +0100 Subject: COMMENTS: added to some variants of "Globalnames.global_reference" type. --- library/globnames.ml | 8 ++++---- library/globnames.mli | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/library/globnames.ml b/library/globnames.ml index 3befaa9a94..2d6afc8577 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -14,10 +14,10 @@ open Libnames (*s Global reference is a kernel side type for all references together *) type global_reference = - | VarRef of variable - | ConstRef of constant - | IndRef of inductive - | ConstructRef of constructor + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of constant (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) let isVarRef = function VarRef _ -> true | _ -> false let isConstRef = function ConstRef _ -> true | _ -> false diff --git a/library/globnames.mli b/library/globnames.mli index 253c20baae..a401046b49 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -13,10 +13,10 @@ open Mod_subst (** {6 Global reference is a kernel side type for all references together } *) type global_reference = - | VarRef of variable - | ConstRef of constant - | IndRef of inductive - | ConstructRef of constructor + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of constant (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) val isVarRef : global_reference -> bool val isConstRef : global_reference -> bool -- cgit v1.2.3 From c87c45877c7a9d571be5f215fac6de1ca7e3ca38 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:34:05 +0100 Subject: CLEANUP: removing unnecessary wrapper function --- toplevel/coqtop.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 5e782233f2..4b48b17fde 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -576,7 +576,7 @@ let parse_args arglist = else fatal_error (Errors.print e) false | any -> fatal_error (Errors.print any) (Errors.is_anomaly any) -let init arglist = +let init_toplevel arglist = init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) Lib.init(); @@ -640,8 +640,6 @@ let init arglist = exit 0 end -let init_toplevel = init - let start () = let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in (* In batch mode, Coqtop has already exited at this point. In interactive one, -- cgit v1.2.3 From c429770d4fc36497cfd02874a665c1ff2f1a0496 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:35:27 +0100 Subject: CLEANUP: simplifying "Coqtop.init_gc" implementation --- toplevel/coqtop.ml | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 4b48b17fde..2aad417e8d 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -257,18 +257,19 @@ let set_emacs () = *) let init_gc () = - let param = - try ignore (Sys.getenv "OCAMLRUNPARAM"); true - with Not_found -> false - in - let control = Gc.get () in - let tweaked_control = { control with - Gc.minor_heap_size = 33554432; (** 4M *) -(* Gc.major_heap_increment = 268435456; (** 32M *) *) - Gc.space_overhead = 120; - } in - if param then () - else Gc.set tweaked_control + try + (* OCAMLRUNPARAM environment variable is set. + * In that case, we let ocamlrun to use the values provided by the user. + *) + ignore (Sys.getenv "OCAMLRUNPARAM") + + with Not_found -> + (* OCAMLRUNPARAM environment variable is not set. + * In this case, we put in place our preferred configuration. + *) + Gc.set { (Gc.get ()) with + Gc.minor_heap_size = 33554432; (** 4M *) + Gc.space_overhead = 120} (*s Parsing of the command line. We no longer use [Arg.parse], in order to use share [Usage.print_usage] -- cgit v1.2.3 From 493b5d18971c8c19eaeccfc992d1212c6479d227 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:38:19 +0100 Subject: CLEANUP: Removing "Vernacexpr.VernacNop" variant to which no Vernacular command is mapped. --- intf/vernacexpr.mli | 1 - printing/ppvernac.ml | 2 -- stm/texmacspp.ml | 1 - stm/vernac_classifier.ml | 1 - toplevel/vernac.ml | 1 - toplevel/vernacentries.ml | 1 - 6 files changed, 7 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 32c0f29751..0e659459e9 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -420,7 +420,6 @@ type vernac_expr = | VernacLocate of locatable | VernacRegister of lident * register_kind | VernacComments of comment list - | VernacNop (* Stm backdoor *) | VernacStm of vernac_expr stm_vernac diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 0f065e251b..5110cf7b23 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -1224,8 +1224,6 @@ module Make (keyword "Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l) ) - | VernacNop -> - mt() (* Toplevel control *) | VernacToplevelControl exn -> diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index 95aaea6f00..2a09143940 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -724,7 +724,6 @@ let rec tmpp v loc = | VernacRegister _ as x -> xmlTODO loc x | VernacComments (cl) -> xmlComment loc (List.flatten (List.map pp_comment cl)) - | VernacNop as x -> xmlTODO loc x (* Stm backdoor *) | VernacStm _ as x -> xmlTODO loc x diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 32358c592b..90490c38bd 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -208,7 +208,6 @@ let rec classify_vernac e = | VernacResetName _ | VernacResetInitial | VernacBacktrack _ | VernacBackTo _ | VernacRestart -> !undo_classifier e (* What are these? *) - | VernacNop | VernacToplevelControl _ | VernacRestoreState _ | VernacWriteState _ -> VtUnknown, VtNow diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index f61129045b..7b80becda1 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -150,7 +150,6 @@ let pr_new_syntax loc ocom = if !beautify_file then set_formatter_translator(); let fs = States.freeze ~marshallable:`No in let com = match ocom with - | Some VernacNop -> mt() | Some com -> Ppvernac.pr_vernac com | None -> mt() in if !beautify_file then diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 2f435adfec..010a0afe40 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1963,7 +1963,6 @@ let interp ?proof ~loc locality poly c = | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r | VernacComments l -> if_verbose msg_info (str "Comments ok\n") - | VernacNop -> () (* The STM should handle that, but LOAD bypasses the STM... *) | VernacAbort id -> msg_warning (str "VernacAbort not handled by Stm") -- cgit v1.2.3 From 84f54fd0923c15109910123443348c193e37fe0f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:44:14 +0100 Subject: TYPOGRAPHY: correction of one particular error in the Reference Manual --- doc/refman/RefMan-ltac.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 2f07beb725..cc7e6b53bf 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1101,7 +1101,7 @@ using the syntax: {\tt Ltac} {\qualid} {\ident}$_1$ ... {\ident}$_n$ {\tt ::=} {\tacexpr} \end{quote} -A previous definition of \qualid must exist in the environment. +A previous definition of {\qualid} must exist in the environment. The new definition will always be used instead of the old one and it goes accross module boundaries. -- cgit v1.2.3 From 20641795624dbb03da0401e4dc503660e5e73df6 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 15:50:40 +0100 Subject: CLEANUP: Vernacexpr.VernacDeclareTacticDefinition The definition of Vernacexpr.VernacDeclareTacticDefinition was changed. The original definition allowed us to represent non-sensical value such as: VernacDeclareTacticDefinition(Qualid ..., false, ...) The new definition prevents that. --- intf/vernacexpr.mli | 6 ++++- parsing/g_ltac.ml4 | 20 +++++++-------- parsing/pcoq.mli | 2 +- printing/ppvernac.ml | 9 +++++-- stm/vernac_classifier.ml | 6 +++-- toplevel/vernacentries.ml | 63 ++++++++++++++++++++++------------------------- 6 files changed, 57 insertions(+), 49 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 0e659459e9..07a206b53e 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -386,7 +386,7 @@ type vernac_expr = | VernacBackTo of int (* Commands *) - | VernacDeclareTacticDefinition of (reference * bool * raw_tactic_expr) list + | VernacDeclareTacticDefinition of tacdef_body list | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list | VernacHints of obsolete_locality * string list * hints_expr @@ -453,6 +453,10 @@ type vernac_expr = | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr +and tacdef_body = + | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) + and located_vernac_expr = Loc.t * vernac_expr (* A vernac classifier has to tell if a command: diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 4a9ca23f15..181c2395d2 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -242,17 +242,17 @@ GEXTEND Gram | n = integer -> MsgInt n ] ] ; - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - (name, redef, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - (name, redef, body) ] ] + tacdef_body: + [ [ id = ident; it=LIST1 input_fun; ":="; body = tactic_expr -> + Vernacexpr.TacticDefinition ((!@loc,id), TacFun (it, body)) + | name = Constr.global; it=LIST1 input_fun; "::="; body = tactic_expr -> + Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + | id = ident; ":="; body = tactic_expr -> + Vernacexpr.TacticDefinition ((!@loc,id), body) + | name = Constr.global; "::="; body = tactic_expr -> + Vernacexpr.TacticRedefinition (name, body) + ] ] ; tactic: [ [ tac = tactic_expr -> tac ] ] diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index ad4d9e5019..fdba413854 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -237,7 +237,7 @@ module Tactic : val binder_tactic : raw_tactic_expr Gram.entry val tactic : raw_tactic_expr Gram.entry val tactic_eoi : raw_tactic_expr Gram.entry - val tacdef_body : (reference * bool * raw_tactic_expr) Gram.entry + val tacdef_body : Vernacexpr.tacdef_body Gram.entry end module Vernac_ : diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 5110cf7b23..f216c599d0 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -1031,12 +1031,17 @@ module Make (* Commands *) | VernacDeclareTacticDefinition l -> - let pr_tac_body (id, redef, body) = + let pr_tac_body tacdef_body = + let id, redef, body = + match tacdef_body with + | TacticDefinition ((_,id), body) -> str (Id.to_string id), false, body + | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body + in let idl, body = match body with | Tacexpr.TacFun (idl,b) -> idl,b | _ -> [], body in - pr_ltac_ref id ++ + id ++ prlist (function None -> str " _" | Some id -> spc () ++ pr_id id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 90490c38bd..58e26de841 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -177,9 +177,11 @@ let rec classify_vernac e = | VernacComments _ -> VtSideff [], VtLater | VernacDeclareTacticDefinition l -> let open Libnames in + let open Vernacexpr in VtSideff (List.map (function - | (Ident (_,r),_,_) -> r - | (Qualid (_,q),_,_) -> snd(repr_qualid q)) l), VtLater + | TacticDefinition ((_,r),_) -> r + | TacticRedefinition (Ident (_,r),_) -> r + | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater (* Who knows *) | VernacLoad _ -> VtSideff [], VtNow (* (Local) Notations have to disappear *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 010a0afe40..28b5bace13 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -942,40 +942,37 @@ type tacdef_kind = let is_defined_tac kn = try ignore (Tacenv.interp_ltac kn); true with Not_found -> false -let make_absolute_name ident repl = - let loc = loc_of_reference ident in - if repl then - let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) - with Not_found -> - Errors.user_err_loc (loc, "", - str "There is no Ltac named " ++ pr_reference ident ++ str ".") - in - UpdateTac kn - else - let id = Constrexpr_ops.coerce_reference_to_id ident in - let kn = Lib.make_kn id in - let () = if is_defined_tac kn then - Errors.user_err_loc (loc, "", - str "There is already an Ltac named " ++ pr_reference ident ++ str".") - in - let is_primitive = - try - match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with - | Tacexpr.TacArg _ -> false - | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) - with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) - in - let () = if is_primitive then - msg_warning (str "The Ltac name " ++ pr_reference ident ++ - str " may be unusable because of a conflict with a notation.") - in - NewTac id - let register_ltac local tacl = - let map (ident, repl, body) = - let name = make_absolute_name ident repl in - (name, body) + let map tactic_body = + match tactic_body with + | TacticDefinition ((loc,id), body) -> + let kn = Lib.make_kn id in + let id_pp = str (Id.to_string id) in + let () = if is_defined_tac kn then + Errors.user_err_loc (loc, "", + str "There is already an Ltac named " ++ id_pp ++ str".") + in + let is_primitive = + try + match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with + | Tacexpr.TacArg _ -> false + | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) + with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) + in + let () = if is_primitive then + msg_warning (str "The Ltac name " ++ id_pp ++ + str " may be unusable because of a conflict with a notation.") + in + NewTac id, body + | TacticRedefinition (ident, body) -> + let loc = loc_of_reference ident in + let kn = + try Nametab.locate_tactic (snd (qualid_of_reference ident)) + with Not_found -> + Errors.user_err_loc (loc, "", + str "There is no Ltac named " ++ pr_reference ident ++ str ".") + in + UpdateTac kn, body in let rfun = List.map map tacl in let recvars = -- cgit v1.2.3 From 5824a2c9362a6e33eb43b5e0e2c7572abeee2511 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 16:41:58 +0100 Subject: CLEANUP: removing unnecessary alias --- intf/vernacexpr.mli | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 07a206b53e..4bc3a9e609 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -19,7 +19,6 @@ open Libnames type lident = Id.t located type lname = Name.t located type lstring = string located -type lreference = reference type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation @@ -330,8 +329,8 @@ type vernac_expr = | VernacBeginSection of lident | VernacEndSegment of lident | VernacRequire of - lreference option * export_flag option * lreference list - | VernacImport of export_flag * lreference list + reference option * export_flag option * reference list + | VernacImport of export_flag * reference list | VernacCanonical of reference or_by_notation | VernacCoercion of obsolete_locality * reference or_by_notation * class_rawexpr * class_rawexpr -- cgit v1.2.3 From 1b5f85d38db7a0d7cb9a4b9491a5563461373182 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 17:31:25 +0100 Subject: CLEANUP: the definition of the "Constrexpr.case_expr" type was simplified --- interp/constrexpr_ops.ml | 2 +- interp/constrextern.ml | 43 +++++++++++++++++++++++-------------------- interp/constrintern.ml | 8 ++++---- interp/topconstr.ml | 6 +++--- intf/constrexpr.mli | 2 +- parsing/g_constr.ml4 | 15 +++++++-------- plugins/funind/indfun.ml | 4 ++-- printing/ppconstr.ml | 10 +++++----- stm/texmacspp.ml | 2 +- 9 files changed, 47 insertions(+), 45 deletions(-) diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 2d48ea4d07..161fd1eb1d 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -178,7 +178,7 @@ and args_eq (a1,e1) (a2,e2) = Option.equal (eq_located explicitation_eq) e1 e2 && constr_expr_eq a1 a2 -and case_expr_eq (e1, (n1, p1)) (e2, (n2, p2)) = +and case_expr_eq (e1, n1, p1) (e2, n2, p2) = constr_expr_eq e1 e2 && Option.equal (eq_located Name.equal) n1 n2 && Option.equal cases_pattern_expr_eq p1 p2 diff --git a/interp/constrextern.ml b/interp/constrextern.ml index ba20f9fa06..ed85c38de0 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -721,26 +721,29 @@ let rec extern inctx scopes vars r = (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> - let na' = match na,tm with - | Anonymous, GVar (_, id) -> - begin match rtntypopt with - | None -> None - | Some ntn -> - if occur_glob_constr id ntn then - Some (Loc.ghost, Anonymous) - else None - end - | Anonymous, _ -> None - | Name id, GVar (_,id') when Id.equal id id' -> None - | Name _, _ -> Some (Loc.ghost,na) in - (sub_extern false scopes vars tm, - (na',Option.map (fun (loc,ind,nal) -> - let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in - let fullargs = - if !Flags.in_debugger then args else - Notation_ops.add_patterns_for_params ind args in - extern_ind_pattern_in_scope scopes vars ind fullargs - ) x))) tml in + let na' = match na,tm with + | Anonymous, GVar (_, id) -> + begin match rtntypopt with + | None -> None + | Some ntn -> + if occur_glob_constr id ntn then + Some (Loc.ghost, Anonymous) + else None + end + | Anonymous, _ -> None + | Name id, GVar (_,id') when Id.equal id id' -> None + | Name _, _ -> Some (Loc.ghost,na) in + (sub_extern false scopes vars tm, + na', + Option.map (fun (loc,ind,nal) -> + let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in + let fullargs = + if !Flags.in_debugger then args else + Notation_ops.add_patterns_for_params ind args in + extern_ind_pattern_in_scope scopes vars ind fullargs + ) x)) + tml + in let eqns = List.map (extern_eqn inctx scopes vars) eqns in CCases (loc,sty,rtntypopt',tml,eqns) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 8afe630ec5..8a86d30220 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1506,7 +1506,7 @@ let internalize globalenv env allow_patvar lvar c = intern env app end | CCases (loc, sty, rtnpo, tms, eqns) -> - let as_in_vars = List.fold_left (fun acc (_,(na,inb)) -> + let as_in_vars = List.fold_left (fun acc (_,na,inb) -> Option.fold_left (fun x tt -> List.fold_right Id.Set.add (ids_of_cases_indtype tt) x) (Option.fold_left (fun x (_,y) -> match y with | Name y' -> Id.Set.add y' x |_ -> x) acc na) inb) Id.Set.empty tms in @@ -1542,7 +1542,7 @@ let internalize globalenv env allow_patvar lvar c = | CLetTuple (loc, nal, (na,po), b, c) -> let env' = reset_tmp_scope env in (* "in" is None so no match to add *) - let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,(na,None)) in + let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,na,None) in let p' = Option.map (fun u -> let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') (Loc.ghost,na') in @@ -1551,7 +1551,7 @@ let internalize globalenv env allow_patvar lvar c = intern (List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (loc, c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in - let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,(na,None)) in (* no "in" no match to ad too *) + let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,na,None) in (* no "in" no match to ad too *) let p' = Option.map (fun p -> let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) (Loc.ghost,na') in @@ -1628,7 +1628,7 @@ let internalize globalenv env allow_patvar lvar c = let rhs' = intern {env with ids = env_ids} rhs in (loc,eqn_ids,pl,rhs')) pll - and intern_case_item env forbidden_names_for_gen (tm,(na,t)) = + and intern_case_item env forbidden_names_for_gen (tm,na,t) = (*the "match" part *) let tm' = intern env tm in (* the "as" part *) diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 1231f11555..15ac46e29e 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -51,7 +51,7 @@ let ids_of_cases_indtype = let ids_of_cases_tomatch tms = List.fold_right - (fun (_,(ona,indnal)) l -> + (fun (_,ona,indnal) l -> Option.fold_right (fun t -> (@) (ids_of_cases_indtype t)) indnal (Option.fold_right (Loc.down_located name_cons) ona l)) tms [] @@ -120,7 +120,7 @@ let fold_constr_expr_with_binders g f n acc = function | CCases (loc,sty,rtnpo,al,bl) -> let ids = ids_of_cases_tomatch al in let acc = Option.fold_left (f (List.fold_right g ids n)) acc rtnpo in - let acc = List.fold_left (f n) acc (List.map fst al) in + let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in List.fold_right (fun (loc,patl,rhs) acc -> let ids = ids_of_pattern_list patl in f (Id.Set.fold g ids n) acc rhs) bl acc @@ -224,7 +224,7 @@ let map_constr_expr_with_binders g f e = function let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in let ids = ids_of_cases_tomatch a in let po = Option.map (f (List.fold_right g ids e)) rtnpo in - CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl) + CCases (loc, sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) | CLetTuple (loc,nal,(ona,po),b,c) -> let e' = List.fold_right (Loc.down_located (name_fold g)) nal e in let e'' = Option.fold_right (Loc.down_located (name_fold g)) ona e in diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 6543db6a17..8eff327dcd 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -93,7 +93,7 @@ type constr_expr = | CDelimiters of Loc.t * string * constr_expr and case_expr = - constr_expr * (Name.t located option * cases_pattern_expr option) + constr_expr * Name.t located option * cases_pattern_expr option and branch_expr = Loc.t * cases_pattern_expr list located list * constr_expr diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 8df91da24b..2dec3b222a 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -267,14 +267,14 @@ GEXTEND Gram CLetTuple (!@loc,lb,po,c1,c2) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, None, [(c1,(None,None))], [(!@loc, [(!@loc,[p])], c2)]) + CCases (!@loc, LetPatternStyle, None, [c1, None, None], [(!@loc, [(!@loc,[p])], c2)]) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(!@loc, [(!@loc, [p])], c2)]) + CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, None], [(!@loc, [(!@loc, [p])], c2)]) | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(!@loc, [(!@loc, [p])], c2)]) + CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [(!@loc, [(!@loc, [p])], c2)]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> @@ -338,11 +338,10 @@ GEXTEND Gram br=branches; "end" -> CCases(!@loc,RegularStyle,ty,ci,br) ] ] ; case_item: - [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] - ; - pred_pattern: - [ [ ona = OPT ["as"; id=name -> id]; - ty = OPT ["in"; t=pattern -> t] -> (ona,ty) ] ] + [ [ c=operconstr LEVEL "100"; + ona = OPT ["as"; id=name -> id]; + ty = OPT ["in"; t=pattern -> t] -> + (c,ona,ty) ] ] ; case_type: [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index bf9da870e4..7815a8f818 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -728,9 +728,9 @@ let rec add_args id new_args b = List.map (fun (e,o) -> add_args id new_args e,o) bl) | CCases(loc,sty,b_option,cel,cal) -> CCases(loc,sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,(na,b_option)) -> + List.map (fun (b,na,b_option) -> add_args id new_args b, - (na, b_option)) cel, + na, b_option) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 663b8b8101..56429410cb 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -457,7 +457,7 @@ end) = struct (pr_decl true) dl ++ fnl() ++ keyword "for" ++ spc () ++ pr_id id - let pr_asin pr (na,indnalopt) = + let pr_asin pr na indnalopt = (match na with (* Decision of printing "_" or not moved to constrextern.ml *) | Some na -> spc () ++ keyword "as" ++ spc () ++ pr_lname na | None -> mt ()) ++ @@ -465,8 +465,8 @@ end) = struct | None -> mt () | Some t -> spc () ++ keyword "in" ++ spc () ++ pr_patt lsimplepatt t) - let pr_case_item pr (tm,asin) = - hov 0 (pr (lcast,E) tm ++ pr_asin pr asin) + let pr_case_item pr (tm,as_clause, in_clause) = + hov 0 (pr (lcast,E) tm ++ pr_asin pr as_clause in_clause) let pr_case_type pr po = match po with @@ -611,12 +611,12 @@ end) = struct ++ str" |}"), latom ) - | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) -> + | CCases (_,LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,[(loc,[p])],b)]) -> return ( hv 0 ( keyword "let" ++ spc () ++ str"'" ++ hov 0 (pr_patt ltop p ++ - pr_asin (pr_dangling_with_for mt pr) asin ++ + pr_asin (pr_dangling_with_for mt pr) as_clause in_clause ++ str " :=" ++ pr spc ltop c ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++ spc () ++ keyword "in" ++ pr spc ltop b)), diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index 2a09143940..1996d35259 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -347,7 +347,7 @@ and pp_cases_pattern_expr cpe = xmlApply loc (xmlOperator "delimiter" ~attr:["name", delim] loc :: [pp_cases_pattern_expr cpe]) -and pp_case_expr (e, (name, pat)) = +and pp_case_expr (e, name, pat) = match name, pat with | None, None -> xmlScrutinee [pp_expr e] | Some (loc, name), None -> -- cgit v1.2.3 From b88929d9d8de179a7e356cf9cbe2afef76f905a3 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 18 Dec 2015 10:07:53 +0100 Subject: COMMENTS: added to the "Constr.case_info" type. --- kernel/constr.ml | 14 +++++++++----- kernel/constr.mli | 14 +++++++++----- 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/kernel/constr.ml b/kernel/constr.ml index 753d188455..c3aebada26 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -42,11 +42,15 @@ type case_printing = cstr_tags : bool list array; (* whether each pattern var of each constructor is a let-in (true) or not (false) *) style : case_style } type case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; (* number of pattern vars of each constructor (with let's)*) - ci_cstr_nargs : int array; (* number of pattern vars of each constructor (w/o let's) *) - ci_pp_info : case_printing (* not interpreted by the kernel *) + { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) + ci_npar : int; (* number of parameters of the above inductive type *) + ci_cstr_ndecls : int array; (* number of arguments of individual constructors + (numbers of parameters of the inductive type are excluded from the count) + (with let's) *) + ci_cstr_nargs : int array; (* number of arguments of individual constructors + (numbers of parameters of the inductive type are excluded from the count) + (w/o let's) *) + ci_pp_info : case_printing (* not interpreted by the kernel *) } (********************************************************************) diff --git a/kernel/constr.mli b/kernel/constr.mli index 70f1699314..edd4eb2310 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -32,11 +32,15 @@ type case_printing = (** the integer is the number of real args, needed for reduction *) type case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; (* number of pattern vars of each constructor (with let's)*) - ci_cstr_nargs : int array; (* number of pattern vars of each constructor (w/o let's) *) - ci_pp_info : case_printing (** not interpreted by the kernel *) + { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) + ci_npar : int; (* number of parameters of the above inductive type *) + ci_cstr_ndecls : int array; (* number of arguments of individual constructors + (numbers of parameters of the inductive type are excluded from the count) + (with let's) *) + ci_cstr_nargs : int array; (* number of arguments of individual constructors + (numbers of parameters of the inductive type are excluded from the count) + (w/o let's) *) + ci_pp_info : case_printing (* not interpreted by the kernel *) } (** {6 The type of constructions } *) -- cgit v1.2.3 From 13f014ba37e0af547d57854df8926d633f9ccb7b Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 21 Dec 2015 17:51:38 +0100 Subject: Trust the directory cache in batch mode. When coqtop is a long-lived process (e.g. coqide), the user might be creating files on the fly. So we have to ask the operating system whether a file exists beforehand, so that we know whether the content of the directory cache is outdated. In batch mode, we can assume that the cache is always up-to-date, so we don't need to query the operating system before trusting the content of the cache. On a script doing "Require Import Reals", this brings down the number of stat syscalls from 42k to 2k. The number of syscalls could be further halved if all_subdirs was filling the directory cache. --- lib/system.ml | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index b641aad91b..31e9861d3a 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -56,7 +56,7 @@ let check_unix_dir warn dir = let apply_subdir f path name = (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) (* as well as skipped files like CVS, ... *) - if name.[0] <> '.' && ok_dirname name then + if ok_dirname name then let path = if path = "." then name else path//name in match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with | Unix.S_DIR -> f (FileDir (path,name)) @@ -109,20 +109,22 @@ let make_dir_table dir = Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) let exists_in_dir_respecting_case dir bf = - let contents, cached = - try StrMap.find dir !dirmap, true with Not_found -> + let cache_dir dir = let contents = make_dir_table dir in dirmap := StrMap.add dir contents !dirmap; - contents, false in + contents in + let contents, fresh = + try + (* in batch mode, assume the directory content is still fresh *) + StrMap.find dir !dirmap, !Flags.batch_mode + with Not_found -> + (* in batch mode, we are not yet sure the directory exists *) + if !Flags.batch_mode && not (exists_dir dir) then StrSet.empty, true + else cache_dir dir, true in StrSet.mem bf contents || - if cached then begin + not fresh && (* rescan, there is a new file we don't know about *) - let contents = make_dir_table dir in - dirmap := StrMap.add dir contents !dirmap; - StrSet.mem bf contents - end - else - false + StrSet.mem bf (cache_dir dir) let file_exists_respecting_case path f = (* This function ensures that a file with expected lowercase/uppercase @@ -132,7 +134,7 @@ let file_exists_respecting_case path f = let df = Filename.dirname f in (String.equal df "." || aux df) && exists_in_dir_respecting_case (Filename.concat path df) bf - in Sys.file_exists (Filename.concat path f) && aux f + in (!Flags.batch_mode || Sys.file_exists (Filename.concat path f)) && aux f let rec search paths test = match paths with -- cgit v1.2.3 From fcf425a4714f0c888b3d670a9a37fe52a6e49bc5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Dec 2015 18:41:50 +0100 Subject: Attaching a dynamic argument to the toplevel type of generic arguments. --- lib/genarg.ml | 46 ++++++++++++++++++++++++++++++++++++++++++---- lib/genarg.mli | 20 ++++++++++++++++++-- 2 files changed, 60 insertions(+), 6 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index 8712eda8e1..b6a2849ad5 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -9,6 +9,8 @@ open Pp open Util +module Val = Dyn.Make(struct end) + type argument_type = (* Basic types *) | IntOrVarArgType @@ -133,13 +135,22 @@ let pair_unpack pack (t, obj) = match t with (** Creating args *) -let (arg0_map : Obj.t option String.Map.t ref) = ref String.Map.empty +type load = { + nil : Obj.t option; + dyn : Obj.t Val.tag; +} + +let (arg0_map : load String.Map.t ref) = ref String.Map.empty -let create_arg opt name = +let cast_tag : 'a Val.tag -> 'b Val.tag = Obj.magic + +let create_arg opt ?dyn name = if String.Map.mem name !arg0_map then Errors.anomaly (str "generic argument already declared: " ++ str name) else - let () = arg0_map := String.Map.add name (Obj.magic opt) !arg0_map in + let dyn = match dyn with None -> Val.create name | Some dyn -> cast_tag dyn in + let obj = { nil = Option.map Obj.repr opt; dyn; } in + let () = arg0_map := String.Map.add name obj !arg0_map in ExtraArgType name let make0 = create_arg @@ -153,12 +164,39 @@ let default_empty_value t = | Some v1, Some v2 -> Some (Obj.repr (v1, v2)) | _ -> None) | ExtraArgType s -> - String.Map.find s !arg0_map + (String.Map.find s !arg0_map).nil | _ -> None in match aux t with | Some v -> Some (Obj.obj v) | None -> None +(** Beware: keep in sync with the corresponding types *) +let int_or_var_T = Val.create "int_or_var" +let ident_T = Val.create "ident" +let var_T = Val.create "var" +let genarg_T = Val.create "genarg" +let constr_T = Val.create "constr" +let constr_may_eval_T = Val.create "constr_may_eval" +let open_constr_T = Val.create "open_constr" + +let option_val = Val.create "option" +let list_val = Val.create "list" +let pair_val = Val.create "pair" + +let val_tag = function +| IntOrVarArgType -> cast_tag int_or_var_T +| IdentArgType -> cast_tag ident_T +| VarArgType -> cast_tag var_T +| GenArgType -> cast_tag genarg_T +| ConstrArgType -> cast_tag constr_T +| ConstrMayEvalArgType -> cast_tag constr_may_eval_T +| OpenConstrArgType -> cast_tag open_constr_T +| ExtraArgType s -> Obj.magic (String.Map.find s !arg0_map).dyn +(** Recursive types have no associated dynamic tag *) +| ListArgType t -> assert false +| OptArgType t -> assert false +| PairArgType (t1, t2) -> assert false + (** Registering genarg-manipulating functions *) module type GenObj = diff --git a/lib/genarg.mli b/lib/genarg.mli index 2dcaa789f7..d52a246107 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -72,14 +72,20 @@ type ('raw, 'glob, 'top) genarg_type (** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized one, and ['top] the internalized one. *) +module Val : Dyn.S +(** Dynamic types for toplevel values. While the generic types permit to relate + objects at various levels of interpretation, toplevel values are wearing + their own type regardless of where they came from. This allows to use the + same runtime representation for several generic types. *) + type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision when the three types agree. *) -val make0 : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +val make0 : 'raw option -> ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Create a new generic type of argument: force to associate unique ML types at each of the three levels. *) -val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +val create_arg : 'raw option -> ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Alias for [make0]. *) (** {5 Specialized types} *) @@ -179,6 +185,16 @@ type ('r, 'l) pair_unpacker = val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r +(** {6 Dynamic toplevel values} *) + +val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag +(** Retrieve the dynamic type associated to a toplevel genarg. Only works for + ground generic arguments. *) + +val option_val : Val.t option Val.tag +val list_val : Val.t list Val.tag +val pair_val : (Val.t * Val.t) Val.tag + (** {6 Type reification} *) type argument_type = -- cgit v1.2.3 From b2beb9087628de23679a831e6273b91816f1ed27 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Dec 2015 19:24:17 +0100 Subject: Using dynamic values in tactic evaluation. --- dev/top_printers.ml | 12 ++-- grammar/argextend.ml4 | 2 +- grammar/tacextend.ml4 | 4 +- lib/genarg.ml | 37 ++++++++++ lib/genarg.mli | 5 ++ plugins/setoid_ring/newring.ml | 2 +- pretyping/pretyping.ml | 2 +- pretyping/pretyping.mli | 4 +- printing/pptacticsig.mli | 6 ++ tactics/geninterp.ml | 4 +- tactics/geninterp.mli | 4 +- tactics/taccoerce.ml | 37 +++++++--- tactics/taccoerce.mli | 6 +- tactics/tacenv.ml | 2 +- tactics/tacenv.mli | 2 +- tactics/tacinterp.ml | 160 +++++++++++++++++++++++++---------------- tactics/tacinterp.mli | 5 +- tactics/tauto.ml4 | 4 +- 18 files changed, 203 insertions(+), 95 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0e90026122..20c8f690bd 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -467,11 +467,13 @@ let pp_generic_argument arg = pp(str"") let prgenarginfo arg = - let tpe = pr_argument_type (genarg_tag arg) in - try - let data = Pptactic.pr_top_generic (Global.env ()) arg in - str "" - with _any -> + let Val.Dyn (tag, _) = arg in + let tpe = str (Val.repr tag) in + (** FIXME *) +(* try *) +(* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) +(* str "" *) +(* with _any -> *) str "" let ppgenarginfo arg = pp (prgenarginfo arg) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index a49291d947..fff7068571 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -194,7 +194,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = (Tacmach.pf_env gl) (Tacmach.project gl) (Tacmach.pf_concl gl) gl.Evd.it (Genarg.in_gen $make_globwit loc globtyp$ x) in - (sigma , out_gen $make_topwit loc globtyp$ a_interp)>> + (sigma , Tacinterp.Value.cast $make_topwit loc globtyp$ a_interp)>> end | Some f -> <:expr< $lid:f$>> in let subst = match h with diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index df2209606d..01828267bf 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -53,7 +53,7 @@ let rec make_let raw e = function let e = make_let raw e l in let v = if raw then <:expr< Genarg.out_gen $make_rawwit loc t$ $lid:p$ >> - else <:expr< Genarg.out_gen $make_topwit loc t$ $lid:p$ >> in + else <:expr< Tacinterp.Value.cast $make_topwit loc t$ $lid:p$ >> in <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let raw e l @@ -73,7 +73,7 @@ let check_unicity s l = let make_clause (pt,_,e) = (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr e) pt)), + vala None, make_let false e pt) let make_fun_clauses loc s l = diff --git a/lib/genarg.ml b/lib/genarg.ml index b6a2849ad5..a43a798c46 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -197,6 +197,43 @@ let val_tag = function | OptArgType t -> assert false | PairArgType (t1, t2) -> assert false +exception CastError of argument_type * Val.t + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let try_prj wit v = match prj (val_tag wit) v with +| None -> raise (CastError (wit, v)) +| Some x -> x + +let rec val_cast : type a. a typed_abstract_argument_type -> Val.t -> a = +fun wit v -> match unquote wit with +| IntOrVarArgType | IdentArgType +| VarArgType | GenArgType +| ConstrArgType | ConstrMayEvalArgType +| OpenConstrArgType | ExtraArgType _ -> try_prj wit v +| ListArgType t -> + let v = match prj list_val v with + | None -> raise (CastError (wit, v)) + | Some v -> v + in + Obj.magic (List.map (fun x -> val_cast t x) v) +| OptArgType t -> + let v = match prj option_val v with + | None -> raise (CastError (wit, v)) + | Some v -> v + in + Obj.magic (Option.map (fun x -> val_cast t x) v) +| PairArgType (t1, t2) -> + let (v1, v2) = match prj pair_val v with + | None -> raise (CastError (wit, v)) + | Some v -> v + in + Obj.magic (val_cast t1 v1, val_cast t2 v2) + (** Registering genarg-manipulating functions *) module type GenObj = diff --git a/lib/genarg.mli b/lib/genarg.mli index d52a246107..c431aa619d 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -191,6 +191,8 @@ val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag (** Retrieve the dynamic type associated to a toplevel genarg. Only works for ground generic arguments. *) +val val_cast : 'a typed_abstract_argument_type -> Val.t -> 'a + val option_val : Val.t option Val.tag val list_val : Val.t list Val.tag val pair_val : (Val.t * Val.t) Val.tag @@ -212,6 +214,9 @@ type argument_type = | PairArgType of argument_type * argument_type | ExtraArgType of string +exception CastError of argument_type * Val.t +(** Exception raised by {!val_cast} *) + val argument_type_eq : argument_type -> argument_type -> bool val pr_argument_type : argument_type -> Pp.std_ppcmds diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 2b07ba7044..d596cf6fb8 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -209,7 +209,7 @@ let get_res = let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac args ist = - let n = Genarg.out_gen (Genarg.topwit Stdarg.wit_int) (List.hd args) in + let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in tactic_res := Array.init n init; Proofview.tclUNIT () diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ce6d189855..f5b89e7895 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -47,7 +47,7 @@ open Misctypes type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t +type unbound_ltac_var_map = Genarg.Val.t Id.Map.t type ltac_var_map = { ltac_constrs : var_map; ltac_uconstrs : uconstr_var_map; diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index f8587d01cd..8b76816ab2 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -29,7 +29,7 @@ type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = Pattern.constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t +type unbound_ltac_var_map = Genarg.Val.t Id.Map.t type ltac_var_map = { ltac_constrs : var_map; @@ -152,5 +152,5 @@ val interp_sort : evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : - (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t -> + (types -> env -> evar_map -> unbound_ltac_var_map -> Genarg.glob_generic_argument -> constr * evar_map) Hook.t diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 1c17d04928..d154e0b663 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -48,6 +48,12 @@ module type Pp = sig val pr_extend : env -> int -> ml_tactic_entry -> typed_generic_argument list -> std_ppcmds + val pr_extend_gen : + ('a -> std_ppcmds) -> int -> ml_tactic_entry -> 'a list -> std_ppcmds + + val pr_alias_gen : ('a -> std_ppcmds) -> + int -> Names.KerName.t -> 'a list -> std_ppcmds + val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds val pr_raw_tactic : raw_tactic_expr -> std_ppcmds diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml index d44c4ac3a0..3da1d542b7 100644 --- a/tactics/geninterp.ml +++ b/tactics/geninterp.ml @@ -12,7 +12,7 @@ open Genarg module TacStore = Store.Make(struct end) type interp_sign = { - lfun : tlevel generic_argument Id.Map.t; + lfun : Val.t Id.Map.t; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> @@ -33,6 +33,6 @@ let register_interp0 = Interp.register0 let generic_interp ist gl v = let unpacker wit v = let (sigma, ans) = interp wit ist gl (glb v) in - (sigma, in_gen (topwit wit) ans) + (sigma, Val.Dyn (val_tag (topwit wit), ans)) in unpack { unpacker; } v diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli index 3c653697d2..472ff10901 100644 --- a/tactics/geninterp.mli +++ b/tactics/geninterp.mli @@ -14,7 +14,7 @@ open Genarg module TacStore : Store.S type interp_sign = { - lfun : tlevel generic_argument Id.Map.t; + lfun : Val.t Id.Map.t; extra : TacStore.t } type ('glb, 'top) interp_fun = interp_sign -> @@ -22,7 +22,7 @@ type ('glb, 'top) interp_fun = interp_sign -> val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -val generic_interp : (glob_generic_argument, typed_generic_argument) interp_fun +val generic_interp : (glob_generic_argument, Val.t) interp_fun val register_interp0 : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index ab71f5f2e7..f856fd842b 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -24,15 +24,30 @@ let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) = let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = Genarg.create_arg None "constr_under_binders" +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + module Value = struct -type t = tlevel generic_argument +type t = Val.t -let rec normalize v = - if has_type v (topwit wit_genarg) then - normalize (out_gen (topwit wit_genarg) v) - else v +let rec normalize v = v (** FIXME *) +(* if has_type v (topwit wit_genarg) then *) +(* normalize (out_gen (topwit wit_genarg) v) *) +(* else v *) let of_constr c = in_gen (topwit wit_constr) c @@ -64,9 +79,15 @@ let to_int v = let to_list v = let v = normalize v in - let list_unpacker wit l = List.map (fun v -> in_gen (topwit wit) v) (top l) in - try Some (list_unpack { list_unpacker } v) - with Failure _ -> None + prj list_val v + +let of_list v = Val.Dyn (list_val, v) + +let to_option v = + let v = normalize v in + prj option_val v + +let of_option v = Val.Dyn (option_val, v) end diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 85bad364d7..4d85ae7099 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -29,8 +29,7 @@ exception CannotCoerceTo of string module Value : sig - type t = tlevel generic_argument - (** Tactics manipulate [tlevel generic_argument]. *) + type t = Val.t val normalize : t -> t (** Eliminated the leading dynamic type casts. *) @@ -42,6 +41,9 @@ sig val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option + val of_list : t list -> t + val to_option : t -> t option option + val of_option : t option -> t end (** {5 Coercion functions} *) diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index c1e4d72e38..d7ab2d71ec 100644 --- a/tactics/tacenv.ml +++ b/tactics/tacenv.ml @@ -31,7 +31,7 @@ let check_alias key = KNmap.mem key !alias_map (** ML tactic extensions (TacML) *) type ml_tactic = - typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic module MLName = struct diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli index 47d9efda57..28fb138817 100644 --- a/tactics/tacenv.mli +++ b/tactics/tacenv.mli @@ -61,7 +61,7 @@ val ltac_entries : unit -> ltac_entry KNmap.t (** {5 ML tactic extensions} *) type ml_tactic = - typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic (** Type of external tactics, used by [TacML]. *) val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 3295b932b9..1760341d11 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -43,25 +43,44 @@ open Taccoerce open Sigma.Notations open Proofview.Notations +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + +let pr_argument_type arg = + let Val.Dyn (tag, _) = arg in + Pp.str (Val.repr tag) + let safe_msgnl s = Proofview.NonLogical.catch (Proofview.NonLogical.print_debug (s++fnl())) (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) -type value = tlevel generic_argument +type value = Val.t (** Abstract application, to print ltac functions *) type appl = | UnnamedAppl (** For generic applications: nothing is printed *) - | GlbAppl of (Names.kernel_name * typed_generic_argument list) list + | GlbAppl of (Names.kernel_name * Val.t list) list (** For calls to global constants, some may alias other. *) let push_appl appl args = match appl with | UnnamedAppl -> UnnamedAppl | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) -let pr_generic arg = - try Pptactic.pr_top_generic (Global.env ()) arg - with e when Errors.noncritical e -> str"" +let pr_generic arg = (** FIXME *) + let Val.Dyn (tag, _) = arg in + str"<" ++ str (Val.repr tag) ++ str ">" let pr_appl h vs = Pptactic.pr_ltac_constant h ++ spc () ++ Pp.prlist_with_sep spc pr_generic vs @@ -123,8 +142,25 @@ module Value = struct let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in of_tacvalue closure + let cast_error wit v = + let pr_v = mt () in (** FIXME *) + let Val.Dyn (tag, _) = v in + let tag = Val.repr tag in + errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ str tag + ++ str " while type " ++ Genarg.pr_argument_type wit ++ str " was expected.") + + let cast wit v = + try val_cast wit v with CastError (wit, v) -> cast_error wit v + end +let print_top_val env arg v = + let unpacker wit cst = + try val_cast (topwit wit) v; mt () + with CastError _ -> mt () + in + unpack { unpacker } arg + let dloc = Loc.ghost let catching_error call_trace fail (e, info) = @@ -176,13 +212,13 @@ let pr_value env v = | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c | _ -> str "a term" else - str "a value of type" ++ spc () ++ pr_argument_type (genarg_tag v) + str "a value of type" ++ spc () ++ pr_argument_type v let pr_closure env ist body = let pp_body = Pptactic.pr_glob_tactic env body in let pr_sep () = fnl () in let pr_iarg (id, arg) = - let arg = pr_argument_type (genarg_tag arg) in + let arg = pr_argument_type arg in hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) in let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in @@ -199,7 +235,7 @@ let pr_inspect env expr result = | VRec (ist, body) -> str "a recursive closure" ++ fnl () ++ pr_closure env !ist body else - let pp_type = pr_argument_type (genarg_tag result) in + let pp_type = pr_argument_type result in str "an object of type" ++ spc () ++ pp_type in pp_expr ++ fnl() ++ str "this is " ++ pp_result @@ -809,7 +845,7 @@ let rec message_of_value v = Ftactic.List.map message_of_value l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) | None -> - let tag = pr_argument_type (genarg_tag v) in + let tag = pr_argument_type v in Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) let interp_message_token ist = function @@ -1095,7 +1131,7 @@ let mk_int_or_var_value ist c = in_gen (topwit wit_int) (interp_int_or_var ist c let pack_sigma (sigma,c) = {it=c;sigma=sigma;} (* Interprets an l-tac expression into a value *) -let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generic_argument Ftactic.t = +let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = (* The name [appl] of applied top-level Ltac names is ignored in [value_interp]. It is installed in the second step by a call to [name_vfun], because it gives more opportunities to detect a @@ -1224,53 +1260,48 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let env = Proofview.Goal.env gl in match tag with | IntOrVarArgType -> - Ftactic.return (mk_int_or_var_value ist (out_gen (glbwit wit_int_or_var) x)) + Ftactic.return (mk_int_or_var_value ist (Genarg.out_gen (glbwit wit_int_or_var) x)) | IdentArgType -> Ftactic.return (value_of_ident (interp_ident ist env sigma - (out_gen (glbwit wit_ident) x))) + (Genarg.out_gen (glbwit wit_ident) x))) | VarArgType -> - Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x)) - | GenArgType -> f (out_gen (glbwit wit_genarg) x) + Ftactic.return (mk_hyp_value ist env sigma (Genarg.out_gen (glbwit wit_var) x)) + | GenArgType -> f (Genarg.out_gen (glbwit wit_genarg) x) | OpenConstrArgType -> let (sigma,v) = - Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (out_gen (glbwit wit_open_constr) x))) gl in + Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (Genarg.out_gen (glbwit wit_open_constr) x))) gl in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) | ConstrMayEvalArgType -> let (sigma,c_interp) = interp_constr_may_eval ist env sigma - (out_gen (glbwit wit_constr_may_eval) x) + (Genarg.out_gen (glbwit wit_constr_may_eval) x) in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) | ListArgType VarArgType -> let wit = glbwit (wit_list wit_var) in - Ftactic.return ( - let ans = List.map (mk_hyp_value ist env sigma) (out_gen wit x) in - in_gen (topwit (wit_list wit_genarg)) ans - ) + let ans = List.map (mk_hyp_value ist env sigma) (Genarg.out_gen wit x) in + Ftactic.return (Value.of_list ans) | ListArgType IntOrVarArgType -> let wit = glbwit (wit_list wit_int_or_var) in - let ans = List.map (mk_int_or_var_value ist) (out_gen wit x) in - Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) + let ans = List.map (mk_int_or_var_value ist) (Genarg.out_gen wit x) in + Ftactic.return (Value.of_list ans) | ListArgType IdentArgType -> let wit = glbwit (wit_list wit_ident) in let mk_ident x = value_of_ident (interp_ident ist env sigma x) in - let ans = List.map mk_ident (out_gen wit x) in - Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) + let ans = List.map mk_ident (Genarg.out_gen wit x) in + Ftactic.return (Value.of_list ans) | ListArgType t -> let open Ftactic in let list_unpacker wit l = - let map x = - f (in_gen (glbwit wit) x) >>= fun v -> - Ftactic.return (out_gen (topwit wit) v) - in + let map x = f (Genarg.in_gen (glbwit wit) x) in Ftactic.List.map map (glb l) >>= fun l -> - Ftactic.return (in_gen (topwit (wit_list wit)) l) + Ftactic.return (Value.of_list l) in list_unpack { list_unpacker } x | ExtraArgType _ -> (** Special treatment of tactics *) - if has_type x (glbwit wit_tactic) then - let tac = out_gen (glbwit wit_tactic) x in + if Genarg.has_type x (glbwit wit_tactic) then + let tac = Genarg.out_gen (glbwit wit_tactic) x in val_interp ist tac else let goal = Proofview.Goal.goal gl in @@ -1294,9 +1325,10 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.lift (tactic_of_value ist v) in let tac = - Ftactic.with_env interp_vars >>= fun (env,l) -> - let name () = Pptactic.pr_tactic env (TacAlias(loc,s,l)) in - Proofview.Trace.name_tactic name (tac l) + Ftactic.with_env interp_vars >>= fun (env, lr) -> + let l = List.map2 (fun (_, g) (_, t) -> print_top_val env g t) l lr in + let name () = Pptactic.pr_alias_gen (fun x -> x) 0 s l in + Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, some more elaborate solution will have to be used. *) @@ -1317,7 +1349,8 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let goal = Evar.unsafe_of_int (-1) in (* /dummy values *) let args = List.map (fun a -> snd(interp_genarg ist env sigma concl goal a)) l in - let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in + let l = List.map2 (print_top_val env) l args in + let name () = Pptactic.pr_extend_gen (fun x -> x) 0 opn l in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) | TacML (loc,opn,l) -> @@ -1334,12 +1367,13 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (fun a sigma -> interp_genarg ist env sigma concl goal a) l goal_sigma in Proofview.Unsafe.tclEVARS sigma <*> - let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in + let l = List.map2 (print_top_val env) l args in + let name () = Pptactic.pr_extend_gen (fun x -> x) 0 opn l in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) end } -and force_vrec ist v : typed_generic_argument Ftactic.t = +and force_vrec ist v : Val.t Ftactic.t = let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let v = to_tacvalue v in @@ -1348,7 +1382,7 @@ and force_vrec ist v : typed_generic_argument Ftactic.t = | v -> Ftactic.return (of_tacvalue v) else Ftactic.return v -and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic.t = +and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = match r with | ArgVar (loc,id) -> let v = @@ -1368,7 +1402,7 @@ and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic. let appl = GlbAppl[r,[]] in val_interp ~appl ist (Tacenv.interp_ltac r) -and interp_tacarg ist arg : typed_generic_argument Ftactic.t = +and interp_tacarg ist arg : Val.t Ftactic.t = match arg with | TacGeneric arg -> Ftactic.nf_enter begin fun gl -> @@ -1428,7 +1462,7 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = | Tacexp t -> val_interp ist t (* Interprets an application node *) -and interp_app loc ist fv largs : typed_generic_argument Ftactic.t = +and interp_app loc ist fv largs : Val.t Ftactic.t = let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in let fv = Value.normalize fv in @@ -1607,22 +1641,22 @@ and interp_genarg ist env sigma concl gl x = match genarg_tag x with | IntOrVarArgType -> in_gen (topwit wit_int_or_var) - (ArgArg (interp_int_or_var ist (out_gen (glbwit wit_int_or_var) x))) + (ArgArg (interp_int_or_var ist (Genarg.out_gen (glbwit wit_int_or_var) x))) | IdentArgType -> in_gen (topwit wit_ident) - (interp_ident ist env sigma (out_gen (glbwit wit_ident) x)) + (interp_ident ist env sigma (Genarg.out_gen (glbwit wit_ident) x)) | VarArgType -> - in_gen (topwit wit_var) (interp_hyp ist env sigma (out_gen (glbwit wit_var) x)) + in_gen (topwit wit_var) (interp_hyp ist env sigma (Genarg.out_gen (glbwit wit_var) x)) | GenArgType -> - in_gen (topwit wit_genarg) (interp_genarg (out_gen (glbwit wit_genarg) x)) + interp_genarg (Genarg.out_gen (glbwit wit_genarg) x) | ConstrArgType -> let (sigma,c_interp) = - interp_constr ist env !evdref (out_gen (glbwit wit_constr) x) + interp_constr ist env !evdref (Genarg.out_gen (glbwit wit_constr) x) in evdref := sigma; in_gen (topwit wit_constr) c_interp | ConstrMayEvalArgType -> - let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (out_gen (glbwit wit_constr_may_eval) x) in + let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (Genarg.out_gen (glbwit wit_constr_may_eval) x) in evdref := sigma; in_gen (topwit wit_constr_may_eval) c_interp | OpenConstrArgType -> @@ -1630,7 +1664,7 @@ and interp_genarg ist env sigma concl gl x = in_gen (topwit wit_open_constr) (interp_open_constr ~expected_type ist env !evdref - (snd (out_gen (glbwit wit_open_constr) x))) + (snd (Genarg.out_gen (glbwit wit_open_constr) x))) | ListArgType ConstrArgType -> let (sigma,v) = interp_genarg_constr_list ist env !evdref x in evdref := sigma; @@ -1638,26 +1672,24 @@ and interp_genarg ist env sigma concl gl x = | ListArgType VarArgType -> interp_genarg_var_list ist env sigma x | ListArgType _ -> let list_unpacker wit l = - let map x = - out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) - in - in_gen (topwit (wit_list wit)) (List.map map (glb l)) + let map x = interp_genarg (Genarg.in_gen (glbwit wit) x) in + Value.of_list (List.map map (glb l)) in list_unpack { list_unpacker } x | OptArgType _ -> let opt_unpacker wit o = match glb o with - | None -> in_gen (topwit (wit_opt wit)) None + | None -> Value.of_option None | Some x -> - let x = out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) in - in_gen (topwit (wit_opt wit)) (Some x) + let x = interp_genarg (Genarg.in_gen (glbwit wit) x) in + Value.of_option (Some x) in opt_unpack { opt_unpacker } x | PairArgType _ -> let pair_unpacker wit1 wit2 o = let (p, q) = glb o in - let p = out_gen (topwit wit1) (interp_genarg (in_gen (glbwit wit1) p)) in - let q = out_gen (topwit wit2) (interp_genarg (in_gen (glbwit wit2) q)) in - in_gen (topwit (wit_pair wit1 wit2)) (p, q) + let p = interp_genarg (Genarg.in_gen (glbwit wit1) p) in + let q = interp_genarg (Genarg.in_gen (glbwit wit2) q) in + Val.Dyn (pair_val, (p, q)) in pair_unpack { pair_unpacker } x | ExtraArgType s -> @@ -1682,14 +1714,16 @@ and global_genarg = fun x -> global_tag (genarg_tag x) and interp_genarg_constr_list ist env sigma x = - let lc = out_gen (glbwit (wit_list wit_constr)) x in + let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in - sigma , in_gen (topwit (wit_list wit_constr)) lc + let lc = List.map Value.of_constr lc in + sigma , Value.of_list lc and interp_genarg_var_list ist env sigma x = - let lc = out_gen (glbwit (wit_list wit_var)) x in + let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in - in_gen (topwit (wit_list wit_var)) lc + let lc = List.map (fun id -> Val.Dyn (val_tag (topwit wit_var), id)) lc in + Value.of_list lc (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : constr Ftactic.t = @@ -2344,8 +2378,8 @@ let interp_redexp env sigma r = let _ = let eval ty env sigma lfun arg = let ist = { lfun = lfun; extra = TacStore.empty; } in - if has_type arg (glbwit wit_tactic) then - let tac = out_gen (glbwit wit_tactic) arg in + if Genarg.has_type arg (glbwit wit_tactic) then + let tac = Genarg.out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in Pfedit.refine_by_tactic env sigma ty tac else diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 88802bf350..c67aa31a9f 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -16,13 +16,14 @@ open Misctypes module Value : sig - type t = tlevel generic_argument + type t = Val.t val of_constr : constr -> t val to_constr : t -> constr option val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t + val cast : 'a typed_abstract_argument_type -> Val.t -> 'a end (** Values for interpretation *) @@ -56,7 +57,7 @@ val get_debug : unit -> debug_info (* spiwack: the [Term.constr] argument is the conclusion of the goal, for "casted open constr" *) val interp_genarg : interp_sign -> Environ.env -> Evd.evar_map -> Term.constr -> Goal.goal -> - glob_generic_argument -> Evd.evar_map * typed_generic_argument + glob_generic_argument -> Evd.evar_map * Value.t (** Interprets any expression *) val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 537d10dd55..3aa9d6d793 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -59,7 +59,7 @@ let wit_tauto_flags : tauto_flags uniform_genarg_type = let assoc_flags ist = let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in - try Genarg.out_gen (topwit wit_tauto_flags) v with _ -> assert false + try Value.cast (topwit wit_tauto_flags) v with _ -> assert false (* Whether inner not are unfolded *) let negation_unfolding = ref true @@ -310,7 +310,7 @@ let simplif ist = let t_simplif = tacticIn simplif "simplif" let tauto_intuit flags t_reduce solver = - let flags = Genarg.in_gen (topwit wit_tauto_flags) flags in + let flags = Genarg.Val.Dyn (Genarg.val_tag (topwit wit_tauto_flags), flags) in let lfun = make_lfun [("t_solver", solver); ("tauto_flags", flags)] in let ist = { default_ist () with lfun = lfun; } in let vars = [Id.of_string "t_solver"] in -- cgit v1.2.3 From 329b5b9ed526d572d7df066dc99486e1dcb9e4cc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Dec 2015 17:18:06 +0100 Subject: Removing the now useless genarg generic argument. --- grammar/argextend.ml4 | 1 - grammar/q_coqast.ml4 | 1 - interp/constrarg.ml | 2 -- interp/constrarg.mli | 2 -- lib/genarg.ml | 6 +----- lib/genarg.mli | 1 - printing/pptactic.ml | 3 --- tactics/taccoerce.ml | 5 +---- tactics/tacintern.ml | 2 -- tactics/tacinterp.ml | 5 +---- tactics/tacsubst.ml | 1 - 11 files changed, 3 insertions(+), 26 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index fff7068571..842f59809f 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -33,7 +33,6 @@ let rec make_wit loc = function | IntOrVarArgType -> <:expr< Constrarg.wit_int_or_var >> | IdentArgType -> <:expr< Constrarg.wit_ident >> | VarArgType -> <:expr< Constrarg.wit_var >> - | GenArgType -> <:expr< Constrarg.wit_genarg >> | ConstrArgType -> <:expr< Constrarg.wit_constr >> | ConstrMayEvalArgType -> <:expr< Constrarg.wit_constr_may_eval >> | OpenConstrArgType -> <:expr< Constrarg.wit_open_constr >> diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index be438b54a5..3088e03654 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -227,7 +227,6 @@ let rec mlexpr_of_argtype loc = function | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >> - | Genarg.GenArgType -> <:expr< Genarg.GenArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> diff --git a/interp/constrarg.ml b/interp/constrarg.ml index a67143b005..84b056ab68 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -38,8 +38,6 @@ let wit_ref = Genarg.make0 None "ref" let wit_quant_hyp = Genarg.make0 None "quant_hyp" -let wit_genarg = unsafe_of_type GenArgType - let wit_sort : (glob_sort, glob_sort, sorts) genarg_type = Genarg.make0 None "sort" diff --git a/interp/constrarg.mli b/interp/constrarg.mli index fdeddd66a1..ef1ef4aee4 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -38,8 +38,6 @@ val wit_ref : (reference, global_reference located or_var, global_reference) gen val wit_quant_hyp : quantified_hypothesis uniform_genarg_type -val wit_genarg : (raw_generic_argument, glob_generic_argument, typed_generic_argument) genarg_type - val wit_sort : (glob_sort, glob_sort, sorts) genarg_type val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type diff --git a/lib/genarg.ml b/lib/genarg.ml index a43a798c46..bf223f99e0 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -17,7 +17,6 @@ type argument_type = | IdentArgType | VarArgType (* Specific types *) - | GenArgType | ConstrArgType | ConstrMayEvalArgType | OpenConstrArgType @@ -30,7 +29,6 @@ let rec argument_type_eq arg1 arg2 = match arg1, arg2 with | IntOrVarArgType, IntOrVarArgType -> true | IdentArgType, IdentArgType -> true | VarArgType, VarArgType -> true -| GenArgType, GenArgType -> true | ConstrArgType, ConstrArgType -> true | ConstrMayEvalArgType, ConstrMayEvalArgType -> true | OpenConstrArgType, OpenConstrArgType -> true @@ -45,7 +43,6 @@ let rec pr_argument_type = function | IntOrVarArgType -> str "int_or_var" | IdentArgType -> str "ident" | VarArgType -> str "var" -| GenArgType -> str "genarg" | ConstrArgType -> str "constr" | ConstrMayEvalArgType -> str "constr_may_eval" | OpenConstrArgType -> str "open_constr" @@ -187,7 +184,6 @@ let val_tag = function | IntOrVarArgType -> cast_tag int_or_var_T | IdentArgType -> cast_tag ident_T | VarArgType -> cast_tag var_T -| GenArgType -> cast_tag genarg_T | ConstrArgType -> cast_tag constr_T | ConstrMayEvalArgType -> cast_tag constr_may_eval_T | OpenConstrArgType -> cast_tag open_constr_T @@ -212,7 +208,7 @@ let try_prj wit v = match prj (val_tag wit) v with let rec val_cast : type a. a typed_abstract_argument_type -> Val.t -> a = fun wit v -> match unquote wit with | IntOrVarArgType | IdentArgType -| VarArgType | GenArgType +| VarArgType | ConstrArgType | ConstrMayEvalArgType | OpenConstrArgType | ExtraArgType _ -> try_prj wit v | ListArgType t -> diff --git a/lib/genarg.mli b/lib/genarg.mli index c431aa619d..89ea49ddb5 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -205,7 +205,6 @@ type argument_type = | IdentArgType | VarArgType (** Specific types *) - | GenArgType | ConstrArgType | ConstrMayEvalArgType | OpenConstrArgType diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 4d14cae7a7..b511300758 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -270,7 +270,6 @@ module Make | IntOrVarArgType -> pr_or_var int (out_gen (rawwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x) - | GenArgType -> pr_raw_generic_rec prc prlc prtac prpat prref (out_gen (rawwit wit_genarg) x) | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) | ConstrMayEvalArgType -> pr_may_eval prc prlc (pr_or_by_notation prref) prpat @@ -306,7 +305,6 @@ module Make | IntOrVarArgType -> pr_or_var int (out_gen (glbwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x) - | GenArgType -> pr_glb_generic_rec prc prlc prtac prpat (out_gen (glbwit wit_genarg) x) | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) | ConstrMayEvalArgType -> pr_may_eval prc prlc @@ -342,7 +340,6 @@ module Make | IntOrVarArgType -> pr_or_var int (out_gen (topwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) | VarArgType -> pr_id (out_gen (topwit wit_var) x) - | GenArgType -> pr_top_generic_rec prc prlc prtac prpat (out_gen (topwit wit_genarg) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x) | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x)) diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index f856fd842b..88e36be14a 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -44,10 +44,7 @@ struct type t = Val.t -let rec normalize v = v (** FIXME *) -(* if has_type v (topwit wit_genarg) then *) -(* normalize (out_gen (topwit wit_genarg) v) *) -(* else v *) +let normalize v = v let of_constr c = in_gen (topwit wit_constr) c diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index ac1229f2f7..d0f83836de 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -733,8 +733,6 @@ and intern_genarg ist x = map_raw wit_ident (intern_ident lf) ist x | VarArgType -> map_raw wit_var intern_hyp ist x - | GenArgType -> - map_raw wit_genarg intern_genarg ist x | ConstrArgType -> map_raw wit_constr intern_constr ist x | ConstrMayEvalArgType -> diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 1760341d11..f87dc663bc 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1266,7 +1266,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (Genarg.out_gen (glbwit wit_ident) x))) | VarArgType -> Ftactic.return (mk_hyp_value ist env sigma (Genarg.out_gen (glbwit wit_var) x)) - | GenArgType -> f (Genarg.out_gen (glbwit wit_genarg) x) | OpenConstrArgType -> let (sigma,v) = Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (Genarg.out_gen (glbwit wit_open_constr) x))) gl in @@ -1647,8 +1646,6 @@ and interp_genarg ist env sigma concl gl x = (interp_ident ist env sigma (Genarg.out_gen (glbwit wit_ident) x)) | VarArgType -> in_gen (topwit wit_var) (interp_hyp ist env sigma (Genarg.out_gen (glbwit wit_var) x)) - | GenArgType -> - interp_genarg (Genarg.out_gen (glbwit wit_genarg) x) | ConstrArgType -> let (sigma,c_interp) = interp_constr ist env !evdref (Genarg.out_gen (glbwit wit_constr) x) @@ -1706,7 +1703,7 @@ and interp_genarg ist env sigma concl gl x = and global_genarg = let rec global_tag = function - | IntOrVarArgType | GenArgType -> true + | IntOrVarArgType -> true | ListArgType t | OptArgType t -> global_tag t | PairArgType (t1,t2) -> global_tag t1 && global_tag t2 | _ -> false diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 6d32aa81b9..2884e318b8 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -284,7 +284,6 @@ and subst_genarg subst (x:glob_generic_argument) = | IdentArgType -> in_gen (glbwit wit_ident) (out_gen (glbwit wit_ident) x) | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x) - | GenArgType -> in_gen (glbwit wit_genarg) (subst_genarg subst (out_gen (glbwit wit_genarg) x)) | ConstrArgType -> in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) | ConstrMayEvalArgType -> -- cgit v1.2.3 From 589130e87d68227d25800e7506666eaf1d47a25a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Dec 2015 17:30:09 +0100 Subject: Changing the toplevel type of the int_or_var generic type to int. --- interp/constrarg.mli | 2 +- plugins/micromega/g_micromega.ml4 | 10 +++------- printing/pptactic.ml | 2 +- tactics/coretactics.ml4 | 4 ---- tactics/eauto.ml4 | 11 ++--------- tactics/extratactics.ml4 | 12 ++++-------- tactics/tacinterp.ml | 2 +- 7 files changed, 12 insertions(+), 31 deletions(-) diff --git a/interp/constrarg.mli b/interp/constrarg.mli index ef1ef4aee4..f2f314eea0 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -26,7 +26,7 @@ val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t (** {5 Additional generic arguments} *) -val wit_int_or_var : int or_var uniform_genarg_type +val wit_int_or_var : (int or_var, int or_var, int) genarg_type val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 62f0ae5037..3c46e1eea0 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -21,12 +21,8 @@ open Misctypes DECLARE PLUGIN "micromega_plugin" -let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") - | ArgArg x -> x - TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z (out_arg i)) ] +| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z i) ] | [ "psatz_Z" ] -> [ (Coq_micromega.psatz_Z (-1)) ] END @@ -63,12 +59,12 @@ TACTIC EXTEND LRA_R END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R (out_arg i)) ] +| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R i) ] | [ "psatz_R" ] -> [ (Coq_micromega.psatz_R (-1)) ] END TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) ] -> [ (Coq_micromega.psatz_Q (out_arg i)) ] +| [ "psatz_Q" int_or_var(i) ] -> [ (Coq_micromega.psatz_Q i) ] | [ "psatz_Q" ] -> [ (Coq_micromega.psatz_Q (-1)) ] END diff --git a/printing/pptactic.ml b/printing/pptactic.ml index b511300758..94cbc54e94 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -337,7 +337,7 @@ module Make let rec pr_top_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (topwit wit_int_or_var) x) + | IntOrVarArgType -> int (out_gen (topwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) | VarArgType -> pr_id (out_gen (topwit wit_var) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 92d4960a7c..1b1fb845e0 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -115,12 +115,10 @@ END TACTIC EXTEND constructor [ "constructor" ] -> [ Tactics.any_constructor false None ] | [ "constructor" int_or_var(i) ] -> [ - let i = Tacinterp.interp_int_or_var ist i in Tactics.constructor_tac false None i NoBindings ] | [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ let { Evd.sigma = sigma; it = bl } = bl in - let i = Tacinterp.interp_int_or_var ist i in let tac = Tactics.constructor_tac false None i bl in Tacticals.New.tclWITHHOLES false tac sigma ] @@ -129,12 +127,10 @@ END TACTIC EXTEND econstructor [ "econstructor" ] -> [ Tactics.any_constructor true None ] | [ "econstructor" int_or_var(i) ] -> [ - let i = Tacinterp.interp_int_or_var ist i in Tactics.constructor_tac true None i NoBindings ] | [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ let { Evd.sigma = sigma; it = bl } = bl in - let i = Tacinterp.interp_int_or_var ist i in let tac = Tactics.constructor_tac true None i bl in Tacticals.New.tclWITHHOLES true tac sigma ] diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 2241fb821c..ffde67e4fb 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -104,11 +104,6 @@ let out_term = function let prolog_tac l n gl = let l = List.map (fun x -> out_term (pf_apply (prepare_hint false (false,true)) gl x)) l in - let n = - match n with - | ArgArg n -> n - | _ -> error "Prolog called with a non closed argument." - in try (prolog l n gl) with UserError ("Refiner.tclFIRST",_) -> errorlabstrm "Prolog.prolog" (str "Prolog failed.") @@ -436,13 +431,11 @@ let gen_eauto ?(debug=Off) np lems = function let make_depth = function | None -> !default_search_depth - | Some (ArgArg d) -> d - | _ -> error "eauto called with a non closed argument." + | Some d -> d let make_dimension n = function | None -> (true,make_depth n) - | Some (ArgArg d) -> (false,d) - | _ -> error "eauto called with a non closed argument." + | Some d -> (false,d) open Genarg diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 92682fc7a0..4ddf9c1162 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -622,10 +622,6 @@ let subst_hole_with_term occ tc t = open Tacmach -let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") - | ArgArg x -> x - let hResolve id c occ t = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in @@ -664,7 +660,7 @@ let hResolve_auto id c t = resolve_auto 1 TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c (out_arg occ) t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] END @@ -686,7 +682,7 @@ let hget_evar n = end } TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ] +| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] END (**********************************************************************) @@ -909,12 +905,12 @@ END (* cycles [n] goals *) TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle (out_arg n) ] +| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] END (* swaps goals number [i] and [j] *) TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap (out_arg i) (out_arg j) ] +| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] END (* reverses the list of focused goals *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index f87dc663bc..5a6834ab5d 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1640,7 +1640,7 @@ and interp_genarg ist env sigma concl gl x = match genarg_tag x with | IntOrVarArgType -> in_gen (topwit wit_int_or_var) - (ArgArg (interp_int_or_var ist (Genarg.out_gen (glbwit wit_int_or_var) x))) + (interp_int_or_var ist (Genarg.out_gen (glbwit wit_int_or_var) x)) | IdentArgType -> in_gen (topwit wit_ident) (interp_ident ist env sigma (Genarg.out_gen (glbwit wit_ident) x)) -- cgit v1.2.3 From 9b02ddf179b375cb09966b70dd3b119eda0d92c1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Dec 2015 17:51:53 +0100 Subject: Sharing toplevel representation for several generic types. - int and int_or_var - ident and var - constr and constr_may_eval --- interp/stdarg.ml | 4 +++- lib/genarg.ml | 10 +++++----- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/interp/stdarg.ml b/interp/stdarg.ml index e155a5217d..5cfe3854a9 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -15,7 +15,9 @@ let wit_bool : bool uniform_genarg_type = make0 None "bool" let wit_int : int uniform_genarg_type = - make0 None "int" + make0 ~dyn:(val_tag (Obj.magic IntOrVarArgType)) None "int" +(** FIXME: IntOrVarArgType is hardwired, but that definition should be the other + way around. *) let wit_string : string uniform_genarg_type = make0 None "string" diff --git a/lib/genarg.ml b/lib/genarg.ml index bf223f99e0..3989cf6df8 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -168,12 +168,10 @@ let default_empty_value t = | None -> None (** Beware: keep in sync with the corresponding types *) -let int_or_var_T = Val.create "int_or_var" +let int_or_var_T = Val.create "int" let ident_T = Val.create "ident" -let var_T = Val.create "var" let genarg_T = Val.create "genarg" let constr_T = Val.create "constr" -let constr_may_eval_T = Val.create "constr_may_eval" let open_constr_T = Val.create "open_constr" let option_val = Val.create "option" @@ -183,9 +181,11 @@ let pair_val = Val.create "pair" let val_tag = function | IntOrVarArgType -> cast_tag int_or_var_T | IdentArgType -> cast_tag ident_T -| VarArgType -> cast_tag var_T +| VarArgType -> cast_tag ident_T + (** Must ensure that toplevel types of Var and Ident agree! *) | ConstrArgType -> cast_tag constr_T -| ConstrMayEvalArgType -> cast_tag constr_may_eval_T +| ConstrMayEvalArgType -> cast_tag constr_T + (** Must ensure that toplevel types of Constr and ConstrMayEval agree! *) | OpenConstrArgType -> cast_tag open_constr_T | ExtraArgType s -> Obj.magic (String.Map.find s !arg0_map).dyn (** Recursive types have no associated dynamic tag *) -- cgit v1.2.3 From 5835804bd69a193b9ea29b6d4c8d0cc03530ccdd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Dec 2015 18:04:14 +0100 Subject: Removing ad-hoc interpretation rules for tactic notations and their genarg. Now that types can share the same dynamic representation, we do not have to transtype the topelvel values dynamically and just take advantage of the standard interpretation function. --- grammar/argextend.ml4 | 2 -- grammar/q_coqast.ml4 | 2 -- interp/constrarg.ml | 8 ++++++-- interp/stdarg.ml | 4 +--- lib/genarg.ml | 14 ++------------ lib/genarg.mli | 2 -- printing/pptactic.ml | 18 +++++++----------- tactics/tacintern.ml | 5 ++--- tactics/tacinterp.ml | 26 +++++--------------------- tactics/tacsubst.ml | 5 ++--- 10 files changed, 25 insertions(+), 61 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 842f59809f..b9336ce333 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -30,11 +30,9 @@ let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function - | IntOrVarArgType -> <:expr< Constrarg.wit_int_or_var >> | IdentArgType -> <:expr< Constrarg.wit_ident >> | VarArgType -> <:expr< Constrarg.wit_var >> | ConstrArgType -> <:expr< Constrarg.wit_constr >> - | ConstrMayEvalArgType -> <:expr< Constrarg.wit_constr_may_eval >> | OpenConstrArgType -> <:expr< Constrarg.wit_open_constr >> | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index 3088e03654..7001f5f627 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -223,12 +223,10 @@ let mlexpr_of_red_expr = function <:expr< Genredexpr.ExtraRedExpr $mlexpr_of_string s$ >> let rec mlexpr_of_argtype loc = function - | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >> | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> - | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> | Genarg.PairArgType (t1,t2) -> diff --git a/interp/constrarg.ml b/interp/constrarg.ml index 84b056ab68..ab54b61977 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -22,7 +22,8 @@ let loc_of_or_by_notation f = function let unsafe_of_type (t : argument_type) : ('a, 'b, 'c) Genarg.genarg_type = Obj.magic t -let wit_int_or_var = unsafe_of_type IntOrVarArgType +let wit_int_or_var = + Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) None "int_or_var" let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = Genarg.make0 None "intropattern" @@ -43,7 +44,8 @@ let wit_sort : (glob_sort, glob_sort, sorts) genarg_type = let wit_constr = unsafe_of_type ConstrArgType -let wit_constr_may_eval = unsafe_of_type ConstrMayEvalArgType +let wit_constr_may_eval = + Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) None "constr_may_eval" let wit_uconstr = Genarg.make0 None "uconstr" @@ -64,11 +66,13 @@ let wit_clause_dft_concl = (** Register location *) let () = + register_name0 wit_int_or_var "Constrarg.wit_int_or_var"; register_name0 wit_ref "Constrarg.wit_ref"; register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern"; register_name0 wit_tactic "Constrarg.wit_tactic"; register_name0 wit_sort "Constrarg.wit_sort"; register_name0 wit_uconstr "Constrarg.wit_uconstr"; + register_name0 wit_constr_may_eval "Constrarg.wit_constr_may_eval"; register_name0 wit_red_expr "Constrarg.wit_red_expr"; register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl"; register_name0 wit_quant_hyp "Constrarg.wit_quant_hyp"; diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 5cfe3854a9..e155a5217d 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -15,9 +15,7 @@ let wit_bool : bool uniform_genarg_type = make0 None "bool" let wit_int : int uniform_genarg_type = - make0 ~dyn:(val_tag (Obj.magic IntOrVarArgType)) None "int" -(** FIXME: IntOrVarArgType is hardwired, but that definition should be the other - way around. *) + make0 None "int" let wit_string : string uniform_genarg_type = make0 None "string" diff --git a/lib/genarg.ml b/lib/genarg.ml index 3989cf6df8..11a0421176 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -13,12 +13,10 @@ module Val = Dyn.Make(struct end) type argument_type = (* Basic types *) - | IntOrVarArgType | IdentArgType | VarArgType (* Specific types *) | ConstrArgType - | ConstrMayEvalArgType | OpenConstrArgType | ListArgType of argument_type | OptArgType of argument_type @@ -26,11 +24,9 @@ type argument_type = | ExtraArgType of string let rec argument_type_eq arg1 arg2 = match arg1, arg2 with -| IntOrVarArgType, IntOrVarArgType -> true | IdentArgType, IdentArgType -> true | VarArgType, VarArgType -> true | ConstrArgType, ConstrArgType -> true -| ConstrMayEvalArgType, ConstrMayEvalArgType -> true | OpenConstrArgType, OpenConstrArgType -> true | ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 | OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 @@ -40,11 +36,9 @@ let rec argument_type_eq arg1 arg2 = match arg1, arg2 with | _ -> false let rec pr_argument_type = function -| IntOrVarArgType -> str "int_or_var" | IdentArgType -> str "ident" | VarArgType -> str "var" | ConstrArgType -> str "constr" -| ConstrMayEvalArgType -> str "constr_may_eval" | OpenConstrArgType -> str "open_constr" | ListArgType t -> pr_argument_type t ++ spc () ++ str "list" | OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" @@ -168,7 +162,6 @@ let default_empty_value t = | None -> None (** Beware: keep in sync with the corresponding types *) -let int_or_var_T = Val.create "int" let ident_T = Val.create "ident" let genarg_T = Val.create "genarg" let constr_T = Val.create "constr" @@ -179,13 +172,10 @@ let list_val = Val.create "list" let pair_val = Val.create "pair" let val_tag = function -| IntOrVarArgType -> cast_tag int_or_var_T | IdentArgType -> cast_tag ident_T | VarArgType -> cast_tag ident_T (** Must ensure that toplevel types of Var and Ident agree! *) | ConstrArgType -> cast_tag constr_T -| ConstrMayEvalArgType -> cast_tag constr_T - (** Must ensure that toplevel types of Constr and ConstrMayEval agree! *) | OpenConstrArgType -> cast_tag open_constr_T | ExtraArgType s -> Obj.magic (String.Map.find s !arg0_map).dyn (** Recursive types have no associated dynamic tag *) @@ -207,9 +197,9 @@ let try_prj wit v = match prj (val_tag wit) v with let rec val_cast : type a. a typed_abstract_argument_type -> Val.t -> a = fun wit v -> match unquote wit with -| IntOrVarArgType | IdentArgType +| IdentArgType | VarArgType -| ConstrArgType | ConstrMayEvalArgType +| ConstrArgType | OpenConstrArgType | ExtraArgType _ -> try_prj wit v | ListArgType t -> let v = match prj list_val v with diff --git a/lib/genarg.mli b/lib/genarg.mli index 89ea49ddb5..83ba1dd04d 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -201,12 +201,10 @@ val pair_val : (Val.t * Val.t) Val.tag type argument_type = (** Basic types *) - | IntOrVarArgType | IdentArgType | VarArgType (** Specific types *) | ConstrArgType - | ConstrMayEvalArgType | OpenConstrArgType | ListArgType of argument_type | OptArgType of argument_type diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 94cbc54e94..9c6da350fa 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -267,13 +267,9 @@ module Make let rec pr_raw_generic_rec prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (rawwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x) | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc (pr_or_by_notation prref) prpat - (out_gen (rawwit wit_constr_may_eval) x) | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = @@ -302,14 +298,9 @@ module Make let rec pr_glb_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (glbwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x) | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc - (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat - (out_gen (glbwit wit_constr_may_eval) x) | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = @@ -337,11 +328,9 @@ module Make let rec pr_top_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | IntOrVarArgType -> int (out_gen (topwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) | VarArgType -> pr_id (out_gen (topwit wit_var) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) - | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x) | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = @@ -1432,6 +1421,8 @@ let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in let pr_string s = str "\"" ++ str s ++ str "\"" in + Genprint.register_print0 Constrarg.wit_int_or_var + (pr_or_var int) (pr_or_var int) int; Genprint.register_print0 Constrarg.wit_ref pr_reference (pr_or_var (pr_located pr_global)) pr_global; Genprint.register_print0 @@ -1462,6 +1453,11 @@ let () = (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) (fun { Evd.it = it } -> pr_bindings_no_with pr_constr pr_lconstr it); + Genprint.register_print0 Constrarg.wit_constr_may_eval + (pr_may_eval pr_constr_expr pr_lconstr_expr (pr_or_by_notation pr_reference) pr_constr_pattern_expr) + (pr_may_eval (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr) + (pr_or_var (pr_and_short_name pr_evaluable_reference)) (pr_pat_and_constr_expr pr_glob_constr)) + pr_constr; Genprint.register_print0 Constrarg.wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index d0f83836de..5e725e182d 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -727,7 +727,6 @@ and intern_match_rule onlytac ist = function and intern_genarg ist x = match genarg_tag x with - | IntOrVarArgType -> map_raw wit_int_or_var intern_int_or_var ist x | IdentArgType -> let lf = ref Id.Set.empty in map_raw wit_ident (intern_ident lf) ist x @@ -735,8 +734,6 @@ and intern_genarg ist x = map_raw wit_var intern_hyp ist x | ConstrArgType -> map_raw wit_constr intern_constr ist x - | ConstrMayEvalArgType -> - map_raw wit_constr_may_eval intern_constr_may_eval ist x | OpenConstrArgType -> map_raw wit_open_constr (fun ist -> on_snd (intern_constr ist)) ist x | ListArgType _ -> @@ -836,6 +833,7 @@ let () = Genintern.register_intern0 wit_clause_dft_concl intern_clause let () = + Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); @@ -844,6 +842,7 @@ let () = Genintern.register_intern0 wit_red_expr (lift intern_red_expr); Genintern.register_intern0 wit_bindings (lift intern_bindings); Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); + Genintern.register_intern0 wit_constr_may_eval (lift intern_constr_may_eval); () (***************************************************************************) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 5a6834ab5d..37d9f1825e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1259,8 +1259,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in match tag with - | IntOrVarArgType -> - Ftactic.return (mk_int_or_var_value ist (Genarg.out_gen (glbwit wit_int_or_var) x)) | IdentArgType -> Ftactic.return (value_of_ident (interp_ident ist env sigma (Genarg.out_gen (glbwit wit_ident) x))) @@ -1270,20 +1268,10 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let (sigma,v) = Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (Genarg.out_gen (glbwit wit_open_constr) x))) gl in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) - | ConstrMayEvalArgType -> - let (sigma,c_interp) = - interp_constr_may_eval ist env sigma - (Genarg.out_gen (glbwit wit_constr_may_eval) x) - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) | ListArgType VarArgType -> let wit = glbwit (wit_list wit_var) in let ans = List.map (mk_hyp_value ist env sigma) (Genarg.out_gen wit x) in Ftactic.return (Value.of_list ans) - | ListArgType IntOrVarArgType -> - let wit = glbwit (wit_list wit_int_or_var) in - let ans = List.map (mk_int_or_var_value ist) (Genarg.out_gen wit x) in - Ftactic.return (Value.of_list ans) | ListArgType IdentArgType -> let wit = glbwit (wit_list wit_ident) in let mk_ident x = value_of_ident (interp_ident ist env sigma x) in @@ -1638,9 +1626,6 @@ and interp_genarg ist env sigma concl gl x = let evdref = ref sigma in let rec interp_genarg x = match genarg_tag x with - | IntOrVarArgType -> - in_gen (topwit wit_int_or_var) - (interp_int_or_var ist (Genarg.out_gen (glbwit wit_int_or_var) x)) | IdentArgType -> in_gen (topwit wit_ident) (interp_ident ist env sigma (Genarg.out_gen (glbwit wit_ident) x)) @@ -1652,10 +1637,6 @@ and interp_genarg ist env sigma concl gl x = in evdref := sigma; in_gen (topwit wit_constr) c_interp - | ConstrMayEvalArgType -> - let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (Genarg.out_gen (glbwit wit_constr_may_eval) x) in - evdref := sigma; - in_gen (topwit wit_constr_may_eval) c_interp | OpenConstrArgType -> let expected_type = WithoutTypeConstraint in in_gen (topwit wit_open_constr) @@ -1703,7 +1684,7 @@ and interp_genarg ist env sigma concl gl x = and global_genarg = let rec global_tag = function - | IntOrVarArgType -> true + | ExtraArgType "int_or_var" -> true (** FIXME *) | ListArgType t | OptArgType t -> global_tag t | PairArgType (t1,t2) -> global_tag t1 && global_tag t2 | _ -> false @@ -2335,6 +2316,7 @@ let interp_constr_with_bindings' ist gl c = (project gl, pack_sigma (sigma, c)) let () = + Geninterp.register_interp0 wit_int_or_var (fun ist gl n -> project gl, interp_int_or_var ist n); Geninterp.register_interp0 wit_ref (lift interp_reference); Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); @@ -2343,7 +2325,9 @@ let () = Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); Geninterp.register_interp0 wit_bindings interp_bindings'; - Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings' + Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + Geninterp.register_interp0 wit_constr_may_eval (lifts interp_constr_may_eval); + () let () = let interp ist gl tac = diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 2884e318b8..0c96653626 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -280,14 +280,11 @@ and subst_match_rule subst = function and subst_genarg subst (x:glob_generic_argument) = match genarg_tag x with - | IntOrVarArgType -> in_gen (glbwit wit_int_or_var) (out_gen (glbwit wit_int_or_var) x) | IdentArgType -> in_gen (glbwit wit_ident) (out_gen (glbwit wit_ident) x) | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x) | ConstrArgType -> in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) - | ConstrMayEvalArgType -> - in_gen (glbwit wit_constr_may_eval) (subst_raw_may_eval subst (out_gen (glbwit wit_constr_may_eval) x)) | OpenConstrArgType -> in_gen (glbwit wit_open_constr) ((),subst_glob_constr subst (snd (out_gen (glbwit wit_open_constr) x))) @@ -322,6 +319,7 @@ and subst_genarg subst (x:glob_generic_argument) = (** Registering *) let () = + Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); Genintern.register_subst0 wit_tactic subst_tactic; @@ -332,4 +330,5 @@ let () = Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; Genintern.register_subst0 wit_bindings subst_bindings; Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; + Genintern.register_subst0 wit_constr_may_eval subst_raw_may_eval; () -- cgit v1.2.3 From 44ac395761d6b46866823b89addaea0ab45f4ebc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Dec 2015 00:38:00 +0100 Subject: Finer-grained types for toplevel values. --- dev/top_printers.ml | 2 +- lib/genarg.ml | 110 ++++++++++++++++++++++++++++++++++++-------------- lib/genarg.mli | 21 +++++++--- tactics/taccoerce.ml | 14 +++++-- tactics/taccoerce.mli | 4 +- tactics/tacinterp.ml | 52 +++++++++++++----------- 6 files changed, 137 insertions(+), 66 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 20c8f690bd..0894e0378d 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -468,7 +468,7 @@ let pp_generic_argument arg = let prgenarginfo arg = let Val.Dyn (tag, _) = arg in - let tpe = str (Val.repr tag) in + let tpe = Val.repr tag in (** FIXME *) (* try *) (* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) diff --git a/lib/genarg.ml b/lib/genarg.ml index 11a0421176..2b8e0c9fdd 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -9,7 +9,51 @@ open Pp open Util -module Val = Dyn.Make(struct end) +module Dyn = Dyn.Make(struct end) + +module Val = +struct + + type 'a typ = 'a Dyn.tag + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a tag * 'a -> t + + let rec eq : type a b. a tag -> b tag -> (a, b) CSig.eq option = + fun t1 t2 -> match t1, t2 with + | Base t1, Base t2 -> Dyn.eq t1 t2 + | List t1, List t2 -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Opt t1, Opt t2 -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Pair (t1, u1), Pair (t2, u2) -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> + match eq u1 u2 with + | None -> None + | Some Refl -> Some Refl + end + | _ -> None + + let rec repr : type a. a tag -> std_ppcmds = function + | Base t -> str (Dyn.repr t) + | List t -> repr t ++ spc () ++ str "list" + | Opt t -> repr t ++ spc () ++ str "option" + | Pair (t1, t2) -> str "(" ++ repr t1 ++ str " * " ++ repr t2 ++ str ")" + +end type argument_type = (* Basic types *) @@ -139,7 +183,7 @@ let create_arg opt ?dyn name = if String.Map.mem name !arg0_map then Errors.anomaly (str "generic argument already declared: " ++ str name) else - let dyn = match dyn with None -> Val.create name | Some dyn -> cast_tag dyn in + let dyn = match dyn with None -> Val.Base (Dyn.create name) | Some dyn -> cast_tag dyn in let obj = { nil = Option.map Obj.repr opt; dyn; } in let () = arg0_map := String.Map.add name obj !arg0_map in ExtraArgType name @@ -162,26 +206,22 @@ let default_empty_value t = | None -> None (** Beware: keep in sync with the corresponding types *) -let ident_T = Val.create "ident" -let genarg_T = Val.create "genarg" -let constr_T = Val.create "constr" -let open_constr_T = Val.create "open_constr" - -let option_val = Val.create "option" -let list_val = Val.create "list" -let pair_val = Val.create "pair" +let base_create n = Val.Base (Dyn.create n) +let ident_T = base_create "ident" +let genarg_T = base_create "genarg" +let constr_T = base_create "constr" +let open_constr_T = base_create "open_constr" -let val_tag = function +let rec val_tag = function | IdentArgType -> cast_tag ident_T | VarArgType -> cast_tag ident_T (** Must ensure that toplevel types of Var and Ident agree! *) | ConstrArgType -> cast_tag constr_T | OpenConstrArgType -> cast_tag open_constr_T -| ExtraArgType s -> Obj.magic (String.Map.find s !arg0_map).dyn -(** Recursive types have no associated dynamic tag *) -| ListArgType t -> assert false -| OptArgType t -> assert false -| PairArgType (t1, t2) -> assert false +| ExtraArgType s -> cast_tag (String.Map.find s !arg0_map).dyn +| ListArgType t -> cast_tag (Val.List (val_tag t)) +| OptArgType t -> cast_tag (Val.Opt (val_tag t)) +| PairArgType (t1, t2) -> cast_tag (Val.Pair (val_tag t1, val_tag t2)) exception CastError of argument_type * Val.t @@ -202,23 +242,31 @@ fun wit v -> match unquote wit with | ConstrArgType | OpenConstrArgType | ExtraArgType _ -> try_prj wit v | ListArgType t -> - let v = match prj list_val v with - | None -> raise (CastError (wit, v)) - | Some v -> v - in - Obj.magic (List.map (fun x -> val_cast t x) v) + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.List tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + Obj.magic (List.map map v) + | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + end | OptArgType t -> - let v = match prj option_val v with - | None -> raise (CastError (wit, v)) - | Some v -> v - in - Obj.magic (Option.map (fun x -> val_cast t x) v) + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Opt tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + Obj.magic (Option.map map v) + | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + end | PairArgType (t1, t2) -> - let (v1, v2) = match prj pair_val v with - | None -> raise (CastError (wit, v)) - | Some v -> v - in - Obj.magic (val_cast t1 v1, val_cast t2 v2) + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Pair (tag1, tag2) -> + let (v1, v2) = v in + let v1 = Val.Dyn (tag1, v1) in + let v2 = Val.Dyn (tag2, v2) in + Obj.magic (val_cast t1 v1, val_cast t2 v2) + | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + end (** Registering genarg-manipulating functions *) diff --git a/lib/genarg.mli b/lib/genarg.mli index 83ba1dd04d..0904960938 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -72,7 +72,22 @@ type ('raw, 'glob, 'top) genarg_type (** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized one, and ['top] the internalized one. *) -module Val : Dyn.S +module Val : +sig + type 'a typ + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a tag * 'a -> t + + val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option + val repr: 'a tag -> Pp.std_ppcmds + +end (** Dynamic types for toplevel values. While the generic types permit to relate objects at various levels of interpretation, toplevel values are wearing their own type regardless of where they came from. This allows to use the @@ -193,10 +208,6 @@ val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag val val_cast : 'a typed_abstract_argument_type -> Val.t -> 'a -val option_val : Val.t option Val.tag -val list_val : Val.t list Val.tag -val pair_val : (Val.t * Val.t) Val.tag - (** {6 Type reification} *) type argument_type = diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 88e36be14a..7fb79d4fe0 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -76,15 +76,21 @@ let to_int v = let to_list v = let v = normalize v in - prj list_val v + let Val.Dyn (tag, v) = v in + match tag with + | Val.List t -> Some (List.map (fun x -> Val.Dyn (t, x)) v) + | _ -> None -let of_list v = Val.Dyn (list_val, v) +let of_list t v = Val.Dyn (Val.List t, v) let to_option v = let v = normalize v in - prj option_val v + let Val.Dyn (tag, v) = v in + match tag with + | Val.Opt t -> Some (Option.map (fun x -> Val.Dyn (t, x)) v) + | _ -> None -let of_option v = Val.Dyn (option_val, v) +let of_option t v = Val.Dyn (Val.Opt t, v) end diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 4d85ae7099..0754c15363 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -41,9 +41,9 @@ sig val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option - val of_list : t list -> t + val of_list : 'a Val.tag -> 'a list -> t val to_option : t -> t option option - val of_option : t option -> t + val of_option : 'a Val.tag -> 'a option -> t end (** {5 Coercion functions} *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 37d9f1825e..570ab245b7 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -58,9 +58,11 @@ let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> let in_gen wit v = Val.Dyn (val_tag wit, v) let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x +let val_tag wit = val_tag (topwit wit) + let pr_argument_type arg = let Val.Dyn (tag, _) = arg in - Pp.str (Val.repr tag) + Val.repr tag let safe_msgnl s = Proofview.NonLogical.catch @@ -80,7 +82,7 @@ let push_appl appl args = | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) let pr_generic arg = (** FIXME *) let Val.Dyn (tag, _) = arg in - str"<" ++ str (Val.repr tag) ++ str ">" + str"<" ++ Val.repr tag ++ str ">" let pr_appl h vs = Pptactic.pr_ltac_constant h ++ spc () ++ Pp.prlist_with_sep spc pr_generic vs @@ -146,7 +148,7 @@ module Value = struct let pr_v = mt () in (** FIXME *) let Val.Dyn (tag, _) = v in let tag = Val.repr tag in - errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ str tag + errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ tag ++ str " while type " ++ Genarg.pr_argument_type wit ++ str " was expected.") let cast wit v = @@ -284,9 +286,9 @@ let coerce_to_tactic loc id v = | _ -> fail () else fail () +let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) let value_of_ident id = - in_gen (topwit wit_intro_pattern) - (Loc.ghost, IntroNaming (IntroIdentifier id)) + in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 @@ -1125,7 +1127,7 @@ let mk_open_constr_value ist gl c = let (sigma,c_interp) = pf_apply (interp_open_constr ist) gl c in sigma, Value.of_constr c_interp let mk_hyp_value ist env sigma c = - Value.of_constr (mkVar (interp_hyp ist env sigma c)) + (mkVar (interp_hyp ist env sigma c)) let mk_int_or_var_value ist c = in_gen (topwit wit_int) (interp_int_or_var ist c) let pack_sigma (sigma,c) = {it=c;sigma=sigma;} @@ -1263,7 +1265,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.return (value_of_ident (interp_ident ist env sigma (Genarg.out_gen (glbwit wit_ident) x))) | VarArgType -> - Ftactic.return (mk_hyp_value ist env sigma (Genarg.out_gen (glbwit wit_var) x)) + Ftactic.return (Value.of_constr (mk_hyp_value ist env sigma (Genarg.out_gen (glbwit wit_var) x))) | OpenConstrArgType -> let (sigma,v) = Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (Genarg.out_gen (glbwit wit_open_constr) x))) gl in @@ -1271,20 +1273,20 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | ListArgType VarArgType -> let wit = glbwit (wit_list wit_var) in let ans = List.map (mk_hyp_value ist env sigma) (Genarg.out_gen wit x) in - Ftactic.return (Value.of_list ans) + Ftactic.return (Value.of_list (val_tag wit_constr) ans) | ListArgType IdentArgType -> let wit = glbwit (wit_list wit_ident) in - let mk_ident x = value_of_ident (interp_ident ist env sigma x) in + let mk_ident x = intro_pattern_of_ident (interp_ident ist env sigma x) in let ans = List.map mk_ident (Genarg.out_gen wit x) in - Ftactic.return (Value.of_list ans) + Ftactic.return (Value.of_list (val_tag wit_intro_pattern) ans) | ListArgType t -> let open Ftactic in - let list_unpacker wit l = + list_unpack { list_unpacker = fun wit l -> let map x = f (Genarg.in_gen (glbwit wit) x) in Ftactic.List.map map (glb l) >>= fun l -> - Ftactic.return (Value.of_list l) - in - list_unpack { list_unpacker } x + let l = CList.map (fun x -> Value.cast (topwit wit) x) l in + Ftactic.return (Value.of_list (val_tag wit) l) + } x | ExtraArgType _ -> (** Special treatment of tactics *) if Genarg.has_type x (glbwit wit_tactic) then @@ -1650,16 +1652,20 @@ and interp_genarg ist env sigma concl gl x = | ListArgType VarArgType -> interp_genarg_var_list ist env sigma x | ListArgType _ -> let list_unpacker wit l = - let map x = interp_genarg (Genarg.in_gen (glbwit wit) x) in - Value.of_list (List.map map (glb l)) + let map x = + let x = interp_genarg (Genarg.in_gen (glbwit wit) x) in + Value.cast (topwit wit) x + in + Value.of_list (val_tag wit) (List.map map (glb l)) in list_unpack { list_unpacker } x | OptArgType _ -> let opt_unpacker wit o = match glb o with - | None -> Value.of_option None + | None -> Value.of_option (val_tag wit) None | Some x -> let x = interp_genarg (Genarg.in_gen (glbwit wit) x) in - Value.of_option (Some x) + let x = Value.cast (topwit wit) x in + Value.of_option (val_tag wit) (Some x) in opt_unpack { opt_unpacker } x | PairArgType _ -> @@ -1667,7 +1673,9 @@ and interp_genarg ist env sigma concl gl x = let (p, q) = glb o in let p = interp_genarg (Genarg.in_gen (glbwit wit1) p) in let q = interp_genarg (Genarg.in_gen (glbwit wit2) q) in - Val.Dyn (pair_val, (p, q)) + let p = Value.cast (topwit wit1) p in + let q = Value.cast (topwit wit2) q in + Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q)) in pair_unpack { pair_unpacker } x | ExtraArgType s -> @@ -1694,14 +1702,12 @@ and global_genarg = and interp_genarg_constr_list ist env sigma x = let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in - let lc = List.map Value.of_constr lc in - sigma , Value.of_list lc + sigma , Value.of_list (val_tag wit_constr) lc and interp_genarg_var_list ist env sigma x = let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in - let lc = List.map (fun id -> Val.Dyn (val_tag (topwit wit_var), id)) lc in - Value.of_list lc + Value.of_list (val_tag wit_var) lc (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : constr Ftactic.t = -- cgit v1.2.3 From 8c51055e67da3fea8b66ebcff6c82cbea079dcee Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Dec 2015 19:24:35 +0100 Subject: ARGUMENT EXTEND shares the toplevel representation when possible. --- grammar/argextend.ml4 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index b9336ce333..87a0dfa984 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -206,13 +206,26 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = (Genarg.in_gen $make_globwit loc globtyp$ x)) >> end | Some f -> <:expr< $lid:f$>> in + let dyn = match typ with + | `Uniform typ -> + let is_new = match typ with + | Genarg.ExtraArgType s' when CString.equal s s' -> true + | _ -> false + in + if is_new then <:expr< None >> + else <:expr< Some (Genarg.val_tag $make_topwit loc typ$) >> + | `Specialized _ -> <:expr< None >> + in let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in let rawwit = <:expr< Genarg.rawwit $wit$ >> in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in declare_str_items loc - [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $default_value$ $se$ >>; + [ <:str_item< + value ($lid:"wit_"^s$) = + let dyn = $dyn$ in + Genarg.make0 ?dyn $default_value$ $se$ >>; <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; -- cgit v1.2.3 From afb9c9a65097dd901df18c443ca13ad4bf394985 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 22 Dec 2015 11:21:42 +0100 Subject: Do not query module files that have already been loaded. For a script that does just "Require Reals", this avoids 40k queries. Note that this changes the signature of the FileDependency feedback. Indeed, it no longer provides the physical path to the dependency but only its logical path (since the physical path is no longer available). The physical path could still have been recovered thanks to the libraries_filename_table list. But due to the existence of the overwrite_library_filenames function, its content cannot be trusted. So anyone interested in the actual physical path should now also rely on the FileLoaded feedback. --- library/library.ml | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/library/library.ml b/library/library.ml index 024ac9e6fa..734a50fe39 100644 --- a/library/library.ml +++ b/library/library.ml @@ -286,12 +286,12 @@ let locate_absolute_library dir = with Not_found -> [] in match find ".vo" @ find ".vio" with | [] -> raise LibNotFound - | [file] -> dir, file + | [file] -> file | [vo;vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ str vo ++ str " because it is more recent"); - dir, vi - | [vo;vi] -> dir, vo + vi + | [vo;vi] -> vo | _ -> assert false let locate_qualified_library ?root ?(warn = true) qid = @@ -459,7 +459,7 @@ let intern_from_file f = module DPMap = Map.Make(DirPath) let rec intern_library (needed, contents) (dir, f) from = - Pp.feedback(Feedback.FileDependency (from, f)); + Pp.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> @@ -467,6 +467,7 @@ let rec intern_library (needed, contents) (dir, f) from = try (DPMap.find dir contents).library_digests, (needed, contents) with Not_found -> (* [dir] is an absolute name which matches [f] which must be in loadpath *) + let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then errorlabstrm "load_physical_library" @@ -481,13 +482,13 @@ and intern_library_deps libs dir m from = (dir :: needed, DPMap.add dir m contents ) and intern_mandatory_library caller from libs (dir,d) = - let digest, libs = intern_library libs (try_locate_absolute_library dir) from in + let digest, libs = intern_library libs (dir, None) from in if not (Safe_typing.digest_match ~actual:digest ~required:d) then errorlabstrm "" (str "Compiled library " ++ str (DirPath.to_string caller) ++ str ".vo makes inconsistent assumptions over library " ++ str (DirPath.to_string dir)); libs -let rec_intern_library libs mref = - let _, libs = intern_library libs mref None in +let rec_intern_library libs (dir, f) = + let _, libs = intern_library libs (dir, Some f) None in libs let native_name_from_filename f = -- cgit v1.2.3 From d55676344c8dc0d9a87b2ef12ec2348281db4bf5 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 22 Dec 2015 14:10:31 +0100 Subject: Move the From logic to Loadpath.expand_path. --- library/library.ml | 12 +----------- library/loadpath.ml | 21 +++++++++++---------- library/loadpath.mli | 2 +- 3 files changed, 13 insertions(+), 22 deletions(-) diff --git a/library/library.ml b/library/library.ml index 734a50fe39..4f964a0510 100644 --- a/library/library.ml +++ b/library/library.ml @@ -297,17 +297,7 @@ let locate_absolute_library dir = let locate_qualified_library ?root ?(warn = true) qid = (* Search library in loadpath *) let dir, base = repr_qualid qid in - let loadpath = match root with - | None -> Loadpath.expand_path dir - | Some root -> - let filter path = - if is_dirpath_prefix_of root path then - let path = drop_dirpath_prefix root path in - is_dirpath_suffix_of dir path - else false - in - Loadpath.filter_path filter - in + let loadpath = Loadpath.expand_path ?root dir in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in let find ext = try diff --git a/library/loadpath.ml b/library/loadpath.ml index 622d390a2c..16b4194544 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -97,18 +97,19 @@ let filter_path f = in aux !load_paths -let expand_path dir = +let expand_path ?root dir = let rec aux = function | [] -> [] - | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> - match implicit with - | true -> - (** The path is implicit, so that we only want match the logical suffix *) - if is_dirpath_suffix_of dir lg then (ph, lg) :: aux l else aux l - | false -> - (** Otherwise we must match exactly *) - if DirPath.equal dir lg then (ph, lg) :: aux l else aux l - in + | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> + let success = + match root with + | None -> + if implicit then is_dirpath_suffix_of dir lg + else DirPath.equal dir lg + | Some root -> + is_dirpath_prefix_of root lg && + is_dirpath_suffix_of dir (drop_dirpath_prefix root lg) in + if success then (ph, lg) :: aux l else aux l in aux !load_paths let locate_file fname = diff --git a/library/loadpath.mli b/library/loadpath.mli index 269e28e0b5..732f6349fb 100644 --- a/library/loadpath.mli +++ b/library/loadpath.mli @@ -42,7 +42,7 @@ val find_load_path : CUnix.physical_path -> t val is_in_load_paths : CUnix.physical_path -> bool (** Whether a physical path is currently bound. *) -val expand_path : DirPath.t -> (CUnix.physical_path * DirPath.t) list +val expand_path : ?root:DirPath.t -> DirPath.t -> (CUnix.physical_path * DirPath.t) list (** Given a relative logical path, associate the list of absolute physical and logical paths which are possible matches of it. *) -- cgit v1.2.3 From 5122a39888cfc6afd2383d59465324dd67b69f4a Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 21 Dec 2015 18:56:43 +0100 Subject: Inclusion of functors with restricted signature is now forbidden (fix #3746) The previous behavior was to include the interface of such a functor, possibly leading to the creation of unexpected axioms, see bug report #3746. In the case of non-functor module with restricted signature, we could simply refer to the original objects (strengthening), but for a functor, the inner objects have no existence yet. As said in the new error message, a simple workaround is hence to first instantiate the functor, then include the local instance: Module LocalInstance := Funct(Args). Include LocalInstance. By the way, the mod_type_alg field is now filled more systematically, cf new comments in declarations.mli. This way, we could use it to know whether a module had been given a restricted signature (via ":"). Earlier, some mod_type_alg were None in situations not handled by the extraction (MEapply of module type). Some code refactoring on the fly. --- kernel/declarations.mli | 23 ++++--- kernel/mod_typing.ml | 128 +++++++++++++++++++++----------------- kernel/mod_typing.mli | 24 ++++--- kernel/modops.ml | 7 ++- kernel/modops.mli | 5 +- kernel/safe_typing.ml | 2 +- plugins/extraction/extract_env.ml | 17 ++--- test-suite/bugs/closed/3746.v | 92 +++++++++++++++++++++++++++ toplevel/himsg.ml | 7 +++ 9 files changed, 220 insertions(+), 85 deletions(-) create mode 100644 test-suite/bugs/closed/3746.v diff --git a/kernel/declarations.mli b/kernel/declarations.mli index dc5c17a75b..0b8272b43d 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -238,17 +238,26 @@ and module_body = { mod_mp : module_path; (** absolute path of the module *) mod_expr : module_implementation; (** implementation *) mod_type : module_signature; (** expanded type *) - (** algebraic type, kept if it's relevant for extraction *) - mod_type_alg : module_expression option; - (** set of all universes constraints in the module *) - mod_constraints : Univ.ContextSet.t; - (** quotiented set of equivalent constants and inductive names *) - mod_delta : Mod_subst.delta_resolver; + mod_type_alg : module_expression option; (** algebraic type *) + mod_constraints : Univ.ContextSet.t; (** + set of all universes constraints in the module *) + mod_delta : Mod_subst.delta_resolver; (** + quotiented set of equivalent constants and inductive names *) mod_retroknowledge : Retroknowledge.action list } +(** For a module, there are five possible situations: + - [Declare Module M : T] then [mod_expr = Abstract; mod_type_alg = Some T] + - [Module M := E] then [mod_expr = Algebraic E; mod_type_alg = None] + - [Module M : T := E] then [mod_expr = Algebraic E; mod_type_alg = Some T] + - [Module M. ... End M] then [mod_expr = FullStruct; mod_type_alg = None] + - [Module M : T. ... End M] then [mod_expr = Struct; mod_type_alg = Some T] + And of course, all these situations may be functors or not. *) + (** A [module_type_body] is just a [module_body] with no implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge] *) + an empty [mod_retroknowledge]. Its [mod_type_alg] contains + the algebraic definition of this module type, or [None] + if it has been built interactively. *) and module_type_body = module_body diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index bd7ee7b339..8a1634881f 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -21,7 +21,7 @@ open Modops open Mod_subst type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.ContextSet.t let rec mp_from_mexpr = function | MEident mp -> mp @@ -183,8 +183,11 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = begin try let mtb_old = module_type_of_module old in - Univ.ContextSet.add_constraints (Subtyping.check_subtypes env' mtb_mp1 mtb_old) old.mod_constraints - with Failure _ -> error_incorrect_with_constraint lab + let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in + Univ.ContextSet.add_constraints chk_cst old.mod_constraints + with Failure _ -> + (* TODO: where can a Failure come from ??? *) + error_incorrect_with_constraint lab end | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; @@ -238,104 +241,89 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Not_found -> error_no_such_label lab | Reduction.NotConvertible -> error_incorrect_with_constraint lab -let mk_alg_with alg wd = Option.map (fun a -> MEwith (a,wd)) alg - let check_with env mp (sign,alg,reso,cst) = function |WithDef(idl,c) -> let struc = destr_nofunctor sign in let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let alg' = mk_alg_with alg (WithDef (idl,(c',Univ.ContextSet.to_context cst'))) in - (NoFunctor struc'),alg',reso, cst+++cst' + let wd' = WithDef (idl,(c',Univ.ContextSet.to_context cst')) in + NoFunctor struc', MEwith (alg,wd'), reso, cst+++cst' |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in - let alg' = mk_alg_with alg wd in - (NoFunctor struc'),alg',reso', cst+++cst' + NoFunctor struc', MEwith (alg,wd), reso', cst+++cst' -let mk_alg_app mpo alg arg = match mpo, alg with - | Some _, Some alg -> Some (MEapply (alg,arg)) - | _ -> None +let translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = + let farg_id, farg_b, fbody_b = destr_functor sign in + let mtb = module_type_of_module (lookup_module mp1 env) in + let cst2 = Subtyping.check_subtypes env mtb farg_b in + let mp_delta = discr_resolver mtb in + let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta in + let body = subst_signature subst fbody_b in + let alg' = mkalg alg mp1 in + let reso' = subst_codom_delta_resolver subst reso in + body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 (** Translation of a module struct entry : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain [SEBapply] or [SEBfunctor]. *) +let mk_alg_app alg arg = MEapply (alg,arg) + let rec translate_mse env mpo inl = function - |MEident mp1 -> - let sign,reso = match mpo with - |Some mp -> - let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp false in - mb.mod_type, mb.mod_delta - |None -> - let mtb = lookup_modtype mp1 env in - mtb.mod_type, mtb.mod_delta + |MEident mp1 as me -> + let mb = match mpo with + |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false + |None -> lookup_modtype mp1 env in - sign,Some (MEident mp1),reso,Univ.ContextSet.empty + mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> - translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) + translate_apply env inl (translate_mse env mpo inl fe) mp1 mk_alg_app |MEwith(me, with_decl) -> assert (mpo == None); (* No 'with' syntax for modules *) let mp = mp_from_mexpr me in check_with env mp (translate_mse env None inl me) with_decl -and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = - let farg_id, farg_b, fbody_b = destr_functor sign in - let mtb = module_type_of_module (lookup_module mp1 env) in - let cst2 = Subtyping.check_subtypes env mtb farg_b in - let mp_delta = discr_resolver mtb in - let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in - let subst = map_mbid farg_id mp1 mp_delta in - let body = subst_signature subst fbody_b in - let alg' = mkalg alg mp1 in - let reso' = subst_codom_delta_resolver subst reso in - body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 - -let mk_alg_funct mpo mbid mtb alg = match mpo, alg with - | Some _, Some alg -> Some (MoreFunctor (mbid,mtb,alg)) - | _ -> None - -let mk_mod mp e ty ty' cst reso = +let mk_mod mp e ty cst reso = { mod_mp = mp; mod_expr = e; mod_type = ty; - mod_type_alg = ty'; + mod_type_alg = None; mod_constraints = cst; mod_delta = reso; mod_retroknowledge = [] } -let mk_modtype mp ty cst reso = mk_mod mp Abstract ty None cst reso +let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso let rec translate_mse_funct env mpo inl mse = function |[] -> let sign,alg,reso,cst = translate_mse env mpo inl mse in - sign, Option.map (fun a -> NoFunctor a) alg, reso, cst + sign, NoFunctor alg, reso, cst |(mbid, ty) :: params -> let mp_id = MPbound mbid in let mtb = translate_modtype env mp_id inl ([],ty) in let env' = add_module_type mp_id mtb env in let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in - let alg' = mk_alg_funct mpo mbid mtb alg in + let alg' = MoreFunctor (mbid,mtb,alg) in MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints and translate_modtype env mp inl (params,mte) = let sign,alg,reso,cst = translate_mse_funct env None inl mte params in let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in let mtb' = subst_modtype_and_resolver mtb mp in - { mtb' with mod_type_alg = alg } + { mtb' with mod_type_alg = Some alg } (** [finalize_module] : - from an already-translated (or interactive) implementation - and a signature entry, produce a final [module_expr] *) + from an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) let finalize_module env mp (sign,alg,reso,cst) restype = match restype with |None -> let impl = match alg with Some e -> Algebraic e | None -> FullStruct in - mk_mod mp impl sign None cst reso + mk_mod mp impl sign cst reso |Some (params_mte,inl) -> let res_mtb = translate_modtype env mp inl params_mte in let auto_mtb = mk_modtype mp sign Univ.ContextSet.empty reso in @@ -344,33 +332,59 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with { res_mtb with mod_mp = mp; mod_expr = impl; - (** cst from module body typing, cst' from subtyping, - and constraints from module type. *) - mod_constraints = Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } + (** cst from module body typing, + cst' from subtyping, + constraints from module type. *) + mod_constraints = + Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } let translate_module env mp inl = function |MType (params,ty) -> let mtb = translate_modtype env mp inl (params,ty) in module_body_of_type mp mtb |MExpr (params,mse,oty) -> - let t = translate_mse_funct env (Some mp) inl mse params in + let (sg,alg,reso,cst) = translate_mse_funct env (Some mp) inl mse params in let restype = Option.map (fun ty -> ((params,ty),inl)) oty in - finalize_module env mp t restype + finalize_module env mp (sg,Some alg,reso,cst) restype + +(** We now forbid any Include of functors with restricted signatures. + Otherwise, we could end with the creation of undesired axioms + (see #3746). Note that restricted non-functorized modules are ok, + thanks to strengthening. *) + +let rec unfunct = function + |NoFunctor me -> me + |MoreFunctor(_,_,me) -> unfunct me + +let rec forbid_incl_signed_functor env = function + |MEapply(fe,_) -> forbid_incl_signed_functor env fe + |MEwith _ -> assert false (* No 'with' syntax for modules *) + |MEident mp1 -> + let mb = lookup_module mp1 env in + match mb.mod_type, mb.mod_type_alg, mb.mod_expr with + |MoreFunctor _, Some _, _ -> + (* functor + restricted signature = error *) + error_include_restricted_functor mp1 + |MoreFunctor _, None, Algebraic me -> + (* functor, no signature yet, a definition which may be restricted *) + forbid_incl_signed_functor env (unfunct me) + |_ -> () let rec translate_mse_inclmod env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.ContextSet.empty + sign,(),mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> let ftrans = translate_mse_inclmod env mp inl fe in - translate_apply env inl ftrans arg (fun _ _ -> None) + translate_apply env inl ftrans arg (fun _ _ -> ()) |MEwith _ -> assert false (* No 'with' syntax for modules *) let translate_mse_incl is_mod env mp inl me = if is_mod then + let () = forbid_incl_signed_functor env me in translate_mse_inclmod env mp inl me else let mtb = translate_modtype env mp inl ([],me) in let sign = clean_bounded_mod_expr mtb.mod_type in - sign,None,mtb.mod_delta,mtb.mod_constraints + sign,(),mtb.mod_delta,mtb.mod_constraints diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index bc0e20205a..d07d59dd9b 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -14,9 +14,18 @@ open Names (** Main functions for translating module entries *) +(** [translate_module] produces a [module_body] out of a [module_entry]. + In the output fields: + - [mod_expr] is [Abstract] for a [MType] entry, or [Algebraic] for [MExpr]. + - [mod_type_alg] is [None] only for a [MExpr] without explicit signature. +*) + val translate_module : env -> module_path -> inline -> module_entry -> module_body +(** [translate_modtype] produces a [module_type_body] whose [mod_type_alg] + cannot be [None] (and of course [mod_expr] is [Abstract]). *) + val translate_modtype : env -> module_path -> inline -> module_type_entry -> module_type_body @@ -24,20 +33,21 @@ val translate_modtype : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain applications or functors. -*) + - The second output is the algebraic expression, kept mostly for + the extraction. *) type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.ContextSet.t val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation +(** From an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) + val finalize_module : - env -> module_path -> module_expression translation -> + env -> module_path -> (module_expression option) translation -> (module_type_entry * inline) option -> module_body @@ -46,4 +56,4 @@ val finalize_module : val translate_mse_incl : bool -> env -> module_path -> inline -> module_struct_entry -> - module_alg_expr translation + unit translation diff --git a/kernel/modops.ml b/kernel/modops.ml index cbb7963315..341c3993a3 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -67,15 +67,13 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string + | IncludeRestrictedFunctor of module_path exception ModuleTypingError of module_typing_error let error_existing_label l = raise (ModuleTypingError (LabelAlreadyDeclared l)) -let error_application_to_not_path mexpr = - raise (ModuleTypingError (ApplicationToNotPath mexpr)) - let error_not_a_functor () = raise (ModuleTypingError NotAFunctor) @@ -112,6 +110,9 @@ let error_generative_module_expected l = let error_no_such_label_sub l l1 = raise (ModuleTypingError (LabelMissing (l,l1))) +let error_include_restricted_functor mp = + raise (ModuleTypingError (IncludeRestrictedFunctor mp)) + (** {6 Operations on functors } *) let is_functor = function diff --git a/kernel/modops.mli b/kernel/modops.mli index a335ad9b4a..86aae598c2 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -126,13 +126,12 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string + | IncludeRestrictedFunctor of module_path exception ModuleTypingError of module_typing_error val error_existing_label : Label.t -> 'a -val error_application_to_not_path : module_struct_entry -> 'a - val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a @@ -152,3 +151,5 @@ val error_incorrect_with_constraint : Label.t -> 'a val error_generative_module_expected : Label.t -> 'a val error_no_such_label_sub : Label.t->string->'a + +val error_include_restricted_functor : module_path -> 'a diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index e0a07dcc3a..036555309f 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -746,7 +746,7 @@ let end_modtype l senv = let add_include me is_module inl senv = let open Mod_typing in let mp_sup = senv.modpath in - let sign,_,resolver,cst = + let sign,(),resolver,cst = translate_mse_incl is_module senv.env mp_sup inl me in let senv = add_constraints (Now (false, cst)) senv in diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 7014df83fd..9964280336 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -177,8 +177,7 @@ let factor_fix env l cb msb = let expand_mexpr env mp me = let inl = Some (Flags.get_inline_level()) in - let sign,_,_,_ = Mod_typing.translate_mse env (Some mp) inl me in - sign + Mod_typing.translate_mse env (Some mp) inl me (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. To check with Elie. *) @@ -231,10 +230,9 @@ let rec extract_structure_spec env mp reso = function (* From [module_expression] to specifications *) -(* Invariant: the [me] given to [extract_mexpr_spec] should either come - from a [mod_type] or [type_expr] field, or their [_alg] counterparts. - This way, any encountered [MEident] should be a true module type. -*) +(* Invariant: the [me_alg] given to [extract_mexpr_spec] and + [extract_mexpression_spec] should come from a [mod_type_alg] field. + This way, any encountered [MEident] should be a true module type. *) and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEident mp -> Visit.add_mp_all mp; MTident mp @@ -247,7 +245,9 @@ and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all mp; MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) - | MEapply _ -> extract_msignature_spec env mp1 no_delta (*TODO*) me_struct + | MEapply _ -> + (* No higher-order module type in OCaml : we use the expanded version *) + extract_msignature_spec env mp1 no_delta (*TODO*) me_struct and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> @@ -335,7 +335,8 @@ and extract_mexpr env mp = function (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) - extract_msignature env mp no_delta ~all:true (expand_mexpr env mp me) + let sign,_,delta,_ = expand_mexpr env mp me in + extract_msignature env mp delta ~all:true sign | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp_all mp; Miniml.MEident mp diff --git a/test-suite/bugs/closed/3746.v b/test-suite/bugs/closed/3746.v new file mode 100644 index 0000000000..a9463f94bb --- /dev/null +++ b/test-suite/bugs/closed/3746.v @@ -0,0 +1,92 @@ + +(* Bug report #3746 : Include and restricted signature *) + +Module Type MT. Parameter p : nat. End MT. +Module Type EMPTY. End EMPTY. +Module Empty. End Empty. + +(* Include of an applied functor with restricted sig : + Used to create axioms (bug report #3746), now forbidden. *) + +Module F (X:EMPTY) : MT. + Definition p := 0. +End F. + +Module InclFunctRestr. + Fail Include F(Empty). +End InclFunctRestr. + +(* A few variants (indirect restricted signature), also forbidden. *) + +Module F1 := F. +Module F2 (X:EMPTY) := F X. + +Module F3a (X:EMPTY). Definition p := 0. End F3a. +Module F3 (X:EMPTY) : MT := F3a X. + +Module InclFunctRestrBis. + Fail Include F1(Empty). + Fail Include F2(Empty). + Fail Include F3(Empty). +End InclFunctRestrBis. + +(* Recommended workaround: manual instance before the include. *) + +Module InclWorkaround. + Module Temp := F(Empty). + Include Temp. +End InclWorkaround. + +Compute InclWorkaround.p. +Print InclWorkaround.p. +Print Assumptions InclWorkaround.p. (* Closed under the global context *) + + + +(* Related situations which are ok, just to check *) + +(* A) Include of non-functor with restricted signature : + creates a proxy to initial stuff *) + +Module M : MT. + Definition p := 0. +End M. + +Module InclNonFunct. + Include M. +End InclNonFunct. + +Definition check : InclNonFunct.p = M.p := eq_refl. +Print Assumptions InclNonFunct.p. (* Closed *) + + +(* B) Include of a module type with opaque content: + The opaque content is "copy-pasted". *) + +Module Type SigOpaque. + Definition p : nat. Proof. exact 0. Qed. +End SigOpaque. + +Module InclSigOpaque. + Include SigOpaque. +End InclSigOpaque. + +Compute InclSigOpaque.p. +Print InclSigOpaque.p. +Print Assumptions InclSigOpaque.p. (* Closed *) + + +(* C) Include of an applied functor with opaque proofs : + opaque proof "copy-pasted" (and substituted). *) + +Module F' (X:EMPTY). + Definition p : nat. Proof. exact 0. Qed. +End F'. + +Module InclFunctOpa. + Include F'(Empty). +End InclFunctOpa. + +Compute InclFunctOpa.p. +Print InclFunctOpa.p. +Print Assumptions InclFunctOpa.p. (* Closed *) diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 8f380830db..a3d502dce4 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -924,6 +924,12 @@ let explain_label_missing l s = str "The field " ++ str (Label.to_string l) ++ str " is missing in " ++ str s ++ str "." +let explain_include_restricted_functor mp = + let q = Nametab.shortest_qualid_of_module mp in + str "Cannot include the functor " ++ Libnames.pr_qualid q ++ + strbrk " since it has a restricted signature. " ++ + strbrk "You may name first an instance of this functor, and include it." + let explain_module_error = function | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err | LabelAlreadyDeclared l -> explain_label_already_declared l @@ -940,6 +946,7 @@ let explain_module_error = function | IncorrectWithConstraint l -> explain_incorrect_label_constraint l | GenerativeModuleExpected l -> explain_generative_module_expected l | LabelMissing (l,s) -> explain_label_missing l s + | IncludeRestrictedFunctor mp -> explain_include_restricted_functor mp (* Module internalization errors *) -- cgit v1.2.3 From e1ac3467db26f9bcc09f12989eeb8379c4fc5817 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 21 Dec 2015 11:37:06 +0100 Subject: COMMENTS: added to the "Names.inductive" and "Names.constructor" types. --- kernel/names.ml | 15 ++++++++++----- kernel/names.mli | 15 ++++++++++----- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/kernel/names.ml b/kernel/names.ml index 0de752c7c5..d1e2c8afee 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -585,11 +585,16 @@ module Mindmap = HMap.Make(MutInd.CanOrd) module Mindset = Mindmap.Set module Mindmap_env = HMap.Make(MutInd.UserOrd) -(** Beware: first inductive has index 0 *) -(** Beware: first constructor has index 1 *) - -type inductive = MutInd.t * int -type constructor = inductive * int +(** Designation of a (particular) inductive type. *) +type inductive = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + +(** Designation of a (particular) constructor of a (particular) inductive type. *) +type constructor = inductive (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) let ind_modpath (mind,_) = MutInd.modpath mind let constr_modpath (ind,_) = ind_modpath ind diff --git a/kernel/names.mli b/kernel/names.mli index b128fe3351..d424552e44 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -411,11 +411,16 @@ module Mindset : CSig.SetS with type elt = MutInd.t module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset module Mindmap_env : Map.S with type key = MutInd.t -(** Beware: first inductive has index 0 *) -type inductive = MutInd.t * int - -(** Beware: first constructor has index 1 *) -type constructor = inductive * int +(** Designation of a (particular) inductive type. *) +type inductive = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + +(** Designation of a (particular) constructor of a (particular) inductive type. *) +type constructor = inductive (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) module Indmap : Map.S with type key = inductive module Constrmap : Map.S with type key = constructor -- cgit v1.2.3 From edc16686634e0700a46b79ba340ca0aac49afb0e Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 21 Dec 2015 13:32:57 +0100 Subject: COMMENTS: of "Constr.case_info" type were updated. --- kernel/constr.ml | 20 ++++++++++++++------ kernel/constr.mli | 20 +++++++++++++------- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/kernel/constr.ml b/kernel/constr.ml index c3aebada26..3e7d888ede 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -41,15 +41,23 @@ type case_printing = { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *) cstr_tags : bool list array; (* whether each pattern var of each constructor is a let-in (true) or not (false) *) style : case_style } + +(* INVARIANT: + * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs + * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)), + * ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i) + *) type case_info = { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) ci_npar : int; (* number of parameters of the above inductive type *) - ci_cstr_ndecls : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (with let's) *) - ci_cstr_nargs : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (w/o let's) *) + ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines + the number of values that can be bound in a match-construct. + NOTE: parameters of the inductive type are therefore excluded from the count *) + ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines + the number of values that can be applied to the constructor, + in addition to the parameters of the related inductive type + NOTE: "lets" are therefore excluded from the count + NOTE: parameters of the inductive type are also excluded from the count *) ci_pp_info : case_printing (* not interpreted by the kernel *) } diff --git a/kernel/constr.mli b/kernel/constr.mli index edd4eb2310..ada2686063 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -30,16 +30,22 @@ type case_printing = cstr_tags : bool list array; (** tell whether letin or lambda in the signature of each constructor *) style : case_style } -(** the integer is the number of real args, needed for reduction *) +(* INVARIANT: + * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs + * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)), + * ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i) + *) type case_info = { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) ci_npar : int; (* number of parameters of the above inductive type *) - ci_cstr_ndecls : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (with let's) *) - ci_cstr_nargs : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (w/o let's) *) + ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines + the number of values that can be bound in a match-construct. + NOTE: parameters of the inductive type are therefore excluded from the count *) + ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines + the number of values that can be applied to the constructor, + in addition to the parameters of the related inductive type + NOTE: "lets" are therefore excluded from the count + NOTE: parameters of the inductive type are also excluded from the count *) ci_pp_info : case_printing (* not interpreted by the kernel *) } -- cgit v1.2.3 From 602badcad9deec9224b78cd1e1033af30358ef2e Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 22 Dec 2015 22:35:09 +0100 Subject: Do not compose "str" and "to_string" whenever possible. For instance, calling only Id.print is faster than calling both str and Id.to_string, since the latter performs a copy. It also makes the code a bit simpler to read. --- checker/safe_typing.ml | 6 ++++-- interp/coqlib.ml | 2 +- library/libnames.ml | 4 ++-- library/library.ml | 10 +++++----- library/nameops.ml | 4 ++-- library/nametab.ml | 2 +- plugins/extraction/table.ml | 2 +- printing/ppconstr.ml | 6 +++--- printing/ppvernac.ml | 2 +- printing/printer.ml | 4 ++-- printing/printmod.ml | 2 +- toplevel/himsg.ml | 16 ++++++++-------- toplevel/obligations.ml | 8 ++++---- toplevel/record.ml | 2 +- toplevel/vernacentries.ml | 6 +++--- 15 files changed, 39 insertions(+), 37 deletions(-) diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 81a3cc035b..ee33051676 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -13,6 +13,8 @@ open Cic open Names open Environ +let pr_dirpath dp = str (DirPath.to_string dp) + (************************************************************************) (* * Global environment @@ -52,9 +54,9 @@ let check_engagement env (expected_impredicative_set,expected_type_in_type) = let report_clash f caller dir = let msg = - str "compiled library " ++ str(DirPath.to_string caller) ++ + str "compiled library " ++ pr_dirpath caller ++ spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++ - str(DirPath.to_string dir) ++ fnl() in + pr_dirpath dir ++ fnl() in f msg diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 5ac718e3b0..b309f26cd6 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -87,7 +87,7 @@ let check_required_library d = *) (* or failing ...*) errorlabstrm "Coqlib.check_required_library" - (str "Library " ++ str (DirPath.to_string dir) ++ str " has to be required first.") + (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") (************************************************************************) (* Specific Coq objects *) diff --git a/library/libnames.ml b/library/libnames.ml index cdaec6a3de..36b46ca498 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -13,7 +13,7 @@ open Names (**********************************************) -let pr_dirpath sl = (str (DirPath.to_string sl)) +let pr_dirpath sl = str (DirPath.to_string sl) (*s Operations on dirpaths *) @@ -197,7 +197,7 @@ let string_of_reference = function let pr_reference = function | Qualid (_,qid) -> pr_qualid qid - | Ident (_,id) -> str (Id.to_string id) + | Ident (_,id) -> Id.print id let loc_of_reference = function | Qualid (loc,qid) -> loc diff --git a/library/library.ml b/library/library.ml index 4f964a0510..ef621e16be 100644 --- a/library/library.ml +++ b/library/library.ml @@ -132,7 +132,7 @@ let try_find_library dir = try find_library dir with Not_found -> errorlabstrm "Library.find_library" - (str "Unknown library " ++ str (DirPath.to_string dir)) + (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) @@ -474,7 +474,7 @@ and intern_library_deps libs dir m from = and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (dir, None) from in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (str "Compiled library " ++ str (DirPath.to_string caller) ++ str ".vo makes inconsistent assumptions over library " ++ str (DirPath.to_string dir)); + errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ str ".vo makes inconsistent assumptions over library " ++ pr_dirpath dir); libs let rec_intern_library libs (dir, f) = @@ -567,7 +567,7 @@ let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> user_err_loc - (loc,"import_library", str (string_of_qualid qid) ++ str " is not a module") + (loc,"import_library", pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -592,7 +592,7 @@ let import_module export modl = try Declaremods.import_module export mp; aux [] l with Not_found -> user_err_loc (loc,"import_library", - str (string_of_qualid dir) ++ str " is not a module")) + pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -604,7 +604,7 @@ let check_coq_overwriting p id = let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && String.equal (Id.to_string (List.last l)) "Coq" then errorlabstrm "" - (str "Cannot build module " ++ str (DirPath.to_string p) ++ str "." ++ pr_id id ++ str "." ++ spc () ++ + (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") (* Verifies that a string starts by a letter and do not contain diff --git a/library/nameops.ml b/library/nameops.ml index 3a23ab97df..418d620c25 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -12,7 +12,7 @@ open Names (* Identifiers *) -let pr_id id = str (Id.to_string id) +let pr_id id = Id.print id let pr_name = function | Anonymous -> str "_" @@ -141,7 +141,7 @@ let name_max na1 na2 = | Name _ -> na1 | Anonymous -> na2 -let pr_lab l = str (Label.to_string l) +let pr_lab l = Label.print l let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/nametab.ml b/library/nametab.ml index 5b6d7cd982..621640ef98 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -523,7 +523,7 @@ let shortest_qualid_of_tactic kn = KnTab.shortest_qualid Id.Set.empty sp !the_tactictab let pr_global_env env ref = - try str (string_of_qualid (shortest_qualid_of_global env ref)) + try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 9feaea8cdb..30486879ee 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -453,7 +453,7 @@ let check_loaded_modfile mp = match base_mp mp with if not (Library.library_is_loaded dp) then begin match base_mp (Lib.current_mp ()) with | MPfile dp' when not (DirPath.equal dp dp') -> - err (str ("Please load library "^(DirPath.to_string dp^" first."))) + err (str "Please load library " ++ pr_dirpath dp ++ str " first.") | _ -> () end | _ -> () diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 56429410cb..d15c3ee2f1 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -153,11 +153,11 @@ end) = struct let pr_qualid sp = let (sl, id) = repr_qualid sp in - let id = tag_ref (str (Id.to_string id)) in + let id = tag_ref (pr_id id) in let sl = match List.rev (DirPath.repr sl) with | [] -> mt () | sl -> - let pr dir = tag_path (str (Id.to_string dir)) ++ str "." in + let pr dir = tag_path (pr_id dir) ++ str "." in prlist pr sl in sl ++ id @@ -182,7 +182,7 @@ end) = struct let pr_reference = function | Qualid (_, qid) -> pr_qualid qid - | Ident (_, id) -> tag_var (str (Id.to_string id)) + | Ident (_, id) -> tag_var (pr_id id) let pr_cref ref us = pr_reference ref ++ pr_universe_instance us diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index f216c599d0..4957199903 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -1034,7 +1034,7 @@ module Make let pr_tac_body tacdef_body = let id, redef, body = match tacdef_body with - | TacticDefinition ((_,id), body) -> str (Id.to_string id), false, body + | TacticDefinition ((_,id), body) -> pr_id id, false, body | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body in let idl, body = diff --git a/printing/printer.ml b/printing/printer.ml index 2e112f9ace..7c031ea536 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -777,7 +777,7 @@ let pr_assumptionset env s = let (v, a, o, tr) = accu in match t with | Variable id -> - let var = str (Id.to_string id) ++ str " : " ++ pr_ltype typ in + let var = pr_id id ++ str " : " ++ pr_ltype typ in (var :: v, a, o, tr) | Axiom (kn,[]) -> let ax = safe_pr_constant env kn ++ safe_pr_ltype typ in @@ -786,7 +786,7 @@ let pr_assumptionset env s = let ax = safe_pr_constant env kn ++ safe_pr_ltype typ ++ cut() ++ prlist_with_sep cut (fun (lbl, ctx, ty) -> - str " used in " ++ str (Names.Label.to_string lbl) ++ + str " used in " ++ pr_label lbl ++ str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty)) l in (v, ax :: a, o, tr) diff --git a/printing/printmod.ml b/printing/printmod.ml index d6f847cc71..e0b1d55be2 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -264,7 +264,7 @@ let nametab_register_modparam mbid mtb = List.iter (nametab_register_body mp dir) struc let print_body is_impl env mp (l,body) = - let name = str (Label.to_string l) in + let name = pr_label l in hov 2 (match body with | SFBmodule _ -> keyword "Module" ++ spc () ++ name | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 8f380830db..e21b6b41ca 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -822,7 +822,7 @@ let explain_not_match_error = function | ModuleTypeFieldExpected -> strbrk "a module type is expected" | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> - str "types given to " ++ str (Id.to_string id) ++ str " differ" + str "types given to " ++ pr_id id ++ str " differ" | NotConvertibleBodyField -> str "the body of definitions differs" | NotConvertibleTypeField (env, typ1, typ2) -> @@ -847,7 +847,7 @@ let explain_not_match_error = function | RecordProjectionsExpected nal -> (if List.length nal >= 2 then str "expected projection names are " else str "expected projection name is ") ++ - pr_enum (function Name id -> str (Id.to_string id) | _ -> str "_") nal + pr_enum (function Name id -> pr_id id | _ -> str "_") nal | NotEqualInductiveAliases -> str "Aliases to inductive types do not match" | NoTypeConstraintExpected -> @@ -896,11 +896,11 @@ let explain_not_equal_module_paths mp1 mp2 = str "Non equal modules." let explain_no_such_label l = - str "No such label " ++ str (Label.to_string l) ++ str "." + str "No such label " ++ pr_label l ++ str "." let explain_incompatible_labels l l' = str "Opening and closing labels are not the same: " ++ - str (Label.to_string l) ++ str " <> " ++ str (Label.to_string l') ++ str "!" + pr_label l ++ str " <> " ++ pr_label l' ++ str "!" let explain_not_a_module s = quote (str s) ++ str " is not a module." @@ -909,19 +909,19 @@ let explain_not_a_module_type s = quote (str s) ++ str " is not a module type." let explain_not_a_constant l = - quote (Label.print l) ++ str " is not a constant." + quote (pr_label l) ++ str " is not a constant." let explain_incorrect_label_constraint l = str "Incorrect constraint for label " ++ - quote (Label.print l) ++ str "." + quote (pr_label l) ++ str "." let explain_generative_module_expected l = - str "The module " ++ str (Label.to_string l) ++ str " is not generative." ++ + str "The module " ++ pr_label l ++ str " is not generative." ++ strbrk " Only components of generative modules can be changed" ++ strbrk " using the \"with\" construct." let explain_label_missing l s = - str "The field " ++ str (Label.to_string l) ++ str " is missing in " + str "The field " ++ pr_label l ++ str " is missing in " ++ str s ++ str "." let explain_module_error = function diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index cac81a9395..a3b973e4d7 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -266,7 +266,7 @@ let reduce c = exception NoObligations of Id.t option let explain_no_obligations = function - Some ident -> str "No obligations for program " ++ str (Id.to_string ident) + Some ident -> str "No obligations for program " ++ Id.print ident | None -> str "No obligations remaining" type obligation_info = @@ -996,7 +996,7 @@ let show_obligations_of_prg ?(msg=true) prg = if !showed > 0 then ( decr showed; msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ str (Id.to_string n) ++ str ":" ++ spc () ++ + str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) @@ -1013,14 +1013,14 @@ let show_obligations ?(msg=true) n = let show_term n = let prg = get_prog_err n in let n = prg.prg_name in - (str (Id.to_string n) ++ spc () ++ str":" ++ spc () ++ + (Id.print n ++ spc () ++ str":" ++ spc () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in - let info = str (Id.to_string n) ++ str " has type-checked" in + let info = Id.print n ++ str " has type-checked" in let prg = init_prog_info sign ~opaque n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( diff --git a/toplevel/record.ml b/toplevel/record.ml index 3a75004b08..c432274a0d 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -171,7 +171,7 @@ let warning_or_error coe indsp err = let st = match err with | MissingProj (fi,projs) -> let s,have = if List.length projs > 1 then "s","were" else "","was" in - (str(Id.to_string fi) ++ + (pr_id fi ++ strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++ strbrk " not defined.") diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 28b5bace13..7144db4949 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -156,7 +156,7 @@ let show_match id = (* "Print" commands *) let print_path_entry p = - let dir = str (DirPath.to_string (Loadpath.logical p)) in + let dir = pr_dirpath (Loadpath.logical p) in let path = str (Loadpath.physical p) in (dir ++ str " " ++ tbrk (0, 0) ++ path) @@ -947,7 +947,7 @@ let register_ltac local tacl = match tactic_body with | TacticDefinition ((loc,id), body) -> let kn = Lib.make_kn id in - let id_pp = str (Id.to_string id) in + let id_pp = pr_id id in let () = if is_defined_tac kn then Errors.user_err_loc (loc, "", str "There is already an Ltac named " ++ id_pp ++ str".") @@ -1584,7 +1584,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = let natureofid = match bdyopt with | None -> "Hypothesis" | Some bdy ->"Constant (let in)" in - v 0 (str (Id.to_string id) ++ str":" ++ pr_constr typ ++ fnl() ++ fnl() + v 0 (pr_id id ++ str":" ++ pr_constr typ ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> print_about ref_or_by_not -- cgit v1.2.3 From 8c684847844b25bd4ce071867fb480c9caa8cb62 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 22 Dec 2015 22:36:27 +0100 Subject: Avoid a pointless conversion/copy. --- library/library.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/library.ml b/library/library.ml index ef621e16be..7aaa8b2e6a 100644 --- a/library/library.ml +++ b/library/library.ml @@ -602,7 +602,7 @@ let import_module export modl = let check_coq_overwriting p id = let l = DirPath.repr p in let is_empty = match l with [] -> true | _ -> false in - if not !Flags.boot && not is_empty && String.equal (Id.to_string (List.last l)) "Coq" then + if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then errorlabstrm "" (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") -- cgit v1.2.3 From 74ebc8b3c20a41f17244d3ab13f984ede2e201e3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 23 Dec 2015 17:32:23 +0100 Subject: Partial backtrack on commit 20641795624. The parsing rules were broken and disallowed tactic replacement of the form Ltac ident ::= expr. --- parsing/g_ltac.ml4 | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 181c2395d2..3f8dd9f193 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -29,6 +29,12 @@ let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + Errors.user_err_loc (loc, "", + str "This expression should be a simple identifier.") + (* Tactics grammar rules *) GEXTEND Gram @@ -242,16 +248,23 @@ GEXTEND Gram | n = integer -> MsgInt n ] ] ; + ltac_def_kind: + [ [ ":=" -> false + | "::=" -> true ] ] + ; + (* Definitions for tactics *) - tacdef_body: - [ [ id = ident; it=LIST1 input_fun; ":="; body = tactic_expr -> - Vernacexpr.TacticDefinition ((!@loc,id), TacFun (it, body)) - | name = Constr.global; it=LIST1 input_fun; "::="; body = tactic_expr -> - Vernacexpr.TacticRedefinition (name, TacFun (it, body)) - | id = ident; ":="; body = tactic_expr -> - Vernacexpr.TacticDefinition ((!@loc,id), body) - | name = Constr.global; "::="; body = tactic_expr -> - Vernacexpr.TacticRedefinition (name, body) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, body) ] ] ; tactic: -- cgit v1.2.3 From f33fc85b1dd2f4994dc85b0943fe503ace2cc5ff Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Dec 2015 17:47:01 +0100 Subject: Removing the last quoted auto tactic in Tauto. --- tactics/tauto.ml4 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 3aa9d6d793..d84f471163 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -393,7 +393,9 @@ let tauto_gen flags = tauto_intuitionistic flags end -let default_intuition_tac = <:tactic< auto with * >> +let default_intuition_tac = + let tac _ _ = Auto.h_auto None [] None in + register_tauto_tactic tac "auto_with" (* This is the uniform mode dealing with ->, not, iff and types isomorphic to /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. -- cgit v1.2.3 From daa7cb065a238c7d4ee394e00315d66d023e5259 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Dec 2015 17:55:25 +0100 Subject: Removing auto from the tactic AST. --- grammar/q_coqast.ml4 | 13 ------- intf/tacexpr.mli | 4 --- parsing/g_tactic.ml4 | 14 -------- plugins/firstorder/g_ground.ml4 | 9 ++++- printing/pptactic.ml | 19 ----------- tactics/coretactics.ml4 | 2 -- tactics/eauto.ml4 | 33 ++---------------- tactics/eauto.mli | 6 ---- tactics/g_auto.ml4 | 76 +++++++++++++++++++++++++++++++++++++++++ tactics/hightactics.mllib | 1 + tactics/tacintern.ml | 6 ---- tactics/tacinterp.ml | 36 ------------------- tactics/tacsubst.ml | 4 --- theories/Init/Notations.v | 1 + 14 files changed, 89 insertions(+), 135 deletions(-) create mode 100644 tactics/g_auto.ml4 diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index 7001f5f627..fc08f0a492 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -420,19 +420,6 @@ let rec mlexpr_of_atomic_tactic = function (* Equivalence relations *) | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >> - (* Automation tactics *) - | Tacexpr.TacAuto (debug,n,lems,l) -> - let d = mlexpr_of_debug debug in - let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in - let lems = mlexpr_of_list mlexpr_of_constr lems in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >> - | Tacexpr.TacTrivial (debug,lems,l) -> - let d = mlexpr_of_debug debug in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - let lems = mlexpr_of_list mlexpr_of_constr lems in - <:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >> - | _ -> failwith "Quotation of atomic tactic expressions: TODO" and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index ead221c5fb..aa1088c9ea 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -162,10 +162,6 @@ type 'a gen_atomic_tactic_expr = rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis - (* Automation tactics *) - | TacTrivial of debug * 'trm list * string list option - | TacAuto of debug * int or_var option * 'trm list * string list option - (* Context management *) | TacClear of bool * 'nam list | TacClearBody of 'nam list diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 3e4a6c6a1b..a197e0209c 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -623,20 +623,6 @@ GEXTEND Gram | IDENT "edestruct"; icl = induction_clause_list -> TacAtom (!@loc, TacInductionDestruct(false,true,icl)) - (* Automation tactic *) - | IDENT "trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Off, lems, db)) - | IDENT "info_trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Info, lems, db)) - | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Debug, lems, db)) - | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Off, n, lems, db)) - | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Info, n, lems, db)) - | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Debug, n, lems, db)) - (* Context management *) | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) | IDENT "clear"; l = LIST0 id_or_meta -> diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index c28da42aea..9d853a79a7 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -52,8 +52,15 @@ let _= in declare_int_option gdopt +let default_intuition_tac = + let tac _ _ = Auto.h_auto None [] None in + let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in + let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in + Tacenv.register_ml_tactic name [| tac |]; + Tacexpr.TacML (Loc.ghost, entry, []) + let (set_default_solver, default_solver, print_default_solver) = - Tactic_option.declare_tactic_option ~default:(<:tactic>) "Firstorder default solver" + Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 9c6da350fa..ff83ac3e9e 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -807,8 +807,6 @@ module Make let rec pr_atom0 a = tag_atom a (match a with | TacIntroPattern [] -> primitive "intros" | TacIntroMove (None,MoveLast) -> primitive "intro" - | TacTrivial (d,[],Some []) -> str (string_of_debug d) ++ primitive "trivial" - | TacAuto (d,None,[],Some []) -> str (string_of_debug d) ++ primitive "auto" | TacClear (true,[]) -> primitive "clear" | t -> str "(" ++ pr_atom1 t ++ str ")" ) @@ -917,23 +915,6 @@ module Make ++ pr_arg pr_quantified_hypothesis h2 ) - (* Automation tactics *) - | TacTrivial (_,[],Some []) as x -> - pr_atom0 x - | TacTrivial (d,lems,db) -> - hov 0 ( - str (string_of_debug d) ++ primitive "trivial" - ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db - ) - | TacAuto (_,None,[],Some []) as x -> - pr_atom0 x - | TacAuto (d,n,lems,db) -> - hov 0 ( - str (string_of_debug d) ++ primitive "auto" - ++ pr_opt (pr_or_var int) n - ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db - ) - (* Context management *) | TacClear (true,[]) as t -> pr_atom0 t diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 1b1fb845e0..6a620deebe 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -221,8 +221,6 @@ let initial_atomic () = "intro", TacIntroMove(None,MoveLast); "intros", TacIntroPattern []; "cofix", TacCofix None; - "trivial", TacTrivial (Off,[],None); - "auto", TacAuto(Off,None,[],None); ] in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index ffde67e4fb..1943a4f1f2 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -438,37 +438,10 @@ let make_dimension n = function | Some d -> (false,d) open Genarg +open G_auto -(* Hint bases *) - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] -END - -let pr_constr_coma_sequence prc _ _ = - prlist_with_sep pr_comma (fun (_,c) -> prc c) - -ARGUMENT EXTEND constr_coma_sequence - TYPED AS open_constr_list - PRINTED BY pr_constr_coma_sequence -| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] -| [ open_constr(c) ] -> [ [c] ] -END - -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c) - -ARGUMENT EXTEND auto_using - TYPED AS open_constr_list - PRINTED BY pr_auto_using -| [ "using" constr_coma_sequence(l) ] -> [ l ] -| [ ] -> [ [] ] -END +let hintbases = G_auto.hintbases +let wit_hintbases = G_auto.wit_hintbases TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) diff --git a/tactics/eauto.mli b/tactics/eauto.mli index b55c70fa12..3d02081bfe 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -15,12 +15,6 @@ val hintbases : hint_db_name list option Pcoq.Gram.entry val wit_hintbases : hint_db_name list option Genarg.uniform_genarg_type -val wit_auto_using : - (Tacexpr.open_constr_expr list, - Tacexpr.open_glob_constr list, Evd.open_constr list) - Genarg.genarg_type - - val e_assumption : unit Proofview.tactic val registered_e_assumption : unit Proofview.tactic diff --git a/tactics/g_auto.ml4 b/tactics/g_auto.ml4 new file mode 100644 index 0000000000..7d35cfaab1 --- /dev/null +++ b/tactics/g_auto.ml4 @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ None ] +| [ "with" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ Some [] ] +END + +let pr_constr_coma_sequence prc _ _ = + prlist_with_sep pr_comma (fun (_,c) -> prc c) + +ARGUMENT EXTEND constr_coma_sequence + TYPED AS open_constr_list + PRINTED BY pr_constr_coma_sequence +| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] +| [ open_constr(c) ] -> [ [c] ] +END + +let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c) + +ARGUMENT EXTEND auto_using + TYPED AS open_constr_list + PRINTED BY pr_auto_using +| [ "using" constr_coma_sequence(l) ] -> [ l ] +| [ ] -> [ [] ] +END + +TACTIC EXTEND trivial +| [ "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial lems db ] +END + +TACTIC EXTEND info_trivial +| [ "info_trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Info lems db ] +END + +TACTIC EXTEND debug_trivial +| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Debug lems db ] +END + +TACTIC EXTEND auto +| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto n lems db ] +END + +TACTIC EXTEND info_auto +| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Info n lems db ] +END + +TACTIC EXTEND debug_auto +| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Debug n lems db ] +END diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index ff2e1ff6aa..30e97f62d5 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,6 +1,7 @@ Extraargs Coretactics Extratactics +G_auto Eauto Class_tactics G_class diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 5e725e182d..ecce4a0ff3 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -517,12 +517,6 @@ let rec intern_atomic lf ist x = (clause_app (intern_hyp_location ist) cls),b, (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) - (* Automation tactics *) - | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l) - | TacAuto (d,n,lems,l) -> - TacAuto (d,Option.map (intern_int_or_var ist) n, - List.map (intern_constr ist) lems,l) - (* Derived basic tactics *) | TacInductionDestruct (ev,isrec,(l,el)) -> TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 570ab245b7..8c8861fd99 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1958,42 +1958,6 @@ and interp_atomic ist tac : unit Proofview.tactic = ((sigma,sigma'),c) clp eqpat) sigma') end } - (* Automation tactics *) - | TacTrivial (debug,lems,l) -> - begin if debug == Tacexpr.Info then - msg_warning - (strbrk"The \"info_trivial\" tactic" ++ spc () - ++strbrk"does not print traces anymore." ++ spc() - ++strbrk"Use \"Info 1 trivial\", instead.") - end; - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let lems = interp_auto_lemmas ist env sigma lems in - name_atomic ~env - (TacTrivial(debug,List.map snd lems,l)) - (Auto.h_trivial ~debug - lems - (Option.map (List.map (interp_hint_base ist)) l)) - end } - | TacAuto (debug,n,lems,l) -> - begin if debug == Tacexpr.Info then - msg_warning - (strbrk"The \"info_auto\" tactic" ++ spc () - ++strbrk"does not print traces anymore." ++ spc() - ++strbrk"Use \"Info 1 auto\", instead.") - end; - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let lems = interp_auto_lemmas ist env sigma lems in - name_atomic ~env - (TacAuto(debug,n,List.map snd lems,l)) - (Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n) - lems - (Option.map (List.map (interp_hint_base ist)) l)) - end } - (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 0c96653626..fdf65292a1 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -154,10 +154,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacLetTac (id,c,clp,b,eqpat) -> TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) - (* Automation tactics *) - | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l) - | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l) - (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> let l' = List.map (fun (c,ids,cls) -> diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index a7bdba90aa..2f6d824d2a 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -85,6 +85,7 @@ Open Scope type_scope. Declare ML Module "coretactics". Declare ML Module "extratactics". +Declare ML Module "g_auto". Declare ML Module "eauto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". -- cgit v1.2.3 From 83b2b197eb33b78f2e3054819f1a36f971c24426 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 16 Dec 2015 23:23:56 +0100 Subject: Fixing non exhaustive pattern-matching in 003fe3d5e60b. --- grammar/q_util.ml4 | 1 + parsing/compat.ml4 | 1 + 2 files changed, 2 insertions(+) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 19f436f926..76113ad509 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -56,6 +56,7 @@ let mlexpr_of_token = function | Tok.IDENT s -> <:expr< Tok.IDENT $mlexpr_of_string s$ >> | Tok.FIELD s -> <:expr< Tok.FIELD $mlexpr_of_string s$ >> | Tok.INT s -> <:expr< Tok.INT $mlexpr_of_string s$ >> +| Tok.INDEX s -> <:expr< Tok.INDEX $mlexpr_of_string s$ >> | Tok.STRING s -> <:expr< Tok.STRING $mlexpr_of_string s$ >> | Tok.LEFTQMARK -> <:expr< Tok.LEFTQMARK >> | Tok.BULLET s -> <:expr< Tok.BULLET $mlexpr_of_string s$ >> diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 4208fd364e..a214b58a60 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -266,6 +266,7 @@ IFDEF CAMLP5 THEN | Tok.PATTERNIDENT s -> "PATTERNIDENT", s | Tok.FIELD s -> "FIELD", s | Tok.INT s -> "INT", s + | Tok.INDEX s -> "INDEX", s | Tok.STRING s -> "STRING", s | Tok.LEFTQMARK -> "LEFTQMARK", "" | Tok.BULLET s -> "BULLET", s -- cgit v1.2.3 From 1f2cc4026cd5e977979ff1507fd5fa0d96e1a92f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 25 Dec 2015 06:08:29 +0100 Subject: Moving the ad hoc interpretation of "intros" as "intros **" from tacinterp.ml to g_tactic.ml4 so as to leave room for "IntroPattern []" to mean "no introduction". --- parsing/g_tactic.ml4 | 8 +++++++- tactics/tacinterp.ml | 2 +- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index a197e0209c..31125e37cf 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -281,6 +281,9 @@ GEXTEND Gram intropatterns: [ [ l = LIST0 nonsimple_intropattern -> l ]] ; + ne_intropatterns: + [ [ l = LIST1 nonsimple_intropattern -> l ]] + ; or_and_intropattern: [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc | "()" -> [[]] @@ -532,7 +535,10 @@ GEXTEND Gram simple_tactic: [ [ (* Basic tactics *) - IDENT "intros"; pl = intropatterns -> TacAtom (!@loc, TacIntroPattern pl) + IDENT "intros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern pl) + | IDENT "intros" -> + TacAtom (!@loc, TacIntroPattern [!@loc,IntroForthcoming false]) | IDENT "intro"; id = ident; hto = move_location -> TacAtom (!@loc, TacIntroMove (Some id, hto)) | IDENT "intro"; hto = move_location -> TacAtom (!@loc, TacIntroMove (None, hto)) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 8c8861fd99..d96c8f98a2 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1775,7 +1775,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacIntroPattern l) (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) - (Tactics.intros_patterns l')) sigma + (Tactics.intro_patterns l')) sigma end } | TacIntroMove (ido,hto) -> Proofview.Goal.enter { enter = begin fun gl -> -- cgit v1.2.3 From c3e01a044297d322d8a5e6830fe3af002ebd2dce Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 18 Dec 2015 08:23:35 +0100 Subject: Fixing an "injection as" bug in the presence of side conditions. --- tactics/equality.ml | 8 ++++---- test-suite/success/Injection.v | 6 ++++++ 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index 92ebcb2724..1854b41205 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1319,13 +1319,13 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = tclZEROMSG (str "Failed to decompose the equality.") else Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) - (Proofview.tclBIND - (Proofview.Monad.List.map + (Tacticals.New.tclTHENFIRST + (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; Proofview.V82.tactic (refine pf)]) - (if l2r then List.rev injectors else injectors)) - (fun _ -> tac (List.length injectors))) + (if l2r then List.rev injectors else injectors))) + (tac (List.length injectors))) let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index 25e464d677..8fd0394625 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -68,6 +68,12 @@ einjection (H O). instantiate (1:=O). Abort. +Goal (forall x y : nat, x = y -> S x = S y) -> True. +intros. +einjection (H O) as H0. +instantiate (y:=O). +Abort. + (* Test the injection intropattern *) Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. -- cgit v1.2.3 From df9d69f3ccf3e5600919a21112afda00b463fbc5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 18 Dec 2015 19:38:19 +0100 Subject: Fixing a bug in the order of side conditions for introduction pattern -> and <-. --- tactics/tactics.ml | 2 +- test-suite/success/intros.v | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2e7adc513a..0c4c5b673b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2240,7 +2240,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with | IntroInjection l' -> intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> - Tacticals.New.tclTHENLAST + Tacticals.New.tclTHENFIRST (* Skip the side conditions of the rewriting step *) (rewrite_hyp style l2r id) (tac thin None []) diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 11156aa0ee..69d66f1008 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -84,3 +84,17 @@ Qed. Goal forall x : nat, True. intros y%(fun x => x). Abort. + +(* Fixing a bug in the order of side conditions of a "->" step *) + +Goal (True -> 1=0) -> 1=1. +intros ->. +- reflexivity. +- exact I. +Qed. + +Goal forall x, (True -> x=0) -> 0=x. +intros x ->. +- reflexivity. +- exact I. +Qed. -- cgit v1.2.3 From b508e2b745be0c38c18f2b8874adf8550bbe6d96 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 20 Dec 2015 04:16:15 +0100 Subject: Moving specialize to Proofview.tactic. --- tactics/coretactics.ml4 | 3 +-- tactics/tactics.ml | 40 ++++++++++++++++++++++++---------------- tactics/tactics.mli | 2 +- 3 files changed, 26 insertions(+), 19 deletions(-) diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 6a620deebe..2682ca0708 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -141,8 +141,7 @@ END TACTIC EXTEND specialize [ "specialize" constr_with_bindings(c) ] -> [ let { Evd.sigma = sigma; it = c } = c in - let specialize = Proofview.V82.tactic (Tactics.specialize c) in - Tacticals.New.tclWITHHOLES false specialize sigma + Tacticals.New.tclWITHHOLES false (Tactics.specialize c) sigma ] END diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0c4c5b673b..f3f6014936 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1894,13 +1894,16 @@ let rec intros_clearing = function (* Modifying/Adding an hypothesis *) -let specialize (c,lbind) g = - let tac, term = +let specialize (c,lbind) = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma, term = if lbind == NoBindings then - let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in - tclEVARS evd, nf_evar evd c + let sigma = Typeclasses.resolve_typeclasses env sigma in + sigma, nf_evar sigma c else - let clause = Tacmach.pf_apply make_clenv_binding g (c,Tacmach.pf_unsafe_type_of g c) lbind in + let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in @@ -1914,18 +1917,23 @@ let specialize (c,lbind) g = errorlabstrm "" (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); - tclEVARS clause.evd, term - in + clause.evd, term in + let typ = Retyping.get_type_of env sigma term in match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with - | Var id when Id.List.mem id (Tacmach.pf_ids_of_hyps g) -> - tclTHEN tac - (tclTHENFIRST - (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (Tacmach.pf_unsafe_type_of g term)) g) - (exact_no_check term)) g - | _ -> tclTHEN tac - (tclTHENLAST - (fun g -> Proofview.V82.of_tactic (cut (Tacmach.pf_unsafe_type_of g term)) g) - (exact_no_check term)) g + | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENFIRST + (assert_before_replacing id typ) + (new_exact_no_check term)) + | _ -> + (* To deprecate in favor of generalize? *) + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENLAST + (cut typ) + (new_exact_no_check term)) + end } (* Keeping only a few hypotheses *) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index f5695ff06e..c966adb801 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -170,7 +170,7 @@ val unfold_body : Id.t -> tactic val keep : Id.t list -> unit Proofview.tactic val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic -val specialize : constr with_bindings -> tactic +val specialize : constr with_bindings -> unit Proofview.tactic val move_hyp : Id.t -> Id.t move_location -> tactic val rename_hyp : (Id.t * Id.t) list -> unit Proofview.tactic -- cgit v1.2.3 From f1c3348278fb00636e0a46595d354ffc8a00992c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 20 Dec 2015 04:21:55 +0100 Subject: Moving code of specialize so that it can accept "as" (no semantic change). --- tactics/tactics.ml | 86 +++++++++++++++++++++++++++--------------------------- 1 file changed, 43 insertions(+), 43 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f3f6014936..df54500f92 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1892,49 +1892,6 @@ let rec intros_clearing = function Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHypId (fun id -> Proofview.V82.tactic (clear [id])); intros_clearing tl] -(* Modifying/Adding an hypothesis *) - -let specialize (c,lbind) = - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let sigma, term = - if lbind == NoBindings then - let sigma = Typeclasses.resolve_typeclasses env sigma in - sigma, nf_evar sigma c - else - let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in - let flags = { (default_unify_flags ()) with resolve_evars = true } in - let clause = clenv_unify_meta_types ~flags clause in - let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in - let rec chk = function - | [] -> [] - | t::l -> if occur_meta t then [] else t :: chk l - in - let tstack = chk tstack in - let term = applist(thd,List.map (nf_evar clause.evd) tstack) in - if occur_meta term then - errorlabstrm "" (str "Cannot infer an instance for " ++ - pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ - str "."); - clause.evd, term in - let typ = Retyping.get_type_of env sigma term in - match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with - | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) - (Tacticals.New.tclTHENFIRST - (assert_before_replacing id typ) - (new_exact_no_check term)) - | _ -> - (* To deprecate in favor of generalize? *) - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) - (Tacticals.New.tclTHENLAST - (cut typ) - (new_exact_no_check term)) - end } - (* Keeping only a few hypotheses *) let keep hyps = @@ -2686,6 +2643,49 @@ let quantify lconstr = tclIDTAC *) +(* Modifying/Adding an hypothesis *) + +let specialize (c,lbind) = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma, term = + if lbind == NoBindings then + let sigma = Typeclasses.resolve_typeclasses env sigma in + sigma, nf_evar sigma c + else + let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in + let flags = { (default_unify_flags ()) with resolve_evars = true } in + let clause = clenv_unify_meta_types ~flags clause in + let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in + let rec chk = function + | [] -> [] + | t::l -> if occur_meta t then [] else t :: chk l + in + let tstack = chk tstack in + let term = applist(thd,List.map (nf_evar clause.evd) tstack) in + if occur_meta term then + errorlabstrm "" (str "Cannot infer an instance for " ++ + pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ + str "."); + clause.evd, term in + let typ = Retyping.get_type_of env sigma term in + match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with + | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENFIRST + (assert_before_replacing id typ) + (new_exact_no_check term)) + | _ -> + (* To deprecate in favor of generalize? *) + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENLAST + (cut typ) + (new_exact_no_check term)) + end } + (*****************************) (* Ad hoc unfold *) (*****************************) -- cgit v1.2.3 From 223db63e09d3f4b0e779961918b1fedd5cda511d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 20 Dec 2015 01:28:08 +0100 Subject: Moving basic generalization tactics upwards for possible use in "intros". --- tactics/tactics.ml | 72 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 38 insertions(+), 34 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index df54500f92..c8a9d7384b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1910,6 +1910,44 @@ let keep hyps = Proofview.V82.tactic (fun gl -> thin cl gl) end } +(*********************************) +(* Basic generalization tactics *) +(*********************************) + +(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] + and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], + this generalizes [hyps |- goal] into [hyps |- T] *) + +let apply_type hdcty argl gl = + refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl + +(* Given a context [hyps] with domain [x1..xn], possibly with let-ins, + and well-typed in the current goal, [bring_hyps hyps] generalizes + [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) + +let bring_hyps hyps = + if List.is_empty hyps then Tacticals.New.tclIDTAC + else + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let store = Proofview.Goal.extra gl in + let concl = Tacmach.New.pf_nf_concl gl in + let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in + let args = Array.of_list (instance_from_named_context hyps) in + Proofview.Refine.refine { run = begin fun sigma -> + let Sigma (ev, sigma, p) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (mkApp (ev, args), sigma, p) + end } + end } + +let revert hyps = + Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in + (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) + end } + (************************) (* Introduction tactics *) (************************) @@ -2474,40 +2512,6 @@ let enough_by na t tac = forward false (Some tac) (ipat_of_name na) t (* Generalization tactics *) (***************************) -(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] - and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], - this generalizes [hyps |- goal] into [hyps |- T] *) - -let apply_type hdcty argl gl = - refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl - -(* Given a context [hyps] with domain [x1..xn], possibly with let-ins, - and well-typed in the current goal, [bring_hyps hyps] generalizes - [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) - -let bring_hyps hyps = - if List.is_empty hyps then Tacticals.New.tclIDTAC - else - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let store = Proofview.Goal.extra gl in - let concl = Tacmach.New.pf_nf_concl gl in - let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in - let args = Array.of_list (instance_from_named_context hyps) in - Proofview.Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = - Evarutil.new_evar env sigma ~principal:true ~store newcl in - Sigma (mkApp (ev, args), sigma, p) - end } - end } - -let revert hyps = - Proofview.Goal.enter { enter = begin fun gl -> - let gl = Proofview.Goal.assume gl in - let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in - (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) - end } - (* Compute a name for a generalization *) let generalized_name c t ids cl = function -- cgit v1.2.3 From 77e6eda6388aba117476f6c8445c4b61ebdbc33e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Dec 2015 00:44:58 +0100 Subject: Tentative API fix for tactic arguments to be fed to tclWITHHOLES. The previous implementation was a source of evar leaks if misused, as it created values coming together with their current evar_map. This is dead wrong if the value is not used on the spot. To fix this, we rather return a ['a delayed_open] object. Two argument types were modified: bindings and constr_bindings. The open_constr argument should also be fixed, but it is more entangled and thus I leave it for another commit. --- interp/constrarg.mli | 4 ++-- plugins/funind/g_indfun.ml4 | 4 +++- printing/pptactic.ml | 4 ++-- tactics/coretactics.ml4 | 31 +++++++++++-------------------- tactics/extratactics.ml4 | 10 +++++----- tactics/extratactics.mli | 2 +- tactics/tacinterp.ml | 16 +++++++++------- tactics/tacticals.ml | 8 ++++++++ tactics/tacticals.mli | 1 + 9 files changed, 42 insertions(+), 38 deletions(-) diff --git a/interp/constrarg.mli b/interp/constrarg.mli index f2f314eea0..052e4ec69b 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -55,12 +55,12 @@ val wit_open_constr : val wit_constr_with_bindings : (constr_expr with_bindings, glob_constr_and_expr with_bindings, - constr with_bindings Evd.sigma) genarg_type + constr with_bindings delayed_open) genarg_type val wit_bindings : (constr_expr bindings, glob_constr_and_expr bindings, - constr bindings Evd.sigma) genarg_type + constr bindings delayed_open) genarg_type val wit_hyp_location_flag : Locus.hyp_location_flag uniform_genarg_type diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 045beb37cf..cba10ca09d 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -55,7 +55,9 @@ let pr_with_bindings_typed prc prlc (c,bl) = let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () - | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it) + | Some b -> + let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in + spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) ARGUMENT EXTEND fun_ind_using diff --git a/printing/pptactic.ml b/printing/pptactic.ml index ff83ac3e9e..b98738ce31 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1433,7 +1433,7 @@ let () = Genprint.register_print0 Constrarg.wit_bindings (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun { Evd.it = it } -> pr_bindings_no_with pr_constr pr_lconstr it); + (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); Genprint.register_print0 Constrarg.wit_constr_may_eval (pr_may_eval pr_constr_expr pr_lconstr_expr (pr_or_by_notation pr_reference) pr_constr_pattern_expr) (pr_may_eval (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr) @@ -1442,7 +1442,7 @@ let () = Genprint.register_print0 Constrarg.wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun { Evd.it = it } -> pr_with_bindings pr_constr pr_lconstr it); + (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); Genprint.register_print0 Stdarg.wit_int int int int; Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 2682ca0708..10de3e866a 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -74,15 +74,13 @@ END TACTIC EXTEND left_with [ "left" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.left_with_bindings false bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) ] END TACTIC EXTEND eleft_with [ "eleft" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) ] END @@ -98,15 +96,13 @@ END TACTIC EXTEND right_with [ "right" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.right_with_bindings false bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) ] END TACTIC EXTEND eright_with [ "eright" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) ] END @@ -118,9 +114,8 @@ TACTIC EXTEND constructor Tactics.constructor_tac false None i NoBindings ] | [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma; it = bl } = bl in - let tac = Tactics.constructor_tac false None i bl in - Tacticals.New.tclWITHHOLES false tac sigma + let tac bl = Tactics.constructor_tac false None i bl in + Tacticals.New.tclDELAYEDWITHHOLES false bl tac ] END @@ -130,9 +125,8 @@ TACTIC EXTEND econstructor Tactics.constructor_tac true None i NoBindings ] | [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma; it = bl } = bl in - let tac = Tactics.constructor_tac true None i bl in - Tacticals.New.tclWITHHOLES true tac sigma + let tac bl = Tactics.constructor_tac true None i bl in + Tacticals.New.tclDELAYEDWITHHOLES true bl tac ] END @@ -140,8 +134,7 @@ END TACTIC EXTEND specialize [ "specialize" constr_with_bindings(c) ] -> [ - let { Evd.sigma = sigma; it = c } = c in - Tacticals.New.tclWITHHOLES false (Tactics.specialize c) sigma + Tacticals.New.tclDELAYEDWITHHOLES false c Tactics.specialize ] END @@ -161,15 +154,13 @@ END TACTIC EXTEND split_with [ "split" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.split_with_bindings false [bl]) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) ] END TACTIC EXTEND esplit_with [ "esplit" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true [bl]) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) ] END diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 4ddf9c1162..dce7a18608 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -70,8 +70,8 @@ let induction_arg_of_quantified_hyp = function ElimOnIdent and not as "constr" *) let elimOnConstrWithHoles tac with_evars c = - Tacticals.New.tclWITHHOLES with_evars - (tac with_evars (Some (None,ElimOnConstr c.it))) c.sigma + Tacticals.New.tclDELAYEDWITHHOLES with_evars c + (fun c -> tac with_evars (Some (None,ElimOnConstr c))) TACTIC EXTEND simplify_eq_main | [ "simplify_eq" constr_with_bindings(c) ] -> @@ -116,7 +116,7 @@ END open Proofview.Notations let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> - discr_main {it = Term.mkVar id,NoBindings; sigma = sigma;} + discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } let injection_main c = elimOnConstrWithHoles (injClause None) false c @@ -161,7 +161,7 @@ END let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> - injection_main { it = Term.mkVar id,NoBindings; sigma = sigma; } + injection_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -201,7 +201,7 @@ END let onSomeWithHoles tac = function | None -> tac None - | Some c -> Tacticals.New.tclWITHHOLES false (tac (Some c.it)) c.sigma + | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) TACTIC EXTEND contradiction [ "contradiction" constr_with_bindings_opt(c) ] -> diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index 72c2679c06..1d2e497d51 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -11,4 +11,4 @@ val injHyp : Names.Id.t -> unit Proofview.tactic (* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) -val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Evd.sigma option -> unit Proofview.tactic +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index d96c8f98a2..16cafafeb8 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -2277,13 +2277,15 @@ let () = let lift f = (); fun ist gl x -> (project gl, f ist (pf_env gl) (project gl) x) let lifts f = (); fun ist gl x -> f ist (pf_env gl) (project gl) x -let interp_bindings' ist gl bl = - let (sigma, bl) = interp_bindings ist (pf_env gl) (project gl) bl in - (project gl, pack_sigma (sigma, bl)) - -let interp_constr_with_bindings' ist gl c = - let (sigma, c) = interp_constr_with_bindings ist (pf_env gl) (project gl) c in - (project gl, pack_sigma (sigma, c)) +let interp_bindings' ist gl bl = (project gl, { delayed = fun env sigma -> + let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in + Sigma.Unsafe.of_pair (bl, sigma) + }) + +let interp_constr_with_bindings' ist gl c = (project gl, { delayed = fun env sigma -> + let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in + Sigma.Unsafe.of_pair (c, sigma) + }) let () = Geninterp.register_interp0 wit_int_or_var (fun ist gl n -> project gl, interp_int_or_var ist n); diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index e181c8e14e..74714300c4 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -515,6 +515,14 @@ module New = struct in Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if + let tclDELAYEDWITHHOLES check x tac = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let Sigma (x, sigma, _) = x.Tacexpr.delayed env sigma in + tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) + end } + let tclTIMEOUT n t = Proofview.tclOR (Proofview.tclTIMEOUT n t) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 80e01a8d07..042f80fe82 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -219,6 +219,7 @@ module New : sig val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic + val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic -- cgit v1.2.3 From cbd815a289db52f58235f23f5afba3be49cc8eed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Dec 2015 13:54:18 +0100 Subject: Removing dead code. --- kernel/cemitcodes.ml | 4 ---- kernel/inductive.ml | 2 +- kernel/uGraph.ml | 6 +----- tactics/tacintern.ml | 3 +-- tactics/tacinterp.ml | 24 ------------------------ 5 files changed, 3 insertions(+), 36 deletions(-) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 5ba93eda05..61042ccc17 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -306,8 +306,6 @@ let init () = type emitcodes = string -let copy = String.copy - let length = String.length type to_patch = emitcodes * (patch list) * fv @@ -332,8 +330,6 @@ let subst_patch s (ri,pos) = let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv -let subst_pconstant s (kn, u) = (fst (subst_con_kn s kn), u) - type body_code = | BCdefined of to_patch | BCalias of Names.constant diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 632b4daeae..d0df5c7b38 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -151,7 +151,7 @@ let remember_subst u subst = (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) -let rec make_subst env = +let make_subst env = let rec make subst = function | (_,Some _,_)::sign, exp, args -> make subst (sign, exp, args) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 9e8ffbc7f2..925b2248d8 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -139,7 +139,6 @@ let rec repr g u = | Equiv v -> repr g v | Canonical arc -> arc -let get_prop_arc g = repr g Level.prop let get_set_arc g = repr g Level.set let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ @@ -155,7 +154,7 @@ let use_index g u = (* [safe_repr] is like [repr] but if the graph doesn't contain the searched universe, we add it. *) -let rec safe_repr g u = +let safe_repr g u = let rec safe_repr_rec entries u = match UMap.find u entries with | Equiv v -> safe_repr_rec entries v @@ -745,9 +744,6 @@ let check_constraints c g = (* Normalization *) -let lookup_level u g = - try Some (UMap.find u g) with Not_found -> None - (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output graph should be equivalent to the input graph from a logical point diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index ecce4a0ff3..23de87d7db 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -97,7 +97,6 @@ let intern_or_var f ist = function | ArgArg x -> ArgArg (f x) let intern_int_or_var = intern_or_var (fun (n : int) -> n) -let intern_id_or_var = intern_or_var (fun (id : Id.t) -> id) let intern_string_or_var = intern_or_var (fun (s : string) -> s) let intern_global_reference ist = function @@ -339,7 +338,7 @@ let intern_typed_pattern ist p = (* type it, so we remember the pattern as a glob_constr only *) (intern_constr_gen true false ist p,dummy_pat) -let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) = +let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let interp_ref r = try Inl (intern_evaluable ist r) with e when Logic.catchable_exception e -> diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 16cafafeb8..a0fa9b5f3e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -363,10 +363,6 @@ let interp_intro_pattern_naming_var loc ist env sigma id = try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) with Not_found -> IntroIdentifier id -let interp_hint_base ist s = - try try_interp_ltac_var coerce_to_hint_base ist None (dloc,Id.of_string s) - with Not_found -> s - let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> @@ -685,10 +681,6 @@ let interp_constr_list ist env sigma c = let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr -let interp_auto_lemmas ist env sigma lems = - let local_sigma, lems = interp_open_constr_list ist env sigma lems in - List.map (fun lem -> (local_sigma,lem)) lems - (* Interprets a type expression *) let pf_interp_type ist gl = interp_type ist (pf_env gl) (project gl) @@ -864,11 +856,6 @@ let interp_message ist l = Ftactic.List.map (interp_message_token ist) l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) -let interp_message ist l = - let open Ftactic in - Ftactic.List.map (interp_message_token ist) l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - let rec interp_intro_pattern ist env sigma = function | loc, IntroAction pat -> let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in @@ -977,19 +964,11 @@ let interp_constr_with_bindings ist env sigma (c,bl) = let sigma, c = interp_open_constr ist env sigma c in sigma, (c,bl) -let interp_constr_with_bindings_arg ist env sigma (keep,c) = - let sigma, c = interp_constr_with_bindings ist env sigma c in - sigma, (keep,c) - let interp_open_constr_with_bindings ist env sigma (c,bl) = let sigma, bl = interp_bindings ist env sigma bl in let sigma, c = interp_open_constr ist env sigma c in sigma, (c, bl) -let interp_open_constr_with_bindings_arg ist env sigma (keep,c) = - let sigma, c = interp_open_constr_with_bindings ist env sigma c in - sigma,(keep,c) - let loc_of_bindings = function | NoBindings -> Loc.ghost | ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) @@ -1128,9 +1107,6 @@ let mk_open_constr_value ist gl c = sigma, Value.of_constr c_interp let mk_hyp_value ist env sigma c = (mkVar (interp_hyp ist env sigma c)) -let mk_int_or_var_value ist c = in_gen (topwit wit_int) (interp_int_or_var ist c) - -let pack_sigma (sigma,c) = {it=c;sigma=sigma;} (* Interprets an l-tac expression into a value *) let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = -- cgit v1.2.3 From 1ec0928ebecc8fa51022b681d32665d4f010e0ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Dec 2015 19:27:52 +0100 Subject: Factorizing code for untyped constr evaluation. --- tactics/extratactics.ml4 | 20 ++++++-------------- tactics/tacinterp.ml | 35 +++++++++++++++++++++++------------ tactics/tacinterp.mli | 5 +++++ 3 files changed, 34 insertions(+), 26 deletions(-) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index dce7a18608..8a52675410 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -347,22 +347,14 @@ END (**********************************************************************) (* Refine *) -let refine_tac simple {Glob_term.closure=closure;term=term} = +let refine_tac ist simple c = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = Pretyping.all_no_fail_flags in - let tycon = Pretyping.OfType concl in - let lvar = { Pretyping.empty_lvar with - Pretyping.ltac_constrs = closure.Glob_term.typed; - Pretyping.ltac_uconstrs = closure.Glob_term.untyped; - Pretyping.ltac_idents = closure.Glob_term.idents; - } in - let update = { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = Pretyping.understand_ltac flags env sigma lvar tycon term in - Sigma.Unsafe.of_pair (c, sigma) - end } in + let expected_type = Pretyping.OfType concl in + let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in + let update = { run = fun sigma -> c.delayed env sigma } in let refine = Proofview.Refine.refine ~unsafe:false update in if simple then refine else refine <*> @@ -371,11 +363,11 @@ let refine_tac simple {Glob_term.closure=closure;term=term} = end } TACTIC EXTEND refine -| [ "refine" uconstr(c) ] -> [ refine_tac false c ] +| [ "refine" uconstr(c) ] -> [ refine_tac ist false c ] END TACTIC EXTEND simple_refine -| [ "simple" "refine" uconstr(c) ] -> [ refine_tac true c ] +| [ "simple" "refine" uconstr(c) ] -> [ refine_tac ist true c ] END (**********************************************************************) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index a0fa9b5f3e..0ac115d1d5 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -685,6 +685,24 @@ let interp_open_constr_list = let pf_interp_type ist gl = interp_type ist (pf_env gl) (project gl) +(* Fully evaluate an untyped constr *) +let type_uconstr ?(flags = constr_flags) + ?(expected_type = WithoutTypeConstraint) ist c = + { delayed = begin fun env sigma -> + let open Pretyping in + let { closure; term } = c in + let vars = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = ist.lfun; + } in + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = understand_ltac flags env sigma vars expected_type term in + Sigma.Unsafe.of_pair (c, sigma) + end } + + (* Interprets a reduction expression *) let interp_unfold ist env sigma (occs,qid) = (interp_occurrences ist occs,interp_evaluable ist env sigma qid) @@ -1404,19 +1422,12 @@ and interp_tacarg ist arg : Val.t Ftactic.t = end | TacPretype c -> Ftactic.enter begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let {closure;term} = interp_uconstr ist env c in - let vars = { - Pretyping.ltac_constrs = closure.typed; - Pretyping.ltac_uconstrs = closure.untyped; - Pretyping.ltac_idents = closure.idents; - Pretyping.ltac_genargs = ist.lfun; - } in - let (sigma,c_interp) = - Pretyping.understand_ltac constr_flags env sigma vars WithoutTypeConstraint term - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) + let c = interp_uconstr ist env c in + let Sigma (c, sigma, _) = (type_uconstr ist c).delayed env sigma in + let sigma = Sigma.to_evar_map sigma in + Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c)) end | TacNumgoals -> Ftactic.lift begin diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index c67aa31a9f..5b81da74a6 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -65,6 +65,11 @@ val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tac (** Interprets an expression that evaluates to a constr *) val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic +val type_uconstr : + ?flags:Pretyping.inference_flags -> + ?expected_type:Pretyping.typing_constraint -> + interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open + (** Interprets redexp arguments *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr -- cgit v1.2.3 From 28d4740736e5ef3b6f8547710dcf7e5b4d11cabd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 27 Dec 2015 19:57:14 +0100 Subject: Eradicating uses of open_constr in TACTIC EXTEND in favour of uconstr. --- plugins/funind/functional_principles_proofs.ml | 2 +- plugins/funind/recdef.ml | 2 +- tactics/auto.mli | 20 ++++---- tactics/eauto.ml4 | 34 +++++++++---- tactics/eauto.mli | 4 +- tactics/extratactics.ml4 | 68 ++++++++++++++------------ tactics/g_auto.ml4 | 38 +++++++------- tactics/hints.ml | 7 +++ tactics/hints.mli | 2 +- 9 files changed, 104 insertions(+), 73 deletions(-) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f57f12f667..1474f1e936 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1473,7 +1473,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [Evd.empty,Lazy.force refl_equal] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ) ) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 5a30da336e..10a145e036 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1335,7 +1335,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [Evd.empty,Lazy.force refl_equal] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ] ) diff --git a/tactics/auto.mli b/tactics/auto.mli index 1132478aac..eca592ad6b 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -44,24 +44,24 @@ val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr - "nocore" amongst the databases. *) val auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) val new_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database *) val full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database and doing delta *) val new_full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with default search depth and with all hint databases except the "v62" compatibility database *) @@ -69,19 +69,19 @@ val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) val gen_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic + int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) val h_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic + int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) val trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic val gen_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic val full_trivial : ?debug:Tacexpr.debug -> - open_constr list -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> unit Proofview.tactic val h_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 1943a4f1f2..fe10b92c36 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -64,6 +64,16 @@ let registered_e_assumption = (Tacmach.New.pf_ids_of_hyps gl)) end } +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + (************************************************************************) (* PROLOG tactic *) (************************************************************************) @@ -103,13 +113,19 @@ let out_term = function | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) let prolog_tac l n gl = - let l = List.map (fun x -> out_term (pf_apply (prepare_hint false (false,true)) gl x)) l in + let map c = + let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in + out_term c + in + let l = List.map map l in try (prolog l n gl) with UserError ("Refiner.tclFIRST",_) -> errorlabstrm "Prolog.prolog" (str "Prolog failed.") TACTIC EXTEND prolog -| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ Proofview.V82.tactic (prolog_tac l n) ] +| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> + [ Proofview.V82.tactic (prolog_tac (eval_uconstrs ist l) n) ] END open Auto @@ -214,7 +230,7 @@ type search_state = { dblist : hint_db list; localdb : hint_db list; prev : prev_search_state; - local_lemmas : Evd.open_constr list; + local_lemmas : Tacexpr.delayed_open_constr list; } and prev_search_state = (* for info eauto *) @@ -446,33 +462,33 @@ let wit_hintbases = G_auto.wit_hintbases TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (make_dimension n p) lems db) ] + [ Proofview.V82.tactic (gen_eauto (make_dimension n p) (eval_uconstrs ist lems) db) ] END TACTIC EXTEND new_eauto | [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ match db with - | None -> new_full_auto (make_depth n) lems - | Some l -> new_auto (make_depth n) lems l ] + | None -> new_full_auto (make_depth n) (eval_uconstrs ist lems) + | Some l -> new_auto (make_depth n) (eval_uconstrs ist lems) l ] END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) lems db) ] + [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) (eval_uconstrs ist lems) db) ] END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) lems db) ] + [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) (eval_uconstrs ist lems) db) ] END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (true, make_depth p) lems db) ] + [ Proofview.V82.tactic (gen_eauto (true, make_depth p) (eval_uconstrs ist lems) db) ] END let cons a l = a :: l diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 3d02081bfe..8e20793c46 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -21,12 +21,12 @@ val registered_e_assumption : unit Proofview.tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list -> +val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> tactic val eauto_with_bases : ?debug:Tacexpr.debug -> bool * int -> - open_constr list -> hint_db list -> Proof_type.tactic + Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic val autounfold : hint_db_name list -> Locus.clause -> tactic diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 8a52675410..a957a56242 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -31,34 +31,42 @@ DECLARE PLUGIN "extratactics" (* replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) -let replace_in_clause_maybe_by (sigma1,c1) c2 cl tac = - Tacticals.New.tclWITHHOLES false - (replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac)) - sigma1 - -let replace_term dir_opt (sigma,c) cl = - Tacticals.New.tclWITHHOLES false - (replace_term dir_opt c cl) - sigma +let with_delayed_uconstr ist c tac = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + let c = Tacinterp.type_uconstr ~flags ist c in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + +let replace_in_clause_maybe_by ist c1 c2 cl tac = + with_delayed_uconstr ist c1 + (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac)) + +let replace_term ist dir_opt c cl = + with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) TACTIC EXTEND replace - ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by c1 c2 cl tac ] + ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] END TACTIC EXTEND replace_term_left - [ "replace" "->" open_constr(c) clause(cl) ] - -> [ replace_term (Some true) c cl ] + [ "replace" "->" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some true) c cl ] END TACTIC EXTEND replace_term_right - [ "replace" "<-" open_constr(c) clause(cl) ] - -> [ replace_term (Some false) c cl ] + [ "replace" "<-" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some false) c cl ] END TACTIC EXTEND replace_term - [ "replace" open_constr(c) clause(cl) ] - -> [ replace_term None c cl ] + [ "replace" uconstr(c) clause(cl) ] + -> [ replace_term ist None c cl ] END let induction_arg_of_quantified_hyp = function @@ -243,22 +251,22 @@ END (**********************************************************************) (* Rewrite star *) -let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) = +let rewrite_star ist clause orient occs c (tac : glob_tactic_expr option) = let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in - Tacticals.New.tclWITHHOLES false - (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) sigma + with_delayed_uconstr ist c + (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) TACTIC EXTEND rewrite_star -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o Locus.AllOccurrences c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star None o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> - [ rewrite_star None o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist None o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> + [ rewrite_star ist None o Locus.AllOccurrences c tac ] END (**********************************************************************) diff --git a/tactics/g_auto.ml4 b/tactics/g_auto.ml4 index 7d35cfaab1..3a2cee9f72 100644 --- a/tactics/g_auto.ml4 +++ b/tactics/g_auto.ml4 @@ -26,51 +26,51 @@ ARGUMENT EXTEND hintbases | [ ] -> [ Some [] ] END -let pr_constr_coma_sequence prc _ _ = - prlist_with_sep pr_comma (fun (_,c) -> prc c) - -ARGUMENT EXTEND constr_coma_sequence - TYPED AS open_constr_list - PRINTED BY pr_constr_coma_sequence -| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] -| [ open_constr(c) ] -> [ [c] ] -END - -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c) +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + +let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) ARGUMENT EXTEND auto_using - TYPED AS open_constr_list + TYPED AS uconstr_list PRINTED BY pr_auto_using -| [ "using" constr_coma_sequence(l) ] -> [ l ] +| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] | [ ] -> [ [] ] END TACTIC EXTEND trivial | [ "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial lems db ] + [ Auto.h_trivial (eval_uconstrs ist lems) db ] END TACTIC EXTEND info_trivial | [ "info_trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Info lems db ] + [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] END TACTIC EXTEND debug_trivial | [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Debug lems db ] + [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] END TACTIC EXTEND auto | [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto n lems db ] + [ Auto.h_auto n (eval_uconstrs ist lems) db ] END TACTIC EXTEND info_auto | [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Info n lems db ] + [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] END TACTIC EXTEND debug_auto | [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Debug n lems db ] + [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] END diff --git a/tactics/hints.ml b/tactics/hints.ml index 6250886821..6d623f1c34 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -33,6 +33,7 @@ open Pfedit open Tacred open Printer open Vernacexpr +open Sigma.Notations (****************************************) (* General functions *) @@ -1184,6 +1185,12 @@ let add_hint_lemmas env sigma eapply lems hint_db = Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = + let map c = + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = c.delayed env sigma in + (Sigma.to_evar_map sigma, c) + in + let lems = List.map map lems in let sign = Environ.named_context env in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") diff --git a/tactics/hints.mli b/tactics/hints.mli index 3a0521f665..257598d188 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -214,7 +214,7 @@ val extern_intern_tac : Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list -- cgit v1.2.3 From cb2f6a95ee72edb956f419a24f8385c8ae7f96f4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Dec 2015 02:08:42 +0100 Subject: Removing the special status of open_constr generic argument. We also intepret it at toplevel as a true constr and push the resulting evarmap in the current state. --- grammar/argextend.ml4 | 1 - grammar/q_coqast.ml4 | 1 - interp/constrarg.ml | 3 ++- interp/constrarg.mli | 2 +- lib/genarg.ml | 7 +------ lib/genarg.mli | 1 - parsing/g_tactic.ml4 | 2 +- parsing/pcoq.mli | 2 +- printing/pptactic.ml | 9 ++++++--- tactics/tacintern.ml | 3 +-- tactics/tacinterp.ml | 14 +------------- tactics/tacsubst.ml | 4 +--- 12 files changed, 15 insertions(+), 34 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 87a0dfa984..f6c223b741 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -33,7 +33,6 @@ let rec make_wit loc = function | IdentArgType -> <:expr< Constrarg.wit_ident >> | VarArgType -> <:expr< Constrarg.wit_var >> | ConstrArgType -> <:expr< Constrarg.wit_constr >> - | OpenConstrArgType -> <:expr< Constrarg.wit_open_constr >> | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> | PairArgType (t1,t2) -> diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index fc08f0a492..494ec6ba29 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -225,7 +225,6 @@ let mlexpr_of_red_expr = function let rec mlexpr_of_argtype loc = function | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> - | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> diff --git a/interp/constrarg.ml b/interp/constrarg.ml index ab54b61977..44623f9c9a 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -49,7 +49,7 @@ let wit_constr_may_eval = let wit_uconstr = Genarg.make0 None "uconstr" -let wit_open_constr = unsafe_of_type OpenConstrArgType +let wit_open_constr = Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) None "open_constr" let wit_constr_with_bindings = Genarg.make0 None "constr_with_bindings" @@ -72,6 +72,7 @@ let () = register_name0 wit_tactic "Constrarg.wit_tactic"; register_name0 wit_sort "Constrarg.wit_sort"; register_name0 wit_uconstr "Constrarg.wit_uconstr"; + register_name0 wit_open_constr "Constrarg.wit_open_constr"; register_name0 wit_constr_may_eval "Constrarg.wit_constr_may_eval"; register_name0 wit_red_expr "Constrarg.wit_red_expr"; register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl"; diff --git a/interp/constrarg.mli b/interp/constrarg.mli index 052e4ec69b..0cc111e617 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -50,7 +50,7 @@ val wit_constr_may_eval : val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type val wit_open_constr : - (open_constr_expr, open_glob_constr, Evd.open_constr) genarg_type + (constr_expr, glob_constr_and_expr, constr) genarg_type val wit_constr_with_bindings : (constr_expr with_bindings, diff --git a/lib/genarg.ml b/lib/genarg.ml index 2b8e0c9fdd..6108c15555 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -61,7 +61,6 @@ type argument_type = | VarArgType (* Specific types *) | ConstrArgType - | OpenConstrArgType | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type @@ -71,7 +70,6 @@ let rec argument_type_eq arg1 arg2 = match arg1, arg2 with | IdentArgType, IdentArgType -> true | VarArgType, VarArgType -> true | ConstrArgType, ConstrArgType -> true -| OpenConstrArgType, OpenConstrArgType -> true | ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 | OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 | PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) -> @@ -83,7 +81,6 @@ let rec pr_argument_type = function | IdentArgType -> str "ident" | VarArgType -> str "var" | ConstrArgType -> str "constr" -| OpenConstrArgType -> str "open_constr" | ListArgType t -> pr_argument_type t ++ spc () ++ str "list" | OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" | PairArgType (t1, t2) -> @@ -210,14 +207,12 @@ let base_create n = Val.Base (Dyn.create n) let ident_T = base_create "ident" let genarg_T = base_create "genarg" let constr_T = base_create "constr" -let open_constr_T = base_create "open_constr" let rec val_tag = function | IdentArgType -> cast_tag ident_T | VarArgType -> cast_tag ident_T (** Must ensure that toplevel types of Var and Ident agree! *) | ConstrArgType -> cast_tag constr_T -| OpenConstrArgType -> cast_tag open_constr_T | ExtraArgType s -> cast_tag (String.Map.find s !arg0_map).dyn | ListArgType t -> cast_tag (Val.List (val_tag t)) | OptArgType t -> cast_tag (Val.Opt (val_tag t)) @@ -240,7 +235,7 @@ fun wit v -> match unquote wit with | IdentArgType | VarArgType | ConstrArgType -| OpenConstrArgType | ExtraArgType _ -> try_prj wit v +| ExtraArgType _ -> try_prj wit v | ListArgType t -> let Val.Dyn (tag, v) = v in begin match tag with diff --git a/lib/genarg.mli b/lib/genarg.mli index 0904960938..674ee97ae8 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -216,7 +216,6 @@ type argument_type = | VarArgType (** Specific types *) | ConstrArgType - | OpenConstrArgType | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 31125e37cf..1fe12ce3e0 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -231,7 +231,7 @@ GEXTEND Gram [ [ id = identref -> id ] ] ; open_constr: - [ [ c = constr -> ((),c) ] ] + [ [ c = constr -> c ] ] ; uconstr: [ [ c = constr -> c ] ] diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index fdba413854..592c879197 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -219,7 +219,7 @@ module Module : module Tactic : sig - val open_constr : open_constr_expr Gram.entry + val open_constr : constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry diff --git a/printing/pptactic.ml b/printing/pptactic.ml index b98738ce31..6e051a1fc0 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -270,7 +270,6 @@ module Make | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x) | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) - | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in @@ -301,7 +300,6 @@ module Make | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x) | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) - | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in @@ -331,7 +329,6 @@ module Make | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) | VarArgType -> pr_id (out_gen (topwit wit_var) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) - | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in @@ -1425,6 +1422,12 @@ let () = (fun (c,_) -> Printer.pr_glob_constr c) Printer.pr_closed_glob ; + Genprint.register_print0 + Constrarg.wit_open_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; Genprint.register_print0 Constrarg.wit_red_expr (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 23de87d7db..08d2d21a3f 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -727,8 +727,6 @@ and intern_genarg ist x = map_raw wit_var intern_hyp ist x | ConstrArgType -> map_raw wit_constr intern_constr ist x - | OpenConstrArgType -> - map_raw wit_open_constr (fun ist -> on_snd (intern_constr ist)) ist x | ListArgType _ -> let list_unpacker wit l = let map x = @@ -832,6 +830,7 @@ let () = Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_red_expr (lift intern_red_expr); Genintern.register_intern0 wit_bindings (lift intern_bindings); Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 0ac115d1d5..ff66628098 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1120,9 +1120,6 @@ let rec read_match_rule lfun ist env sigma = function (* misc *) -let mk_open_constr_value ist gl c = - let (sigma,c_interp) = pf_apply (interp_open_constr ist) gl c in - sigma, Value.of_constr c_interp let mk_hyp_value ist env sigma c = (mkVar (interp_hyp ist env sigma c)) @@ -1260,10 +1257,6 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (Genarg.out_gen (glbwit wit_ident) x))) | VarArgType -> Ftactic.return (Value.of_constr (mk_hyp_value ist env sigma (Genarg.out_gen (glbwit wit_var) x))) - | OpenConstrArgType -> - let (sigma,v) = - Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (Genarg.out_gen (glbwit wit_open_constr) x))) gl in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) | ListArgType VarArgType -> let wit = glbwit (wit_list wit_var) in let ans = List.map (mk_hyp_value ist env sigma) (Genarg.out_gen wit x) in @@ -1626,12 +1619,6 @@ and interp_genarg ist env sigma concl gl x = in evdref := sigma; in_gen (topwit wit_constr) c_interp - | OpenConstrArgType -> - let expected_type = WithoutTypeConstraint in - in_gen (topwit wit_open_constr) - (interp_open_constr ~expected_type - ist env !evdref - (snd (Genarg.out_gen (glbwit wit_open_constr) x))) | ListArgType ConstrArgType -> let (sigma,v) = interp_genarg_constr_list ist env !evdref x in evdref := sigma; @@ -2283,6 +2270,7 @@ let () = Geninterp.register_interp0 wit_tacvalue (fun ist gl c -> project gl, c); Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + Geninterp.register_interp0 wit_open_constr (lifts interp_open_constr); Geninterp.register_interp0 wit_bindings interp_bindings'; Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; Geninterp.register_interp0 wit_constr_may_eval (lifts interp_constr_may_eval); diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index fdf65292a1..2132e9a573 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -281,9 +281,6 @@ and subst_genarg subst (x:glob_generic_argument) = | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x) | ConstrArgType -> in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) - | OpenConstrArgType -> - in_gen (glbwit wit_open_constr) - ((),subst_glob_constr subst (snd (out_gen (glbwit wit_open_constr) x))) | ListArgType _ -> let list_unpacker wit l = let map x = @@ -322,6 +319,7 @@ let () = Genintern.register_subst0 wit_sort (fun _ v -> v); Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); Genintern.register_subst0 wit_red_expr subst_redexp; Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; Genintern.register_subst0 wit_bindings subst_bindings; -- cgit v1.2.3 From 9af1d5ae4dbed8557b5c715a65f2742c57641f52 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 22 Dec 2015 15:39:28 +0100 Subject: Implementing non-focussed generic arguments. Kind of enhances the situation of bug #4409. Now arguments can be interpreted globally or focussedly in a dynamic fashion because the interpretation function returns a Ftactic.t. The bug is not fixed yet because we should tweak the interpretation of tactic arguments. --- grammar/argextend.ml4 | 23 +++--- tactics/ftactic.ml | 6 ++ tactics/ftactic.mli | 8 ++ tactics/geninterp.ml | 10 +-- tactics/geninterp.mli | 3 +- tactics/tacinterp.ml | 202 +++++++++++++++++++++----------------------------- tactics/tacinterp.mli | 5 +- 7 files changed, 119 insertions(+), 138 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index f6c223b741..677daebfb3 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -182,17 +182,22 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = | None -> begin match globtyp with | Genarg.ExtraArgType s' when CString.equal s s' -> - <:expr< fun ist gl v -> (gl.Evd.sigma, v) >> + <:expr< fun ist v -> Ftactic.return v >> | _ -> - <:expr< fun ist gl x -> - let (sigma,a_interp) = - Tacinterp.interp_genarg ist - (Tacmach.pf_env gl) (Tacmach.project gl) (Tacmach.pf_concl gl) gl.Evd.it - (Genarg.in_gen $make_globwit loc globtyp$ x) - in - (sigma , Tacinterp.Value.cast $make_topwit loc globtyp$ a_interp)>> + <:expr< fun ist x -> + Ftactic.bind + (Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x)) + (fun v -> Ftactic.return (Tacinterp.Value.cast $make_topwit loc globtyp$ v)) >> end - | Some f -> <:expr< $lid:f$>> in + | Some f -> + (** Compatibility layer, TODO: remove me *) + <:expr< + let f = $lid:f$ in + fun ist v -> Ftactic.nf_enter (fun gl -> + let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in + Ftactic.bind (Ftactic.lift (Proofview.Unsafe.tclEVARS sigma)) (fun _ -> Ftactic.return v) + ) + >> in let subst = match h with | None -> begin match globtyp with diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml index a688b94879..f8437b5599 100644 --- a/tactics/ftactic.ml +++ b/tactics/ftactic.ml @@ -84,3 +84,9 @@ module Ftac = Monad.Make(Self) module List = Ftac.List let debug_prompt = Tactic_debug.debug_prompt + +module Notations = +struct + let (>>=) = bind + let (<*>) = fun m n -> bind m (fun () -> n) +end diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli index 4496499229..a20d8a9c3c 100644 --- a/tactics/ftactic.mli +++ b/tactics/ftactic.mli @@ -67,3 +67,11 @@ module List : Monad.ListS with type 'a t := 'a t val debug_prompt : int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t + +(** {5 Notations} *) + +module Notations : +sig + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (<*>) : unit t -> 'a t -> 'a t +end diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml index 3da1d542b7..dff87d3a82 100644 --- a/tactics/geninterp.ml +++ b/tactics/geninterp.ml @@ -15,8 +15,7 @@ type interp_sign = { lfun : Val.t Id.Map.t; extra : TacStore.t } -type ('glb, 'top) interp_fun = interp_sign -> - Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t module InterpObj = struct @@ -30,9 +29,10 @@ module Interp = Register(InterpObj) let interp = Interp.obj let register_interp0 = Interp.register0 -let generic_interp ist gl v = +let generic_interp ist v = + let open Ftactic.Notations in let unpacker wit v = - let (sigma, ans) = interp wit ist gl (glb v) in - (sigma, Val.Dyn (val_tag (topwit wit), ans)) + interp wit ist (glb v) >>= fun ans -> + Ftactic.return (Val.Dyn (val_tag (topwit wit), ans)) in unpack { unpacker; } v diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli index 472ff10901..34261c507c 100644 --- a/tactics/geninterp.mli +++ b/tactics/geninterp.mli @@ -17,8 +17,7 @@ type interp_sign = { lfun : Val.t Id.Map.t; extra : TacStore.t } -type ('glb, 'top) interp_fun = interp_sign -> - Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index ff66628098..5e5b2be243 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1123,6 +1123,15 @@ let rec read_match_rule lfun ist env sigma = function let mk_hyp_value ist env sigma c = (mkVar (interp_hyp ist env sigma c)) +let interp_focussed wit f v = + Ftactic.nf_enter begin fun gl -> + let v = Genarg.out_gen (glbwit wit) v in + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let v = in_gen (topwit wit) (f env sigma v) in + Ftactic.return v + end + (* Interprets an l-tac expression into a value *) let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = (* The name [appl] of applied top-level Ltac names is ignored in @@ -1239,14 +1248,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | ConstrArgType | ListArgType ConstrArgType | OptArgType _ | PairArgType _ -> (** generic handler *) - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let goal = Proofview.Goal.goal gl in - let (sigma, arg) = interp_genarg ist env sigma concl goal x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return arg) - end + interp_genarg ist x | _ as tag -> (** Special treatment. TODO: use generic handler *) Ftactic.nf_enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1280,9 +1282,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let tac = Genarg.out_gen (glbwit wit_tactic) x in val_interp ist tac else - let goal = Proofview.Goal.goal gl in - let (newsigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS newsigma) <*> return v) + Geninterp.generic_interp ist x | _ -> assert false end in @@ -1311,43 +1311,18 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,opn,l) when List.for_all global_genarg l -> - let trace = push_trace (loc,LtacMLCall tac) ist in - let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - (* spiwack: a special case for tactics (from TACTIC EXTEND) when - every argument can be interpreted without a - [Proofview.Goal.nf_enter]. *) - let tac = Tacenv.interp_ml_tactic opn in - (* dummy values, will be ignored *) - let env = Environ.empty_env in - let sigma = Evd.empty in - let concl = Term.mkRel (-1) in - let goal = Evar.unsafe_of_int (-1) in - (* /dummy values *) - let args = List.map (fun a -> snd(interp_genarg ist env sigma concl goal a)) l in - let l = List.map2 (print_top_val env) l args in - let name () = Pptactic.pr_extend_gen (fun x -> x) 0 opn l in - Proofview.Trace.name_tactic name - (catch_error_tac trace (tac args ist)) | TacML (loc,opn,l) -> + let open Ftactic.Notations in let trace = push_trace (loc,LtacMLCall tac) ist in let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let goal_sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl gl in - let goal = Proofview.Goal.goal gl in - let tac = Tacenv.interp_ml_tactic opn in - let (sigma,args) = - Evd.MonadR.List.map_right - (fun a sigma -> interp_genarg ist env sigma concl goal a) l goal_sigma - in - Proofview.Unsafe.tclEVARS sigma <*> - let l = List.map2 (print_top_val env) l args in + let tac = Tacenv.interp_ml_tactic opn in + let args = Ftactic.List.map_right (fun a -> interp_genarg ist a) l in + let tac args = + let l = List.map2 (print_top_val ()) l args in let name () = Pptactic.pr_extend_gen (fun x -> x) 0 opn l in - Proofview.Trace.name_tactic name - (catch_error_tac trace (tac args ist)) - end } + Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + in + Ftactic.run args tac and force_vrec ist v : Val.t Ftactic.t = let v = Value.normalize v in @@ -1381,12 +1356,7 @@ and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = and interp_tacarg ist arg : Val.t Ftactic.t = match arg with | TacGeneric arg -> - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let goal = Proofview.Goal.goal gl in - let (sigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} arg in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) - end + Geninterp.generic_interp ist arg | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> Ftactic.enter begin fun gl -> @@ -1595,93 +1565,79 @@ and interp_match_goal ist lz lr lmr = end (* Interprets extended tactic generic arguments *) -(* spiwack: interp_genarg has an argument [concl] for the case of - "casted open constr". And [gl] for [Geninterp]. I haven't changed - the interface for geninterp yet as it is used by ARGUMENT EXTEND - (in turn used by plugins). At the time I'm writing this comment - though, the only concerned plugins are the declarative mode (which - needs the [extra] field of goals to interprete rules) and ssreflect - (a handful of time). I believe we'd need to address "casted open - constr" and the declarative mode rules to provide a reasonable - interface. *) -and interp_genarg ist env sigma concl gl x = - let evdref = ref sigma in - let rec interp_genarg x = +and interp_genarg ist x : Val.t Ftactic.t = + let open Ftactic.Notations in match genarg_tag x with | IdentArgType -> - in_gen (topwit wit_ident) - (interp_ident ist env sigma (Genarg.out_gen (glbwit wit_ident) x)) + interp_focussed wit_ident (interp_ident ist) x | VarArgType -> - in_gen (topwit wit_var) (interp_hyp ist env sigma (Genarg.out_gen (glbwit wit_var) x)) + interp_focussed wit_var (interp_hyp ist) x | ConstrArgType -> - let (sigma,c_interp) = - interp_constr ist env !evdref (Genarg.out_gen (glbwit wit_constr) x) - in - evdref := sigma; - in_gen (topwit wit_constr) c_interp + Ftactic.nf_enter begin fun gl -> + let c = Genarg.out_gen (glbwit wit_constr) x in + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, c) = interp_constr ist env sigma c in + let c = in_gen (topwit wit_constr) c in + Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return c) + end | ListArgType ConstrArgType -> - let (sigma,v) = interp_genarg_constr_list ist env !evdref x in - evdref := sigma; - v - | ListArgType VarArgType -> interp_genarg_var_list ist env sigma x + interp_genarg_constr_list ist x + | ListArgType VarArgType -> + interp_genarg_var_list ist x | ListArgType _ -> let list_unpacker wit l = let map x = - let x = interp_genarg (Genarg.in_gen (glbwit wit) x) in - Value.cast (topwit wit) x + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Value.cast (topwit wit) x) in - Value.of_list (val_tag wit) (List.map map (glb l)) + Ftactic.List.map map (glb l) >>= fun l -> + Ftactic.return (Value.of_list (val_tag wit) l) in list_unpack { list_unpacker } x | OptArgType _ -> let opt_unpacker wit o = match glb o with - | None -> Value.of_option (val_tag wit) None + | None -> Ftactic.return (Value.of_option (val_tag wit) None) | Some x -> - let x = interp_genarg (Genarg.in_gen (glbwit wit) x) in + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> let x = Value.cast (topwit wit) x in - Value.of_option (val_tag wit) (Some x) + Ftactic.return (Value.of_option (val_tag wit) (Some x)) in opt_unpack { opt_unpacker } x | PairArgType _ -> let pair_unpacker wit1 wit2 o = let (p, q) = glb o in - let p = interp_genarg (Genarg.in_gen (glbwit wit1) p) in - let q = interp_genarg (Genarg.in_gen (glbwit wit2) q) in + interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> + interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> let p = Value.cast (topwit wit1) p in let q = Value.cast (topwit wit2) q in - Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q)) + Ftactic.return (Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q))) in pair_unpack { pair_unpacker } x - | ExtraArgType s -> - let (sigma,v) = Geninterp.generic_interp ist { Evd.it=gl;sigma=(!evdref) } x in - evdref:=sigma; - v - in - let v = interp_genarg x in - !evdref , v - + | ExtraArgType _ -> + Geninterp.generic_interp ist x (** returns [true] for genargs which have the same meaning independently of goals. *) -and global_genarg = - let rec global_tag = function - | ExtraArgType "int_or_var" -> true (** FIXME *) - | ListArgType t | OptArgType t -> global_tag t - | PairArgType (t1,t2) -> global_tag t1 && global_tag t2 - | _ -> false - in - fun x -> global_tag (genarg_tag x) - -and interp_genarg_constr_list ist env sigma x = +and interp_genarg_constr_list ist x = + Ftactic.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in - sigma , Value.of_list (val_tag wit_constr) lc + let lc = Value.of_list (val_tag wit_constr) lc in + Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return lc) + end -and interp_genarg_var_list ist env sigma x = +and interp_genarg_var_list ist x = + Ftactic.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in - Value.of_list (val_tag wit_var) lc + Ftactic.return (Value.of_list (val_tag wit_var) lc) + end (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : constr Ftactic.t = @@ -2226,7 +2182,7 @@ let hide_interp global t ot = let def_intern ist x = (ist, x) let def_subst _ x = x -let def_interp ist gl x = (project gl, x) +let def_interp ist x = Ftactic.return x let declare_uniform t = Genintern.register_intern0 t def_intern; @@ -2248,26 +2204,36 @@ let () = let () = declare_uniform wit_pre_ident -let lift f = (); fun ist gl x -> (project gl, f ist (pf_env gl) (project gl) x) -let lifts f = (); fun ist gl x -> f ist (pf_env gl) (project gl) x +let lift f = (); fun ist x -> Ftactic.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Ftactic.return (f ist env sigma x) +end + +let lifts f = (); fun ist x -> Ftactic.nf_enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, v) = f ist env sigma x in + Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) +end -let interp_bindings' ist gl bl = (project gl, { delayed = fun env sigma -> +let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in Sigma.Unsafe.of_pair (bl, sigma) - }) + } -let interp_constr_with_bindings' ist gl c = (project gl, { delayed = fun env sigma -> +let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in Sigma.Unsafe.of_pair (c, sigma) - }) + } let () = - Geninterp.register_interp0 wit_int_or_var (fun ist gl n -> project gl, interp_int_or_var ist n); + Geninterp.register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); Geninterp.register_interp0 wit_ref (lift interp_reference); Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); - Geninterp.register_interp0 wit_tacvalue (fun ist gl c -> project gl, c); + Geninterp.register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); Geninterp.register_interp0 wit_open_constr (lifts interp_open_constr); @@ -2277,16 +2243,16 @@ let () = () let () = - let interp ist gl tac = + let interp ist tac = let f = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - (project gl, TacArg (dloc, TacGeneric (Genarg.in_gen (glbwit wit_tacvalue) f))) + Ftactic.return (TacArg (dloc, TacGeneric (Genarg.in_gen (glbwit wit_tacvalue) f))) in Geninterp.register_interp0 wit_tactic interp let () = - Geninterp.register_interp0 wit_uconstr (fun ist gl c -> - project gl , interp_uconstr ist (pf_env gl) c - ) + Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter begin fun gl -> + Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) + end) (***************************************************************************) (* Other entry points *) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 5b81da74a6..47a16a3bc0 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -54,10 +54,7 @@ val get_debug : unit -> debug_info (** Adds an interpretation function for extra generic arguments *) -(* spiwack: the [Term.constr] argument is the conclusion of the goal, - for "casted open constr" *) -val interp_genarg : interp_sign -> Environ.env -> Evd.evar_map -> Term.constr -> Goal.goal -> - glob_generic_argument -> Evd.evar_map * Value.t +val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t (** Interprets any expression *) val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic -- cgit v1.2.3 From a4cc4ea007b074009bea485e75f7efef3d4d25f3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Dec 2015 15:42:16 +0100 Subject: Removing unused parsing entries. --- parsing/g_tactic.ml4 | 9 --------- 1 file changed, 9 deletions(-) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 1fe12ce3e0..a7b05dd5eb 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -453,15 +453,6 @@ GEXTEND Gram [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] ; - hintbases: - [ [ "with"; "*" -> None - | "with"; l = LIST1 [ x = IDENT -> x] -> Some l - | -> Some [] ] ] - ; - auto_using: - [ [ "using"; l = LIST1 constr SEP "," -> l - | -> [] ] ] - ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; -- cgit v1.2.3 From b2eaecf0e748e3c286e1ef337f72cee6d3475162 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Dec 2015 02:48:45 +0100 Subject: Fixing bug #4462: unshelve: Anomaly: Uncaught exception Not_found. The rewrite tactic was causing an evar leak because of the use of the Evd.remove primitive. This function did not modify the future goals of the evarmap to remove the considered evar and thus maintained dangling evars in there, causing the anomaly. --- pretyping/evd.ml | 7 ++++++- test-suite/bugs/closed/4462.v | 7 +++++++ 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4462.v diff --git a/pretyping/evd.ml b/pretyping/evd.ml index c9b9f34414..8edc7a17c6 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -658,7 +658,12 @@ let add d e i = match i.evar_body with let remove d e = let undf_evars = EvMap.remove e d.undf_evars in let defn_evars = EvMap.remove e d.defn_evars in - { d with undf_evars; defn_evars; } + let principal_future_goal = match d.principal_future_goal with + | None -> None + | Some e' -> if Evar.equal e e' then None else d.principal_future_goal + in + let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in + { d with undf_evars; defn_evars; principal_future_goal; future_goals } let find d e = try EvMap.find e d.undf_evars diff --git a/test-suite/bugs/closed/4462.v b/test-suite/bugs/closed/4462.v new file mode 100644 index 0000000000..c680518c6a --- /dev/null +++ b/test-suite/bugs/closed/4462.v @@ -0,0 +1,7 @@ +Variables P Q : Prop. +Axiom pqrw : P <-> Q. + +Require Setoid. + +Goal P -> Q. +unshelve (rewrite pqrw). -- cgit v1.2.3 From 203b0eaac832af3b62e484c1aef89a02ffe8e29b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Dec 2015 18:31:17 +0100 Subject: External tactics and notations now accept any tactic argument. This commit has deep consequences in term of tactic evaluation, as it allows to pass any tac_arg to ML and alias tactics rather than mere generic arguments. This makes the evaluation much more uniform, and in particular it removes the special evaluation function for notations. This last point may break some notations out there unluckily. I had to treat in an ad-hoc way the tactic(...) entry of tactic notations because it is actually not interpreted as a generic argument but rather as a proper tactic expression instead. There is for now no syntax to pass any tactic argument to a given ML or notation tactic, but this should come soon. Also fixes bug #3849 en passant. --- intf/tacexpr.mli | 4 +-- parsing/egramcoq.ml | 22 +++++++++++++-- plugins/setoid_ring/newring.ml | 6 ++-- printing/pptactic.ml | 43 ++++++++++++++++++++--------- printing/pptacticsig.mli | 15 ++++------ tactics/tacintern.ml | 6 ++-- tactics/tacinterp.ml | 62 ++++-------------------------------------- tactics/tacsubst.ml | 6 ++-- tactics/tauto.ml4 | 2 +- test-suite/bugs/closed/3849.v | 8 ++++++ test-suite/bugs/opened/3849.v | 8 ------ toplevel/metasyntax.ml | 1 + 12 files changed, 83 insertions(+), 100 deletions(-) create mode 100644 test-suite/bugs/closed/3849.v delete mode 100644 test-suite/bugs/opened/3849.v diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index aa1088c9ea..6d10ef9d51 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -292,9 +292,9 @@ and 'a gen_tactic_expr = | TacFun of 'a gen_tactic_fun_ast | TacArg of 'a gen_tactic_arg located (* For ML extensions *) - | TacML of Loc.t * ml_tactic_entry * 'l generic_argument list + | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list (* For syntax extensions *) - | TacAlias of Loc.t * KerName.t * (Id.t * 'l generic_argument) list + | TacAlias of Loc.t * KerName.t * (Id.t * 'a gen_tactic_arg) list constraint 'a = < term:'t; diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 84736f8aba..2bc5b0f83f 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -257,7 +257,8 @@ let add_ml_tactic_entry name prods = let mkact i loc l : raw_tactic_expr = let open Tacexpr in let entry = { mltac_name = name; mltac_index = i } in - TacML (loc, entry, List.map snd l) + let map (_, arg) = TacGeneric arg in + TacML (loc, entry, List.map map l) in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in synchronize_level_positions (); @@ -274,7 +275,24 @@ let head_is_ident tg = match tg.tacgram_prods with let add_tactic_entry kn tg = let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = (TacAlias (loc,kn,l):raw_tactic_expr) in + let mkact loc l = + let filter = function + | GramTerminal _ -> None + | GramNonTerminal (_, t, _, None) -> None + | GramNonTerminal (_, t, _, Some _) -> Some (Genarg.unquote t) + in + let types = List.map_filter filter tg.tacgram_prods in + let map (id, arg) t = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Constrarg.wit_tactic in + if Genarg.argument_type_eq t (Genarg.unquote wit) then + (id, Tacexp (Genarg.out_gen wit arg)) + else + (id, TacGeneric arg) + in + let l = List.map2 map l types in + (TacAlias (loc,kn,l):raw_tactic_expr) + in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then error "Notation for simple tactic must start with an identifier." diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index d596cf6fb8..88c8465b1b 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -137,8 +137,8 @@ let closed_term_ast l = let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in TacFun([Some(Id.of_string"t")], TacML(Loc.ghost,tacname, - [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None); - Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l])) + [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); + TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)])) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) @@ -228,7 +228,7 @@ let exec_tactic env evd n f args = (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in - let get_res = TacML (Loc.ghost, get_res, [n]) in + let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 6e051a1fc0..4cb7e9fb38 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -371,10 +371,11 @@ module Make in pr_sequence (fun x -> x) l - let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let pr_extend_gen check pr_gen lev { mltac_name = s; mltac_index = i } l = try let pp_rules = Hashtbl.find prtac_tab s in let pp = pp_rules.(i) in + let () = if not (List.for_all2eq check pp.pptac_args l) then raise Not_found in let (lev', pl) = pp.pptac_prods in let p = pr_tacarg_using_rule pr_gen (pl,l) in if lev' > lev then surround p else p @@ -389,28 +390,35 @@ module Make in str "<" ++ name ++ str ">" ++ args - let pr_alias_gen pr_gen lev key l = + let pr_alias_gen check pr_gen lev key l = try let pp = KNmap.find key !prnotation_tab in let (lev', pl) = pp.pptac_prods in + let () = if not (List.for_all2eq check pp.pptac_args l) then raise Not_found in let p = pr_tacarg_using_rule pr_gen (pl, l) in if lev' > lev then surround p else p with Not_found -> KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" + let check_type t arg = match arg with + | TacGeneric arg -> argument_type_eq t (genarg_tag arg) + | _ -> false + + let unwrap_gen f = function TacGeneric x -> f x | _ -> assert false + let pr_raw_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference) + pr_extend_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) let pr_glob_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_glb_generic_rec prc prlc prtac prpat) + pr_extend_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) let pr_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_top_generic_rec prc prlc prtac prpat) + pr_extend_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) let pr_raw_alias prc prlc prtac prpat = - pr_alias_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference) + pr_alias_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) let pr_glob_alias prc prlc prtac prpat = - pr_alias_gen (pr_glb_generic_rec prc prlc prtac prpat) + pr_alias_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) let pr_alias prc prlc prtac prpat = - pr_alias_gen (pr_top_generic_rec prc prlc prtac prpat) + pr_alias_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) (**********************************************************************) (* The tactic printer *) @@ -716,8 +724,8 @@ module Make pr_reference : 'ref -> std_ppcmds; pr_name : 'nam -> std_ppcmds; pr_generic : 'lev generic_argument -> std_ppcmds; - pr_extend : int -> ml_tactic_entry -> 'lev generic_argument list -> std_ppcmds; - pr_alias : int -> KerName.t -> 'lev generic_argument list -> std_ppcmds; + pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds; + pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds; } constraint 'a = < @@ -1352,9 +1360,18 @@ module Make (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) - let pr_extend env = pr_extend_rec - (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - (pr_glob_tactic_level env) pr_constr_pattern + let check_val_type t arg = + let t = Genarg.val_tag (Obj.magic t) in (** FIXME *) + let Val.Dyn (t', _) = arg in + match Genarg.Val.eq t t' with + | None -> false + | Some _ -> true + + let pr_alias pr lev key args = + pr_alias_gen check_val_type pr lev key args + + let pr_extend pr lev ml args = + pr_extend_gen check_val_type pr lev ml args let pr_tactic env = pr_tactic_level env ltop diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index d154e0b663..01f240f6b8 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -40,19 +40,16 @@ module type Pp = sig val pr_top_generic : env -> tlevel generic_argument -> std_ppcmds val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_generic_argument list -> std_ppcmds + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_generic_argument list -> std_ppcmds + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds - val pr_extend : env -> int -> - ml_tactic_entry -> typed_generic_argument list -> std_ppcmds + val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds - val pr_extend_gen : - ('a -> std_ppcmds) -> int -> ml_tactic_entry -> 'a list -> std_ppcmds - - val pr_alias_gen : ('a -> std_ppcmds) -> - int -> Names.KerName.t -> 'a list -> std_ppcmds + val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 08d2d21a3f..93d64f686d 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -656,11 +656,11 @@ and intern_tactic_seq onlytac ist = function (* For extensions *) | TacAlias (loc,s,l) -> - let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in + let l = List.map (fun (id,a) -> (id,intern_tacarg !strict_check false ist a)) l in ist.ltacvars, TacAlias (loc,s,l) | TacML (loc,opn,l) -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_genarg ist) l) + ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with @@ -700,7 +700,7 @@ and intern_tacarg strict onlytac ist = function | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (intern_tactic onlytac ist t) | TacGeneric arg -> - let (_, arg) = Genintern.generic_intern ist arg in + let arg = intern_genarg ist arg in TacGeneric arg (* Reads the rules of a Match Context or a Match *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 5e5b2be243..1596406c9a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -156,12 +156,7 @@ module Value = struct end -let print_top_val env arg v = - let unpacker wit cst = - try val_cast (topwit wit) v; mt () - with CastError _ -> mt () - in - unpack { unpacker } arg +let print_top_val env v = mt () (** FIXME *) let dloc = Loc.ghost @@ -1244,51 +1239,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (* For extensions *) | TacAlias (loc,s,l) -> let body = Tacenv.interp_alias s in - let rec f x = match genarg_tag x with - | ConstrArgType - | ListArgType ConstrArgType - | OptArgType _ | PairArgType _ -> (** generic handler *) - interp_genarg ist x - | _ as tag -> (** Special treatment. TODO: use generic handler *) - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - match tag with - | IdentArgType -> - Ftactic.return (value_of_ident (interp_ident ist env sigma - (Genarg.out_gen (glbwit wit_ident) x))) - | VarArgType -> - Ftactic.return (Value.of_constr (mk_hyp_value ist env sigma (Genarg.out_gen (glbwit wit_var) x))) - | ListArgType VarArgType -> - let wit = glbwit (wit_list wit_var) in - let ans = List.map (mk_hyp_value ist env sigma) (Genarg.out_gen wit x) in - Ftactic.return (Value.of_list (val_tag wit_constr) ans) - | ListArgType IdentArgType -> - let wit = glbwit (wit_list wit_ident) in - let mk_ident x = intro_pattern_of_ident (interp_ident ist env sigma x) in - let ans = List.map mk_ident (Genarg.out_gen wit x) in - Ftactic.return (Value.of_list (val_tag wit_intro_pattern) ans) - | ListArgType t -> - let open Ftactic in - list_unpack { list_unpacker = fun wit l -> - let map x = f (Genarg.in_gen (glbwit wit) x) in - Ftactic.List.map map (glb l) >>= fun l -> - let l = CList.map (fun x -> Value.cast (topwit wit) x) l in - Ftactic.return (Value.of_list (val_tag wit) l) - } x - | ExtraArgType _ -> - (** Special treatment of tactics *) - if Genarg.has_type x (glbwit wit_tactic) then - let tac = Genarg.out_gen (glbwit wit_tactic) x in - val_interp ist tac - else - Geninterp.generic_interp ist x - | _ -> assert false - end - in let (>>=) = Ftactic.bind in let interp_vars = - Ftactic.List.map (fun (x,v) -> f v >>= fun v -> Ftactic.return (x,v)) l + Ftactic.List.map (fun (x,v) -> interp_tacarg ist v >>= fun v -> Ftactic.return (x,v)) l in let addvar (x, v) accu = Id.Map.add x v accu in let tac l = @@ -1302,8 +1255,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> - let l = List.map2 (fun (_, g) (_, t) -> print_top_val env g t) l lr in - let name () = Pptactic.pr_alias_gen (fun x -> x) 0 s l in + let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s (List.map snd lr) in Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, @@ -1316,10 +1268,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let trace = push_trace (loc,LtacMLCall tac) ist in let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in - let args = Ftactic.List.map_right (fun a -> interp_genarg ist a) l in + let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = - let l = List.map2 (print_top_val ()) l args in - let name () = Pptactic.pr_extend_gen (fun x -> x) 0 opn l in + let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) in Ftactic.run args tac @@ -1355,8 +1306,7 @@ and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = and interp_tacarg ist arg : Val.t Ftactic.t = match arg with - | TacGeneric arg -> - Geninterp.generic_interp ist arg + | TacGeneric arg -> interp_genarg ist arg | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> Ftactic.enter begin fun gl -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 2132e9a573..45b2d317c2 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -245,8 +245,8 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with (* For extensions *) | TacAlias (_,s,l) -> let s = subst_kn subst s in - TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l) - | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_genarg subst) l) + TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_tacarg subst a)) l) + | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) @@ -261,7 +261,7 @@ and subst_tacarg subst = function | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (subst_tactic subst t) - | TacGeneric arg -> TacGeneric (Genintern.generic_substitute subst arg) + | TacGeneric arg -> TacGeneric (subst_genarg subst arg) (* Reads the rules of a Match Context or a Match *) and subst_match_rule subst = function diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index d84f471163..f0805f7d08 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -210,7 +210,7 @@ let constructor i = (** Take care of the index: this is the second entry in constructor. *) let name = { Tacexpr.mltac_name = name; mltac_index = 1 } in let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in - Tacexpr.TacML (Loc.ghost, name, [i]) + Tacexpr.TacML (Loc.ghost, name, [TacGeneric i]) let is_disj _ ist = let flags = assoc_flags ist in diff --git a/test-suite/bugs/closed/3849.v b/test-suite/bugs/closed/3849.v new file mode 100644 index 0000000000..a8dc3af9cf --- /dev/null +++ b/test-suite/bugs/closed/3849.v @@ -0,0 +1,8 @@ +Tactic Notation "foo" hyp_list(hs) := clear hs. + +Tactic Notation "bar" hyp_list(hs) := foo hs. + +Goal True. +do 5 pose proof 0 as ?n0. +foo n1 n2. +bar n3 n4. diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/opened/3849.v deleted file mode 100644 index 5290054a06..0000000000 --- a/test-suite/bugs/opened/3849.v +++ /dev/null @@ -1,8 +0,0 @@ -Tactic Notation "foo" hyp_list(hs) := clear hs. - -Tactic Notation "bar" hyp_list(hs) := foo hs. - -Goal True. -do 5 pose proof 0 as ?n0. -foo n1 n2. -Fail bar n3 n4. diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 7714cc8108..0f96c2b4af 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -171,6 +171,7 @@ let extend_atomic_tactic name entries = | None -> () | Some args -> let open Tacexpr in + let args = List.map (fun a -> TacGeneric a) args in let entry = { mltac_name = name; mltac_index = i } in let body = TacML (Loc.ghost, entry, args) in Tacenv.register_ltac false false (Names.Id.of_string id) body -- cgit v1.2.3 From 19e2576c979c57ad0827f6a4364713930e0c6d4f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 30 Dec 2015 09:12:39 +0100 Subject: Simplifying code of fourier. --- plugins/fourier/fourierR.ml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index e5c9b27075..b1f642c1d2 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -413,13 +413,6 @@ let tac_zero_infeq_false gl (n,d) = (tac_zero_inf_pos gl (-n,d))) ;; -let create_meta () = mkMeta(Evarutil.new_meta());; - -let my_cut c gl= - let concl = pf_concl gl in - apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl -;; - let exact = exact_check;; let tac_use h = @@ -587,7 +580,7 @@ let rec fourier () = then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in - tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq)) + tac:=(Tacticals.New.tclTHENS (cut ineq) [Tacticals.New.tclTHEN (change_concl (mkAppL [| get coq_not; ineq|] )) -- cgit v1.2.3 From 74ba1999baa08a283c1743c22692bc575b40a0b9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 3 Aug 2015 15:18:58 +0200 Subject: Taking into account generated typing constraints in tactic "generalize". --- tactics/tactics.ml | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index c8a9d7384b..d90deb38dc 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2535,18 +2535,19 @@ let generalized_name c t ids cl = function [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] but only those at [occs] in [T] *) -let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) = +let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in - let cl',evd' = subst_closed_term_occ env evd (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in + let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t ids cl' na in - mkProd_or_LetIn (na,b,t) cl', evd' + mkProd_or_LetIn (na,b,t) cl', sigma' -let generalize_goal gl i ((occs,c,b),na as o) cl = - let t = Tacmach.pf_unsafe_type_of gl c in +let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let env = Tacmach.pf_env gl in - generalize_goal_gen env (Tacmach.pf_ids_of_hyps gl) i o t cl + let ids = Tacmach.pf_ids_of_hyps gl in + let sigma, t = Typing.type_of env sigma c in + generalize_goal_gen env sigma ids i o t cl let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in @@ -2603,13 +2604,14 @@ let new_generalize_gen_let lconstr = let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in - let (newcl, sigma), args = + let newcl, sigma, args = List.fold_right_i - (fun i ((_,c,b),_ as o) (cl, args) -> - let t = Tacmach.New.pf_unsafe_type_of gl c in + (fun i ((_,c,b),_ as o) (cl, sigma, args) -> + let sigma, t = Typing.type_of env sigma c in let args = if Option.is_empty b then c :: args else args in - generalize_goal_gen env ids i o t cl, args) - 0 lconstr ((concl, sigma), []) + let cl, sigma = generalize_goal_gen env sigma ids i o t cl in + (cl, sigma, args)) + 0 lconstr (concl, sigma, []) in let tac = Proofview.Refine.refine { run = begin fun sigma -> -- cgit v1.2.3 From 37ab457263e980aa49e681eceb3eb382ef8b36e3 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 24 Oct 2015 17:53:30 +0200 Subject: Moving apply_type to new proof engine. Note that code depending on apply_type might now have to ensure that typing constraints that were possibly generated by apply_type are now taken into account in advance. --- tactics/tactics.ml | 21 +++++++++++++++------ tactics/tactics.mli | 2 +- 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d90deb38dc..6d20bc3cdb 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1918,8 +1918,17 @@ let keep hyps = and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], this generalizes [hyps |- goal] into [hyps |- T] *) -let apply_type hdcty argl gl = - refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl +let apply_type newcl args = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let store = Proofview.Goal.extra gl in + Proofview.Refine.refine { run = begin fun sigma -> + let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in + let Sigma (ev, sigma, p) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (applist (ev, args), sigma, p) + end } + end } (* Given a context [hyps] with domain [x1..xn], possibly with let-ins, and well-typed in the current goal, [bring_hyps hyps] generalizes @@ -2582,7 +2591,7 @@ let generalize_dep ?(with_let=false) c gl = let args = instance_from_named_context to_quantify_rev in tclTHENLIST [tclEVARS evd; - apply_type cl'' (if Option.is_empty body then c::args else args); + Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args)); thin (List.rev tothin')] gl @@ -2592,9 +2601,9 @@ let generalize_gen_let lconstr gl = List.fold_right_i (generalize_goal gl) 0 lconstr (Tacmach.pf_concl gl,Tacmach.project gl) in - tclTHEN (tclEVARS evd) + Proofview.V82.of_tactic (Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> - if Option.is_empty b then Some c else None) lconstr)) gl + if Option.is_empty b then Some c else None) lconstr))) gl let new_generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -3864,7 +3873,7 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ (* Generalize dependent hyps (but not args) *) - if deps = [] then Proofview.tclUNIT () else Proofview.V82.tactic (apply_type tmpcl deps_cstr); + if deps = [] then Proofview.tclUNIT () else apply_type tmpcl deps_cstr; (* side-conditions in elim (resp case) schemes come last (resp first) *) induct_tac elim; Proofview.V82.tactic (tclMAP expand_hyp toclear) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index c966adb801..098212048f 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -179,7 +179,7 @@ val revert : Id.t list -> unit Proofview.tactic (** {6 Resolution tactics. } *) -val apply_type : constr -> constr list -> tactic +val apply_type : constr -> constr list -> unit Proofview.tactic val bring_hyps : named_context -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic -- cgit v1.2.3 From d3bc575c498ae09ad1003405d17a9d5cfbcf3cbf Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 31 Dec 2015 17:00:42 +0100 Subject: Do not dump a glob reference when its location is ghost. (Fix bug #4469) This patch also causes the code to finish a bit faster in the NoGlob case by not preparing a string for dump_string. It also optimizes Dumpglob.is_ghost by only checking whether the end position is zero. Note that no ghost locations were part of the glob files of the standard library before the patch. Note also that the html documentation of the standard library is bitwise identical before and after the patch. --- interp/dumpglob.ml | 7 +++++-- lib/loc.ml | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index c18ceecaba..c7d3da653c 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -139,12 +139,15 @@ let interval loc = loc1, loc2-1 let dump_ref loc filepath modpath ident ty = - if !glob_output = Feedback then + match !glob_output with + | Feedback -> Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) - else + | NoGlob -> () + | _ when not (Loc.is_ghost loc) -> let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el filepath modpath ident ty) + | _ -> () let dump_reference loc modpath ident ty = let filepath = Names.DirPath.to_string (Lib.library_dp ()) in diff --git a/lib/loc.ml b/lib/loc.ml index b62677d484..9043bee075 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -31,7 +31,7 @@ let ghost = { fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = 0; ep = 0; } -let is_ghost loc = Pervasives.(=) loc ghost (** FIXME *) +let is_ghost loc = loc.ep = 0 let merge loc1 loc2 = if loc1.bp < loc2.bp then -- cgit v1.2.3 From 1a8a8db7a9e4eb5ab56cd192411529661a4972c7 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 23 Dec 2015 14:27:13 +0100 Subject: Remove Library.mem, which is pointless since 8.5. --- library/library.ml | 7 ------- library/library.mli | 3 --- 2 files changed, 10 deletions(-) diff --git a/library/library.ml b/library/library.ml index 7aaa8b2e6a..db95213fe9 100644 --- a/library/library.ml +++ b/library/library.ml @@ -769,13 +769,6 @@ let save_library_raw f sum lib univs proofs = System.marshal_out_segment f' ch (proofs : seg_proofs); close_out ch -(************************************************************************) -(*s Display the memory use of a library. *) - -open Printf - -let mem s = Pp.mt () - module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) diff --git a/library/library.mli b/library/library.mli index d5e610dd67..71aefdbd86 100644 --- a/library/library.mli +++ b/library/library.mli @@ -82,8 +82,5 @@ val locate_qualified_library : *) -(** {6 Statistics: display the memory use of a library. } *) -val mem : DirPath.t -> Pp.std_ppcmds - (** {6 Native compiler. } *) val native_name_from_filename : string -> string -- cgit v1.2.3 From 1a157442dff4bfa127af467c49280e79889acde7 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 26 Dec 2015 10:07:19 +0100 Subject: Do not compose List.length with List.filter. --- interp/constrintern.ml | 2 +- lib/cList.ml | 7 +++++++ lib/cList.mli | 2 ++ pretyping/recordops.ml | 2 +- pretyping/typeclasses.ml | 2 +- printing/prettyp.ml | 2 +- 6 files changed, 13 insertions(+), 4 deletions(-) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 8a86d30220..d4cb797759 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1386,7 +1386,7 @@ let internalize globalenv env allow_patvar lvar c = let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in - let n' = Option.map (fun _ -> List.length (List.filter (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore)) n in + let n' = Option.map (fun _ -> List.count (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, (env',rbl) = diff --git a/lib/cList.ml b/lib/cList.ml index 0ac372d8d8..72f892a09d 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -48,6 +48,7 @@ sig val filteri : (int -> 'a -> bool) -> 'a list -> 'a list val smartfilter : ('a -> bool) -> 'a list -> 'a list + val count : ('a -> bool) -> 'a list -> int val index : 'a eq -> 'a -> 'a list -> int val index0 : 'a eq -> 'a -> 'a list -> int val iteri : (int -> 'a -> unit) -> 'a list -> unit @@ -375,6 +376,12 @@ let rec smartfilter f l = match l with else h :: tl' else tl' +let count f l = + let rec aux acc = function + | [] -> acc + | h :: t -> if f h then aux (acc + 1) t else aux acc t in + aux 0 l + let rec index_f f x l n = match l with | [] -> raise Not_found | y :: l -> if f x y then n else index_f f x l (succ n) diff --git a/lib/cList.mli b/lib/cList.mli index 19eeb2509a..1487f67a37 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -94,6 +94,8 @@ sig (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i [f ai = true], then [smartfilter f l == l] *) + val count : ('a -> bool) -> 'a list -> int + val index : 'a eq -> 'a -> 'a list -> int (** [index] returns the 1st index of an element in a list (counting from 1). *) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 7fde7b7ac4..af48654015 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -299,7 +299,7 @@ let check_and_decompose_canonical_structure ref = | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in - let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in + let ntrue_projs = List.count snd s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref; (sp,indsp) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index deb03f5160..c44fbc0ba8 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -436,7 +436,7 @@ let instance_constructor (cl,u) args = | None -> true | Some _ -> false in - let lenpars = List.length (List.filter filter (snd cl.cl_context)) in + let lenpars = List.count filter (snd cl.cl_context) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with | IndRef ind -> diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 84649e6ebf..08228cb209 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -132,7 +132,7 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in - let nprods = List.length (List.filter (fun (_,b,_) -> Option.is_empty b) ctx) in + let nprods = List.count (fun (_,b,_) -> Option.is_empty b) ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in List.exists is_status_implicit lastimpl -- cgit v1.2.3 From f7433647beb23113faf0bf68326e5dc98e388d79 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Thu, 31 Dec 2015 17:04:07 +0100 Subject: Remove unused function Checker.print_loc. There is no location to print anyway, so it will never be useful. --- checker/checker.ml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/checker/checker.ml b/checker/checker.ml index d5d9b9e3b8..a13d529e83 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -217,12 +217,6 @@ open Type_errors let anomaly_string () = str "Anomaly: " let report () = (str "." ++ spc () ++ str "Please report.") -let print_loc loc = - if loc = Loc.ghost then - (str"") - else - let loc = Loc.unloc loc in - (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = str "\"" ++ str s ++ str "\"" let where s = -- cgit v1.2.3 From a1d6232019dd903419b0ac10819dfde6759c45d1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 31 Dec 2015 19:32:31 +0100 Subject: Fix bug #4456, anomaly in handle-side effects The side-effects can contain universe declarations needed to typecheck later proofs, which weren't added to the env used to typecheck them. --- kernel/term_typing.ml | 5 +- test-suite/bugs/closed/4456.v | 647 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 651 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4456.v diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index a566028d40..74c2e7da37 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -424,7 +424,10 @@ let export_side_effects mb env ce = let trusted = check_signatures mb signatures in let push_seff env = function | kn, cb, `Nothing, _ -> - Environ.add_constant kn cb env + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + Environ.push_context ~strict:true cb.const_universes env + else env | kn, cb, `Opaque(_, ctx), _ -> let env = Environ.add_constant kn cb env in Environ.push_context_set diff --git a/test-suite/bugs/closed/4456.v b/test-suite/bugs/closed/4456.v new file mode 100644 index 0000000000..a32acf789c --- /dev/null +++ b/test-suite/bugs/closed/4456.v @@ -0,0 +1,647 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Fiat" "-top" "BooleanRecognizerMin" "-R" "." "Top") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2475 lines to 729 lines, then from 746 lines to 658 lines, then from 675 lines to 658 lines *) +(* coqc version 8.5beta3 (November 2015) compiled on Nov 11 2015 18:23:0 with OCaml 4.01.0 + coqtop version 8.5beta3 (November 2015) *) +(* Variable P : forall n m : nat, n = m -> Prop. *) +(* Axiom Prefl : forall n : nat, P n n eq_refl. *) +Axiom proof_admitted : False. + +Tactic Notation "admit" := case proof_admitted. + +Require Coq.Program.Program. +Require Coq.Strings.String. +Require Coq.omega.Omega. +Module Export Fiat_DOT_Common. +Module Export Fiat. +Module Common. +Import Coq.Lists.List. +Export Coq.Program.Program. + +Global Set Implicit Arguments. + +Global Coercion is_true : bool >-> Sortclass. +Coercion bool_of_sum {A B} (b : sum A B) : bool := if b then true else false. + +Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type + := match ls return Type with + | nil => True + | x::xs => (P x * ForallT P xs)%type + end. +Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type + := match ls with + | nil => P nil + | x::xs => (P (x::xs) * Forall_tails P xs)%type + end. + +End Common. + +End Fiat. + +End Fiat_DOT_Common. +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Core. +Import Coq.Relations.Relation_Definitions. +Import Coq.Classes.Morphisms. + +Local Coercion is_true : bool >-> Sortclass. + +Module Export StringLike. + Class StringLike {Char : Type} := + { + String :> Type; + is_char : String -> Char -> bool; + length : String -> nat; + take : nat -> String -> String; + drop : nat -> String -> String; + get : nat -> String -> option Char; + unsafe_get : nat -> String -> Char; + bool_eq : String -> String -> bool; + beq : relation String := fun x y => bool_eq x y + }. + + Arguments StringLike : clear implicits. + Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope. + Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope. + Local Open Scope string_like_scope. + + Class StringLikeProperties (Char : Type) `{StringLike Char} := + { + singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch'; + singleton_exists : forall s, length s = 1 -> exists ch, s ~= [ ch ]; + get_0 : forall s ch, take 1 s ~= [ ch ] <-> get 0 s = Some ch; + get_S : forall n s, get (S n) s = get n (drop 1 s); + unsafe_get_correct : forall n s ch, get n s = Some ch -> unsafe_get n s = ch; + length_singleton : forall s ch, s ~= [ ch ] -> length s = 1; + bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s'; + is_char_Proper :> Proper (beq ==> eq ==> eq) is_char; + length_Proper :> Proper (beq ==> eq) length; + take_Proper :> Proper (eq ==> beq ==> beq) take; + drop_Proper :> Proper (eq ==> beq ==> beq) drop; + bool_eq_Equivalence :> Equivalence beq; + bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str'; + take_short_length : forall str n, n <= length str -> length (take n str) = n; + take_long : forall str n, length str <= n -> take n str =s str; + take_take : forall str n m, take n (take m str) =s take (min n m) str; + drop_length : forall str n, length (drop n str) = length str - n; + drop_0 : forall str, drop 0 str =s str; + drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str; + drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str); + take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str); + bool_eq_from_get : forall str str', (forall n, get n str = get n str') -> str =s str' + }. +Global Arguments StringLikeProperties _ {_}. +End StringLike. + +End Core. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Core. +Import Coq.Strings.String. +Import Coq.Lists.List. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type}. + + Section definitions. + + Inductive item := + | Terminal (_ : Char) + | NonTerminal (_ : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions; + Start_productions :> productions := Lookup Start_symbol; + Valid_nonterminals : list string; + Valid_productions : list productions := map Lookup Valid_nonterminals + }. + End definitions. + + End cfg. + +Arguments item _ : clear implicits. +Arguments production _ : clear implicits. +Arguments productions _ : clear implicits. +Arguments grammar _ : clear implicits. + +End Core. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_BaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export BaseTypes. +Import Coq.Arith.Wf_nat. + +Local Coercion is_true : bool >-> Sortclass. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + nonterminal_carrierT : Type; + of_nonterminal : String.string -> nonterminal_carrierT; + to_nonterminal : nonterminal_carrierT -> String.string; + initial_nonterminals_data : nonterminals_listT; + nonterminals_length : nonterminals_listT -> nat; + is_valid_nonterminal : nonterminals_listT -> nonterminal_carrierT -> bool; + remove_nonterminal : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT }. + + Class parser_removal_dataT' `{predata : parser_computational_predataT} := + { nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop + := ltof _ nonterminals_length; + nonterminals_length_zero : forall ls, + nonterminals_length ls = 0 + -> forall nt, is_valid_nonterminal ls nt = false; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + remove_nonterminal_noninc : forall ls nonterminal, + ~nonterminals_listT_R ls (remove_nonterminal ls nonterminal); + initial_nonterminals_correct : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) <-> List.In nonterminal (Valid_nonterminals G); + initial_nonterminals_correct' : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal <-> List.In (to_nonterminal nonterminal) (Valid_nonterminals G); + to_of_nonterminal : forall nonterminal, + List.In nonterminal (Valid_nonterminals G) + -> to_nonterminal (of_nonterminal nonterminal) = nonterminal; + of_to_nonterminal : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal + -> of_nonterminal (to_nonterminal nonterminal) = nonterminal; + ntl_wf : well_founded nonterminals_listT_R + := well_founded_ltof _ _; + remove_nonterminal_1 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' + -> is_valid_nonterminal ls ps'; + remove_nonterminal_2 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' = false + <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }. + + Class split_dataT := + { split_string_for_production + : item Char -> production Char -> String -> list nat }. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_data :> split_dataT }. +End recursive_descent_parser. + +End BaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_BaseTypes. + +Module Export Fiat_DOT_Common_DOT_List_DOT_Operations. +Module Export Fiat. +Module Export Common. +Module Export List. +Module Export Operations. + +Import Coq.Lists.List. + +Module Export List. + Section InT. + Context {A : Type} (a : A). + + Fixpoint InT (ls : list A) : Set + := match ls return Set with + | nil => False + | b :: m => (b = a) + InT m + end%type. + End InT. + + End List. + +End Operations. + +End List. + +End Common. + +End Fiat. + +End Fiat_DOT_Common_DOT_List_DOT_Operations. + +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Properties. + +Section String. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}. + + Lemma take_length {str n} + : length (take n str) = min n (length str). +admit. +Defined. + + End String. + +End Properties. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Properties. + +Local Open Scope list_scope. +Definition production_is_reachableT {Char} (G : grammar Char) (p : production Char) + := { nt : _ + & { prefix : _ + & List.In nt (Valid_nonterminals G) + * List.InT + (prefix ++ p) + (Lookup G nt) } }%type. + +End Properties. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_MinimalParse. +Module Export Fiat. +Module Export Parsers. +Module Export MinimalParse. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. + +Local Coercion is_true : bool >-> Sortclass. +Local Open Scope string_like_scope. + +Section cfg. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + Context {predata : @parser_computational_predataT} + {rdata' : @parser_removal_dataT' _ G predata}. + + Inductive minimal_parse_of + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + productions Char -> Type := + | MinParseHead : forall len0 valid str pat pats, + @minimal_parse_of_production len0 valid str pat + -> @minimal_parse_of len0 valid str (pat::pats) + | MinParseTail : forall len0 valid str pat pats, + @minimal_parse_of len0 valid str pats + -> @minimal_parse_of len0 valid str (pat::pats) + with minimal_parse_of_production + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + production Char -> Type := + | MinParseProductionNil : forall len0 valid str, + length str = 0 + -> @minimal_parse_of_production len0 valid str nil + | MinParseProductionCons : forall len0 valid str n pat pats, + length str <= len0 + -> @minimal_parse_of_item len0 valid (take n str) pat + -> @minimal_parse_of_production len0 valid (drop n str) pats + -> @minimal_parse_of_production len0 valid str (pat::pats) + with minimal_parse_of_item + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + item Char -> Type := + | MinParseTerminal : forall len0 valid str ch, + str ~= [ ch ] + -> @minimal_parse_of_item len0 valid str (Terminal ch) + | MinParseNonTerminal + : forall len0 valid str (nt : String.string), + @minimal_parse_of_nonterminal len0 valid str nt + -> @minimal_parse_of_item len0 valid str (NonTerminal nt) + with minimal_parse_of_nonterminal + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + String.string -> Type := + | MinParseNonTerminalStrLt + : forall len0 valid (nt : String.string) str, + length str < len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> @minimal_parse_of (length str) initial_nonterminals_data str (Lookup G nt) + -> @minimal_parse_of_nonterminal len0 valid str nt + | MinParseNonTerminalStrEq + : forall len0 str valid nonterminal, + length str = len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) + -> is_valid_nonterminal valid (of_nonterminal nonterminal) + -> @minimal_parse_of len0 (remove_nonterminal valid (of_nonterminal nonterminal)) str (Lookup G nonterminal) + -> @minimal_parse_of_nonterminal len0 valid str nonterminal. + +End cfg. + +End MinimalParse. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_MinimalParse. + +Module Export Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export CorrectnessBaseTypes. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. +Import Fiat_DOT_Common.Fiat.Common. +Section general. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Definition split_list_completeT_for {data : @parser_computational_predataT} + {len0 valid} + (it : item Char) (its : production Char) + (str : String) + (pf : length str <= len0) + (split_list : list nat) + + := ({ n : nat + & (minimal_parse_of_item (G := G) (predata := data) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type) + -> ({ n : nat + & (In (min (length str) n) (map (min (length str)) split_list)) + * (minimal_parse_of_item (G := G) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type). + + Definition split_list_completeT {data : @parser_computational_predataT} + (splits : item Char -> production Char -> String -> list nat) + := forall len0 valid str (pf : length str <= len0) nt, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> ForallT + (Forall_tails + (fun prod + => match prod return Type with + | nil => True + | it::its + => @split_list_completeT_for data len0 valid it its str pf (splits it its str) + end)) + (Lookup G nt). + + Class boolean_parser_completeness_dataT' {data : boolean_parser_dataT} := + { split_string_for_production_complete + : split_list_completeT split_string_for_production }. +End general. + +End CorrectnessBaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. + +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Valid. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Definition item_valid (it : item Char) + := match it with + | Terminal _ => True + | NonTerminal nt' => is_true (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt')) + end. + + Definition production_valid pat + := List.Forall item_valid pat. + + Definition productions_valid pats + := List.Forall production_valid pats. + + Definition grammar_valid + := forall nt, + List.In nt (Valid_nonterminals G) + -> productions_valid (Lookup G nt). +End cfg. + +End Valid. + +Section app. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Lemma hd_production_valid + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : item_valid it. +admit. +Defined. + + Lemma production_valid_cons + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : production_valid its. +admit. +Defined. + + End app. + +Import Coq.Lists.List. +Import Coq.omega.Omega. +Import Fiat_DOT_Common.Fiat.Common. +Import Fiat.Parsers.ContextFreeGrammar.Valid. +Local Open Scope string_like_scope. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char). + Context {data : @boolean_parser_dataT Char _} + {cdata : @boolean_parser_completeness_dataT' Char _ G data} + {rdata : @parser_removal_dataT' _ G _} + {gvalid : grammar_valid G}. + + Local Notation dec T := (T + (T -> False))%type (only parsing). + + Local Notation iffT x y := ((x -> y) * (y -> x))%type (only parsing). + + Lemma dec_prod {A B} (HA : dec A) (HB : dec B) : dec (A * B). +admit. +Defined. + + Lemma dec_In {A} {P : A -> Type} (HA : forall a, dec (P a)) ls + : dec { a : _ & (In a ls * P a) }. +admit. +Defined. + + Section item. + Context {len0 valid} + (str : String) + (str_matches_nonterminal' + : nonterminal_carrierT -> bool) + (str_matches_nonterminal + : forall nt : nonterminal_carrierT, + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Section valid. + Context (Hmatches + : forall nt, + is_valid_nonterminal initial_nonterminals_data nt + -> str_matches_nonterminal nt = str_matches_nonterminal' nt :> bool) + (it : item Char) + (Hvalid : item_valid it). + + Definition parse_item' + : dec (minimal_parse_of_item (G := G) len0 valid str it). + Proof. + clear Hvalid. + refine (match it return dec (minimal_parse_of_item len0 valid str it) with + | Terminal ch => if Sumbool.sumbool_of_bool (str ~= [ ch ]) + then inl (MinParseTerminal _ _ _ _ _) + else inr (fun _ => !) + | NonTerminal nt => if str_matches_nonterminal (of_nonterminal nt) + then inl (MinParseNonTerminal _) + else inr (fun _ => !) + end); + clear str_matches_nonterminal Hmatches; + admit. + Defined. + End valid. + + End item. + Context {len0 valid} + (parse_nonterminal + : forall (str : String) (len : nat) (Hlen : length str = len) (pf : len <= len0) (nt : nonterminal_carrierT), + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Lemma dec_in_helper {ls it its str} + : iffT {n0 : nat & + (In (min (length str) n0) (map (min (length str)) ls) * + minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + {n0 : nat & + (In n0 ls * + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its))%type}. +admit. +Defined. + + Lemma parse_production'_helper {str it its} (pf : length str <= len0) + : dec {n0 : nat & + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + -> dec (minimal_parse_of_production (G := G) len0 valid str (it :: its)). +admit. +Defined. + Local Ltac t_parse_production_for := repeat + match goal with + | [ H : (beq_nat _ _) = true |- _ ] => apply EqNat.beq_nat_true in H + | _ => progress subst + | _ => solve [ constructor; assumption ] + | [ H : minimal_parse_of_production _ _ _ nil |- _ ] => (inversion H; clear H) + | [ H : minimal_parse_of_production _ _ _ (_::_) |- _ ] => (inversion H; clear H) + | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H' + | _ => progress simpl in * + | _ => discriminate + | [ H : forall x, (_ * _)%type -> _ |- _ ] => specialize (fun x y z => H x (y, z)) + | _ => solve [ eauto with nocore ] + | _ => solve [ apply Min.min_case_strong; omega ] + | _ => omega + | [ H : production_valid (_::_) |- _ ] + => let H' := fresh in + pose proof H as H'; + apply production_valid_cons in H; + apply hd_production_valid in H' + end. + + Definition parse_production'_for + (splits : item Char -> production Char -> String -> list nat) + (Hsplits : forall str it its (Hreachable : production_is_reachableT G (it::its)) pf', split_list_completeT_for (len0 := len0) (G := G) (valid := valid) it its str pf' (splits it its str)) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0) + (prod : production Char) + (Hreachable : production_is_reachableT G prod) + : dec (minimal_parse_of_production (G := G) len0 valid str prod). + Proof. + revert prod Hreachable str len Hlen pf. + refine + ((fun pf_helper => + list_rect + (fun prod => + forall (Hreachable : production_is_reachableT G prod) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0), + dec (minimal_parse_of_production (G := G) len0 valid str prod)) + ( + fun Hreachable str len Hlen pf + => match Utils.dec (beq_nat len 0) with + | left H => inl _ + | right H => inr (fun p => _) + end) + (fun it its parse_production' Hreachable str len Hlen pf + => parse_production'_helper + _ + (let parse_item := (fun n pf => parse_item' (parse_nonterminal (take n str) (len := min n len) (eq_trans take_length (f_equal (min _) Hlen)) pf) it) in + let parse_item := (fun n => parse_item n (Min.min_case_strong n len (fun k => k <= len0) (fun Hlen => (Nat.le_trans _ _ _ Hlen pf)) (fun Hlen => pf))) in + let parse_production := (fun n => parse_production' (pf_helper it its Hreachable) (drop n str) (len - n) (eq_trans (drop_length _ _) (f_equal (fun x => x - _) Hlen)) (Nat.le_trans _ _ _ (Nat.le_sub_l _ _) pf)) in + match dec_In + (fun n => dec_prod (parse_item n) (parse_production n)) + (splits it its str) + with + | inl p => inl (existT _ (projT1 p) (snd (projT2 p))) + | inr p + => let pf' := (Nat.le_trans _ _ _ (Nat.eq_le_incl _ _ Hlen) pf) in + let H := (_ : split_list_completeT_for (G := G) (len0 := len0) (valid := valid) it its str pf' (splits it its str)) in + inr (fun p' => p (fst dec_in_helper (H p'))) + end) + )) _); + [ clear parse_nonterminal Hsplits splits rdata cdata + | clear parse_nonterminal Hsplits splits rdata cdata + | .. + | admit ]. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + Defined. -- cgit v1.2.3 From 37cc37090fcbabb9546a79558c9420e532701be4 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 31 Dec 2015 20:07:06 +0100 Subject: Put implicits back as in 8.4. --- test-suite/bugs/closed/3743.v | 2 +- theories/Classes/RelationClasses.v | 4 ++++ theories/Structures/OrdersFacts.v | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v index 4dfb3380a8..c799d4393f 100644 --- a/test-suite/bugs/closed/3743.v +++ b/test-suite/bugs/closed/3743.v @@ -3,7 +3,7 @@ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *) Require Export Coq.Setoids.Setoid. -Fail Add Parametric Relation A +Add Parametric Relation A : A (@eq A) transitivity proved by transitivity as refine_rel. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 15cb02d37f..6248babd0e 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -208,6 +208,10 @@ Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. Arguments irreflexivity {A R Irreflexive} [x] _. +Arguments symmetry {A} {R} {_} [x] [y] _. +Arguments asymmetry {A} {R} {_} [x] [y] _ _. +Arguments transitivity {A} {R} {_} [x] [y] [z] _ _. +Arguments Antisymmetric A eqA {_} _. Hint Resolve irreflexivity : ord. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 88fbd8c11c..954d3df203 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -90,7 +90,7 @@ Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). Instance le_order : PartialOrder eq le. Proof. compute; iorder. Qed. - Instance le_antisym : Antisymmetric eq le. + Instance le_antisym : Antisymmetric _ eq le. Proof. apply partial_order_antisym; auto with *. Qed. Lemma le_not_gt_iff : forall x y, x<=y <-> ~y Univ.universe_set -> evar_map val universe_of_name : evar_map -> string -> Univ.universe_level val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map -val universes : evar_map -> UGraph.t - val add_constraints_context : evar_universe_context -> Univ.constraints -> evar_universe_context @@ -517,7 +515,6 @@ val is_sort_variable : evar_map -> sorts -> Univ.universe_level option not a local sort variable declared in [evm] *) val is_flexible_level : evar_map -> Univ.Level.t -> bool -val whd_sort_variable : evar_map -> constr -> constr (* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) val normalize_universe : evar_map -> Univ.universe -> Univ.universe val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance -- cgit v1.2.3 From beab8bdff2daec9012c12648cad3f9b458a78124 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 1 Jan 2016 23:19:18 +0100 Subject: Remove unused open. --- kernel/pre_env.mli | 1 - 1 file changed, 1 deletion(-) diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index b499ac0c52..f403116617 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -10,7 +10,6 @@ open Names open Term open Context open Declarations -open Univ (** The type of environments. *) -- cgit v1.2.3 From 97c1dfa2f76a61992e600be4f07babb5be9c521e Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 1 Jan 2016 23:23:14 +0100 Subject: Remove useless recursive flags. --- stm/vernac_classifier.ml | 2 +- tools/ocamllibdep.mll | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 58e26de841..dcb6700941 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -60,7 +60,7 @@ let undo_classifier = ref (fun _ -> assert false) let set_undo_classifier f = undo_classifier := f let rec classify_vernac e = - let rec static_classifier e = match e with + let static_classifier e = match e with (* PG compatibility *) | VernacUnsetOption (["Silent"]|["Undo"]|["Printing";"Depth"]) | VernacSetOption ((["Silent"]|["Undo"]|["Printing";"Depth"]),_) diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 1bcbe7c0e8..670ff487c5 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -164,7 +164,7 @@ let traite_fichier_modules md ext = let addQueue q v = q := v :: !q -let rec treat_file old_name = +let treat_file old_name = let name = Filename.basename old_name in let dirname = Some (Filename.dirname old_name) in match get_extension name [".mllib"] with -- cgit v1.2.3 From 1b5d54b58f4ecea66ef9bf439d23b115d2c77050 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 1 Jan 2016 23:29:11 +0100 Subject: Remove unplugged button from the interface. --- ide/preferences.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/ide/preferences.ml b/ide/preferences.ml index a605014f2c..3d11e94feb 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -700,10 +700,6 @@ let configure ?(apply=(fun () -> ())) () = ~border_width:2 ~packing:scroll#add_with_viewport () in - let reset_button = GButton.button - ~label:"Reset" - ~packing:box#pack () - in let i = ref 0 in let cb = ref [] in let iter text tag = -- cgit v1.2.3 From bfdf6d2db29972ff52a1870524a230fdecb636dc Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 1 Jan 2016 23:31:47 +0100 Subject: Remove unused functions. --- stm/texmacspp.ml | 3 --- tools/coqdep_common.ml | 5 ----- 2 files changed, 8 deletions(-) diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index 1996d35259..b18e35a472 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -20,9 +20,6 @@ let unlock loc = let start, stop = Loc.unloc loc in (string_of_int start, string_of_int stop) -let xmlNoop = (* almost noop *) - PCData "" - let xmlWithLoc loc ename attr xml = let start, stop = unlock loc in Element(ename, [ "begin", start; "end", stop ] @ attr, xml) diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index b66529bb38..65fbd628a5 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -165,11 +165,6 @@ let warning_module_notfound f s = eprintf "*** Warning: in file %s, library %s is required and has not been found in the loadpath!\n%!" f (String.concat "." s) -let warning_notfound f s = - eprintf "*** Warning: in file %s, the file " f; - eprintf "%s.v is required and has not been found!\n" s; - flush stderr - let warning_declare f s = eprintf "*** Warning: in file %s, declared ML module " f; eprintf "%s has not been found!\n" s; -- cgit v1.2.3 From c671a5cb30db29feda56f008d45789c2fd4928e9 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 1 Jan 2016 23:33:40 +0100 Subject: Do not make it harder on the compiler optimizer by packing arguments. --- lib/cList.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/cList.ml b/lib/cList.ml index 72f892a09d..bd3e09b5b2 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -645,12 +645,13 @@ let rec split3 = function let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz) let firstn n l = - let rec aux acc = function - | (0, l) -> List.rev acc - | (n, (h::t)) -> aux (h::acc) (pred n, t) + let rec aux acc n l = + match n, l with + | 0, _ -> List.rev acc + | n, h::t -> aux (h::acc) (pred n) t | _ -> failwith "firstn" in - aux [] (n,l) + aux [] n l let rec last = function | [] -> failwith "List.last" -- cgit v1.2.3 From 53d109a21d97d073bc6a1f36a6c39b940a55eb69 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 1 Jan 2016 23:42:47 +0100 Subject: Remove unused hashconsing code. --- lib/hashcons.ml | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 46ba0b6285..d927519181 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -96,20 +96,6 @@ let recursive_hcons h f u = let () = loop := hrec in hrec -(* A set of global hashcons functions *) -let hashcons_resets = ref [] -let init() = List.iter (fun f -> f()) !hashcons_resets - -(* [register_hcons h u] registers the hcons function h, result of the above - * wrappers. It returns another hcons function that always uses the same - * table, which can be reinitialized by init() - *) -let register_hcons h u = - let hf = ref (h u) in - let reset() = hf := h u in - hashcons_resets := reset :: !hashcons_resets; - (fun x -> !hf x) - (* Basic hashcons modules for string and obj. Integers do not need be hashconsed. *) @@ -194,18 +180,3 @@ module Hobj = Make( let equal = comp_obj let hash = Hashtbl.hash end) - -(* Hashconsing functions for string and obj. Always use the same - * global tables. The latter can be reinitialized with init() - *) -(* string : string -> string *) -(* obj : Obj.t -> Obj.t *) -let string = register_hcons (simple_hcons Hstring.generate Hstring.hcons) () -let obj = register_hcons (recursive_hcons Hobj.generate Hobj.hcons) () - -(* The unsafe polymorphic hashconsing function *) -let magic_hash (c : 'a) = - init(); - let r = obj (Obj.repr c) in - init(); - (Obj.magic r : 'a) -- cgit v1.2.3 From d5b1807e65f7ea29d435c3f894aa551370c5989f Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 1 Jan 2016 23:47:59 +0100 Subject: Fix typos. --- ide/FAQ | 2 +- kernel/uGraph.ml | 4 ++-- lib/hashcons.ml | 2 +- plugins/micromega/mfourier.ml | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/ide/FAQ b/ide/FAQ index 07b818246a..c8b0a5d328 100644 --- a/ide/FAQ +++ b/ide/FAQ @@ -1,7 +1,7 @@ CoqIde FAQ Q0) What is CoqIde? -R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations. +R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations. Q1) How to enable Emacs keybindings? R1: Insert diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 925b2248d8..6765f91ee1 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -277,7 +277,7 @@ exception CycleDetected problems. arXiv preprint arXiv:1112.0784. *) (* [delta] is the timeout for backward search. It might be - usefull to tune a multiplicative constant. *) + useful to tune a multiplicative constant. *) let get_delta g = int_of_float (min (float_of_int g.n_edges ** 0.5) @@ -668,7 +668,7 @@ let check_leq g u v = is_type0m_univ u || check_eq_univs g u v || real_check_leq g u v -(* enforc_univ_eq g u v will force u=v if possible, will fail otherwise *) +(* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) let rec enforce_univ_eq u v g = let ucan = repr g u in diff --git a/lib/hashcons.ml b/lib/hashcons.ml index d927519181..eeaaf2f7fc 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -72,7 +72,7 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = end -(* A few usefull wrappers: +(* A few useful wrappers: * takes as argument the function [generate] above and build a function of type * u -> t -> t that creates a fresh table each time it is applied to the * sub-hcons functions. *) diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 0261d73490..e22fe58434 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -120,7 +120,7 @@ and cstr_info = { (** A system of constraints has the form [\{sys = s ; vars = v\}]. [s] is a hashtable mapping a normalised vector to a [cstr_info] record where - [bound] is an interval - - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint. + - [prf_idx] is the set of hypothesis indexes (i.e. constraints in the initial system) used to obtain the current constraint. In the initial system, each constraint is given an unique singleton proof_idx. When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector @@ -872,7 +872,7 @@ let mk_proof hyps prf = | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in - (* I take only the pairs for which the elimination is meaningfull *) + (* I take only the pairs for which the elimination is meaningful *) forall_pairs (pivot v) prfsl prfsr | And(prf1,prf2) -> let prfsl1 = mk_proof prf1 -- cgit v1.2.3 From f3e611b2115b425f875e971ac9ff7534c2af2800 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Dec 2015 13:56:40 +0100 Subject: Separation of concern in TacAlias API. The TacAlias node now only contains the arguments fed to the tactic notation. The binding variables are worn by the tactic representation in Tacenv. --- intf/tacexpr.mli | 2 +- parsing/egramcoq.ml | 4 ++-- printing/pptactic.ml | 2 +- tactics/tacenv.ml | 3 ++- tactics/tacenv.mli | 7 +++++-- tactics/tacintern.ml | 2 +- tactics/tacinterp.ml | 19 ++++++++++++------- tactics/tacsubst.ml | 2 +- toplevel/metasyntax.ml | 15 ++++++++------- 9 files changed, 33 insertions(+), 23 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 6d10ef9d51..05e7ea1a3b 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -294,7 +294,7 @@ and 'a gen_tactic_expr = (* For ML extensions *) | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list (* For syntax extensions *) - | TacAlias of Loc.t * KerName.t * (Id.t * 'a gen_tactic_arg) list + | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list constraint 'a = < term:'t; diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 2bc5b0f83f..bd9bacbc60 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -286,9 +286,9 @@ let add_tactic_entry kn tg = (** HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Constrarg.wit_tactic in if Genarg.argument_type_eq t (Genarg.unquote wit) then - (id, Tacexp (Genarg.out_gen wit arg)) + Tacexp (Genarg.out_gen wit arg) else - (id, TacGeneric arg) + TacGeneric arg in let l = List.map2 map l types in (TacAlias (loc,kn,l):raw_tactic_expr) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 4cb7e9fb38..50a543968a 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1201,7 +1201,7 @@ module Make | TacML (loc,s,l) -> pr_with_comments loc (pr.pr_extend 1 s l), lcall | TacAlias (loc,kn,l) -> - pr_with_comments loc (pr.pr_alias (level_of inherited) kn (List.map snd l)), latom + pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom ) in if prec_less prec inherited then strm diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index d7ab2d71ec..c7339acea7 100644 --- a/tactics/tacenv.ml +++ b/tactics/tacenv.ml @@ -15,9 +15,10 @@ open Tacexpr (** Tactic notations (TacAlias) *) type alias = KerName.t +type alias_tactic = Id.t list * glob_tactic_expr let alias_map = Summary.ref ~name:"tactic-alias" - (KNmap.empty : glob_tactic_expr KNmap.t) + (KNmap.empty : alias_tactic KNmap.t) let register_alias key tac = alias_map := KNmap.add key tac !alias_map diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli index 28fb138817..65fd693435 100644 --- a/tactics/tacenv.mli +++ b/tactics/tacenv.mli @@ -17,10 +17,13 @@ open Tacexpr type alias = KerName.t (** Type of tactic alias, used in the [TacAlias] node. *) -val register_alias : alias -> glob_tactic_expr -> unit +type alias_tactic = Id.t list * glob_tactic_expr +(** Contents of a tactic notation *) + +val register_alias : alias -> alias_tactic -> unit (** Register a tactic alias. *) -val interp_alias : alias -> glob_tactic_expr +val interp_alias : alias -> alias_tactic (** Recover the the body of an alias. Raises an anomaly if it does not exist. *) val check_alias : alias -> bool diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 93d64f686d..e6273401dd 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -656,7 +656,7 @@ and intern_tactic_seq onlytac ist = function (* For extensions *) | TacAlias (loc,s,l) -> - let l = List.map (fun (id,a) -> (id,intern_tacarg !strict_check false ist a)) l in + let l = List.map (intern_tacarg !strict_check false ist) l in ist.ltacvars, TacAlias (loc,s,l) | TacML (loc,opn,l) -> let _ignore = Tacenv.interp_ml_tactic opn in diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 1596406c9a..a871815881 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1238,14 +1238,12 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac (* For extensions *) | TacAlias (loc,s,l) -> - let body = Tacenv.interp_alias s in + let (ids, body) = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in - let interp_vars = - Ftactic.List.map (fun (x,v) -> interp_tacarg ist v >>= fun v -> Ftactic.return (x,v)) l - in - let addvar (x, v) accu = Id.Map.add x v accu in + let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = - let lfun = List.fold_right addvar l ist.lfun in + let addvar x v accu = Id.Map.add x v accu in + let lfun = List.fold_right2 addvar ids l ist.lfun in let trace = push_trace (loc,LtacNotationCall s) ist in let ist = { lfun = lfun; @@ -1255,12 +1253,19 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> - let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s (List.map snd lr) in + let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, some more elaborate solution will have to be used. *) in + let tac = + let len1 = List.length ids in + let len2 = List.length l in + if len1 = len2 then tac + else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ + expected " ++ int len1 ++ str ", found " ++ int len2) + in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) | TacML (loc,opn,l) -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 45b2d317c2..754c886205 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -245,7 +245,7 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with (* For extensions *) | TacAlias (_,s,l) -> let s = subst_kn subst s in - TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_tacarg subst a)) l) + TacAlias (dloc,s,List.map (subst_tacarg subst) l) | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 0f96c2b4af..821283e946 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -81,7 +81,7 @@ type tactic_grammar_obj = { tacobj_local : locality_flag; tacobj_tacgram : tactic_grammar; tacobj_tacpp : Pptactic.pp_tactic; - tacobj_body : Tacexpr.glob_tactic_expr + tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; } let check_key key = @@ -111,9 +111,10 @@ let load_tactic_notation i (_, tobj) = Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram let subst_tactic_notation (subst, tobj) = + let (ids, body) = tobj.tacobj_body in { tobj with tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body; + tacobj_body = (ids, Tacsubst.subst_tactic subst body); } let classify_tactic_notation tacobj = Substitute tacobj @@ -126,9 +127,9 @@ let inTacticGrammar : tactic_grammar_obj -> obj = subst_function = subst_tactic_notation; classify_function = classify_tactic_notation} -let cons_production_parameter l = function - | GramTerminal _ -> l - | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l +let cons_production_parameter = function + | GramTerminal _ -> None + | GramNonTerminal (_, _, _, id) -> id let add_tactic_notation (local,n,prods,e) = let prods = List.map (interp_prod_item n) prods in @@ -137,7 +138,7 @@ let add_tactic_notation (local,n,prods,e) = Pptactic.pptac_args = tags; pptac_prods = (n, List.map make_terminal_status prods); } in - let ids = List.fold_left cons_production_parameter [] prods in + let ids = List.map_filter cons_production_parameter prods in let tac = Tacintern.glob_tactic_env ids (Global.env()) e in let parule = { tacgram_level = n; @@ -148,7 +149,7 @@ let add_tactic_notation (local,n,prods,e) = tacobj_local = local; tacobj_tacgram = parule; tacobj_tacpp = pprule; - tacobj_body = tac; + tacobj_body = (ids, tac); } in Lib.add_anonymous_leaf (inTacticGrammar tacobj) -- cgit v1.2.3 From 9a6269a2a425de9d1a593f2c7be77cc2922b46aa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Dec 2015 19:57:07 +0100 Subject: Proper datatype for EXTEND syntax tokens. --- grammar/argextend.ml4 | 40 ++++++++++++++--------------- grammar/q_util.ml4 | 4 +++ grammar/q_util.mli | 4 +++ grammar/tacextend.ml4 | 65 +++++++++++++++++++++--------------------------- grammar/vernacextend.ml4 | 21 ++++++++-------- 5 files changed, 66 insertions(+), 68 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 677daebfb3..89a1cd8b83 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -45,7 +45,7 @@ let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> let has_extraarg l = let check = function - | GramNonTerminal(_, t, _, _) -> + | ExtNonTerminal(EntryName (t, _), _) -> begin match Genarg.unquote t with | ExtraArgType _ -> true | _ -> false @@ -74,7 +74,7 @@ let rec get_empty_entry : type s a. (s, a) entry_key -> _ = function let statically_known_possibly_empty s (prods,_) = List.for_all (function - | GramNonTerminal(_,t,e,_) -> + | ExtNonTerminal(EntryName (t, e), _) -> begin match Genarg.unquote t with | ExtraArgType s' -> (* For ExtraArg we don't know (we'll have to test dynamically) *) @@ -83,26 +83,26 @@ let statically_known_possibly_empty s (prods,_) = | _ -> is_possibly_empty e end - | GramTerminal _ -> + | ExtTerminal _ -> (* This consumes a token for sure *) false) prods let possibly_empty_subentries loc (prods,act) = - let bind_name p v e = match p with - | None -> e - | Some id -> - let s = Names.Id.to_string id in <:expr< let $lid:s$ = $v$ in $e$ >> in + let bind_name id v e = + let s = Names.Id.to_string id in + <:expr< let $lid:s$ = $v$ in $e$ >> + in let rec aux = function | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >> - | GramNonTerminal(_,_,e,p) :: tl when is_possibly_empty e -> - bind_name p (get_empty_entry e) (aux tl) - | GramNonTerminal(_,t,_,p) :: tl -> + | ExtNonTerminal(EntryName (_, e), id) :: tl when is_possibly_empty e -> + bind_name id (get_empty_entry e) (aux tl) + | ExtNonTerminal(EntryName (t, _), id) :: tl -> let t = match Genarg.unquote t with | ExtraArgType _ as t -> t | _ -> assert false in (* We check at runtime if extraarg s parses "epsilon" *) - let s = match p with None -> "_" | Some id -> Names.Id.to_string id in + let s = Names.Id.to_string id in <:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with [ None -> raise Exit | Some v -> v ] in $aux tl$ >> @@ -135,20 +135,20 @@ let make_possibly_empty_subentries loc s cl = let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> - | GramNonTerminal (_,t,_,Some p) :: tl -> + | ExtNonTerminal (EntryName (t, _), p) :: tl -> let t = Genarg.unquote t in let p = Names.Id.to_string p in <:expr< (fun $lid:p$ -> let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) >> - | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl -> + | ExtTerminal _ :: tl -> <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function - | GramTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> - | GramNonTerminal (_,_,g,_) -> mlexpr_of_prod_entry_key g + | ExtTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> + | ExtNonTerminal (EntryName (_, g), _) -> mlexpr_of_prod_entry_key g let rec make_prod = function | [] -> <:expr< Extend.Stop >> @@ -315,15 +315,15 @@ EXTEND ; genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e "" in + ExtNonTerminal (entry, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e sep in + ExtNonTerminal (entry, Names.Id.of_string s) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Lexer.add_keyword s; - GramTerminal s + ExtTerminal s ] ] ; entry_name: diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 76113ad509..4c1f25941f 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -10,6 +10,10 @@ open Compat +type extend_token = +| ExtTerminal of string +| ExtNonTerminal of unit Pcoq.entry_name * Names.Id.t + let mlexpr_of_list f l = List.fold_right (fun e1 e2 -> diff --git a/grammar/q_util.mli b/grammar/q_util.mli index d01fb1e9a0..d9359de1e8 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -8,6 +8,10 @@ open Compat (* necessary for camlp4 *) +type extend_token = +| ExtTerminal of string +| ExtNonTerminal of unit Pcoq.entry_name * Names.Id.t + val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr val mlexpr_of_pair : diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 01828267bf..6069f4b4b2 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -27,29 +27,26 @@ let plugin_name = <:expr< __coq_plugin_name >> let rec make_patt = function | [] -> <:patt< [] >> - | GramNonTerminal(loc',_,_,Some p)::l -> + | ExtNonTerminal (_, p) :: l -> let p = Names.Id.to_string p in <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l let rec make_when loc = function | [] -> <:expr< True >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let loc' = of_coqloc loc' in + | ExtNonTerminal (EntryName (t, _), p) :: l -> let p = Names.Id.to_string p in let l = make_when loc l in - let loc = CompatLoc.merge loc' loc in - let t = mlexpr_of_argtype loc' (Genarg.unquote t) in + let t = mlexpr_of_argtype loc (Genarg.unquote t) in <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >> | _::l -> make_when loc l let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> - | GramNonTerminal(loc,t,_,Some p)::l -> + | ExtNonTerminal (EntryName (t, _), p) :: l -> let t = Genarg.unquote t in - let loc = of_coqloc loc in let p = Names.Id.to_string p in - let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in + let loc = MLast.loc_of_expr e in let e = make_let raw e l in let v = if raw then <:expr< Genarg.out_gen $make_rawwit loc t$ $lid:p$ >> @@ -59,7 +56,7 @@ let rec make_let raw e = function let rec extract_signature = function | [] -> [] - | GramNonTerminal (_,t,_,_) :: l -> Genarg.unquote t :: extract_signature l + | ExtNonTerminal (EntryName (t, _), _) :: l -> Genarg.unquote t :: extract_signature l | _::l -> extract_signature l @@ -83,37 +80,32 @@ let make_fun_clauses loc s l = let rec make_args = function | [] -> <:expr< [] >> - | GramNonTerminal(loc,t,_,Some p)::l -> + | ExtNonTerminal (EntryName (t, _), p) :: l -> let t = Genarg.unquote t in - let loc = of_coqloc loc in let p = Names.Id.to_string p in <:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >> | _::l -> make_args l let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function - | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >> - | GramNonTerminal (loc,nt,_,sopt) -> - let loc = of_coqloc loc in <:expr< None >> + | ExtTerminal s -> <:expr< Some $mlexpr_of_string s$ >> + | ExtNonTerminal _ -> <:expr< None >> let make_prod_item = function - | GramTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | GramNonTerminal (loc,nt,g,sopt) -> - let loc = of_coqloc loc in + | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> + | ExtNonTerminal (EntryName (nt, g), id) -> let nt = Genarg.unquote nt in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ - $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >> + $mlexpr_of_prod_entry_key g$ (Some $mlexpr_of_ident id$) >> let mlexpr_of_clause cl = mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) cl let rec make_tags loc = function | [] -> <:expr< [] >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let loc' = of_coqloc loc' in + | ExtNonTerminal (EntryName (t, _), p) :: l -> let l = make_tags loc l in - let loc = CompatLoc.merge loc' loc in let t = Genarg.unquote t in - let t = mlexpr_of_argtype loc' t in + let t = mlexpr_of_argtype loc t in <:expr< [ $t$ :: $l$ ] >> | _::l -> make_tags loc l @@ -127,7 +119,7 @@ let make_one_printing_rule (pt,_,e) = let make_printing_rule r = mlexpr_of_list make_one_printing_rule r let make_empty_check = function -| GramNonTerminal(_, t, e, _)-> +| ExtNonTerminal (EntryName (t, e), _)-> let t = Genarg.unquote t in let is_extra = match t with ExtraArgType _ -> true | _ -> false in if is_possibly_empty e || is_extra then @@ -143,16 +135,16 @@ let make_empty_check = function else (* This does not parse epsilon (this Exit is static time) *) raise Exit -| GramTerminal _ -> +| ExtTerminal _ -> (* Idem *) raise Exit let rec possibly_atomic loc = function | [] -> [] -| ((GramNonTerminal _ :: _ | []), _, _) :: rem -> +| ((ExtNonTerminal _ :: _ | []), _, _) :: rem -> (** This is not parsed by the TACTIC EXTEND rules *) assert false -| (GramTerminal s :: prods, _, _) :: rem -> +| (ExtTerminal s :: prods, _, _) :: rem -> let entry = try let l = List.map make_empty_check prods in @@ -164,8 +156,8 @@ let rec possibly_atomic loc = function (** Special treatment of constr entries *) let is_constr_gram = function -| GramTerminal _ -> false -| GramNonTerminal (_, _, e, _) -> +| ExtTerminal _ -> false +| ExtNonTerminal (EntryName (_, e), _) -> match e with | Aentry e -> begin match Entry.repr e with @@ -175,12 +167,11 @@ let is_constr_gram = function | _ -> false let make_var = function - | GramNonTerminal(loc',_,_,Some p) -> Some p - | GramNonTerminal(loc',_,_,None) -> Some (Id.of_string "_") + | ExtNonTerminal (_, p) -> Some p | _ -> assert false let declare_tactic loc s c cl = match cl with -| [(GramTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> +| [(ExtTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in @@ -258,7 +249,7 @@ EXTEND c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; "->"; "["; e = Pcaml.expr; "]" -> (match l with - | GramNonTerminal _ :: _ -> + | ExtNonTerminal _ :: _ -> (* En attendant la syntaxe de tacticielles *) failwith "Tactic syntax must start with an identifier" | _ -> (l,c,e)) @@ -266,14 +257,14 @@ EXTEND ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e "" in + ExtNonTerminal (entry, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e sep in + ExtNonTerminal (entry, Names.Id.of_string s) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); - GramTerminal s + ExtTerminal s ] ] ; tac_name: diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 54638556db..8de59e5cd2 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -22,7 +22,7 @@ open Compat type rule = { r_head : string option; (** The first terminal grammar token *) - r_patt : Vernacexpr.vernac_expr grammar_prod_item list; + r_patt : extend_token list; (** The remaining tokens of the parsing rule *) r_class : MLast.expr option; (** An optional classifier for the STM *) @@ -34,11 +34,10 @@ type rule = { let rec make_let e = function | [] -> e - | GramNonTerminal(loc,t,_,Some p)::l -> + | ExtNonTerminal (EntryName (t, _), p) :: l -> let t = Genarg.unquote t in - let loc = of_coqloc loc in let p = Names.Id.to_string p in - let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in + let loc = MLast.loc_of_expr e in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> | _::l -> make_let e l @@ -51,7 +50,7 @@ let make_clause { r_patt = pt; r_branch = e; } = (* To avoid warnings *) let mk_ignore c pt = let names = CList.map_filter (function - | GramNonTerminal(_,_,_,Some p) -> Some (Names.Id.to_string p) + | ExtNonTerminal (_, p) -> Some (Names.Id.to_string p) | _ -> None) pt in let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in let names = List.fold_left fold <:expr< () >> names in @@ -109,7 +108,7 @@ let make_fun_classifiers loc s c l = let mlexpr_of_clause = mlexpr_of_list (fun { r_head = a; r_patt = b; } -> mlexpr_of_list make_prod_item - (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) + (Option.List.cons (Option.map (fun a -> ExtTerminal a) a) b)) let declare_command loc s c nt cl = let se = mlexpr_of_string s in @@ -182,13 +181,13 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e "" in + ExtNonTerminal (entry, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e sep in + ExtNonTerminal (entry, Names.Id.of_string s) | s = STRING -> - GramTerminal s + ExtTerminal s ] ] ; END -- cgit v1.2.3 From a5e1b40b93e47a278746ee6752474891cd856c29 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Dec 2015 19:26:02 +0100 Subject: Simplification of grammar_prod_item type. Actually the identifier was never used and just carried along. --- dev/top_printers.ml | 6 ++---- grammar/tacextend.ml4 | 2 +- intf/vernacexpr.mli | 2 +- parsing/egramcoq.ml | 7 +++---- parsing/egramml.ml | 19 ++++++++----------- parsing/egramml.mli | 4 ++-- parsing/g_vernac.ml4 | 2 +- printing/ppvernac.ml | 3 +-- toplevel/metasyntax.ml | 13 ++++++------- 9 files changed, 25 insertions(+), 33 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0894e0378d..cbebcdfcd4 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -520,8 +520,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), - Some (Names.Id.of_string "c"))] + (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")))] let _ = try @@ -537,8 +536,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), - Some (Names.Id.of_string "c"))] + (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")))] (* Setting printer of unbound global reference *) open Names diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 6069f4b4b2..bf0c4fc215 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -95,7 +95,7 @@ let make_prod_item = function | ExtNonTerminal (EntryName (nt, g), id) -> let nt = Genarg.unquote nt in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ - $mlexpr_of_prod_entry_key g$ (Some $mlexpr_of_ident id$) >> + $mlexpr_of_prod_entry_key g$ >> let mlexpr_of_clause cl = mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) cl diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 4bc3a9e609..3bb86fcb20 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -205,7 +205,7 @@ type proof_expr = type grammar_tactic_prod_item_expr = | TacTerm of string - | TacNonTerm of Loc.t * string * (Names.Id.t * string) option + | TacNonTerm of Loc.t * string * (Names.Id.t * string) type syntax_modifier = | SetItemLevel of string list * Extend.production_level diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index bd9bacbc60..29f8555c81 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -257,7 +257,7 @@ let add_ml_tactic_entry name prods = let mkact i loc l : raw_tactic_expr = let open Tacexpr in let entry = { mltac_name = name; mltac_index = i } in - let map (_, arg) = TacGeneric arg in + let map arg = TacGeneric arg in TacML (loc, entry, List.map map l) in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in @@ -278,11 +278,10 @@ let add_tactic_entry kn tg = let mkact loc l = let filter = function | GramTerminal _ -> None - | GramNonTerminal (_, t, _, None) -> None - | GramNonTerminal (_, t, _, Some _) -> Some (Genarg.unquote t) + | GramNonTerminal (_, t, _) -> Some (Genarg.unquote t) in let types = List.map_filter filter tg.tacgram_prods in - let map (id, arg) t = + let map arg t = (** HACK to handle especially the tactic(...) entry *) let wit = Genarg.rawwit Constrarg.wit_tactic in if Genarg.argument_type_eq t (Genarg.unquote wit) then diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 984027b815..e95b85bc26 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -18,9 +18,9 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's grammar_prod_item -type 'a ty_arg = Id.t * ('a -> raw_generic_argument) +type 'a ty_arg = ('a -> raw_generic_argument) type ('self, _, 'r) ty_rule = | TyStop : ('self, 'r, 'r) ty_rule @@ -37,12 +37,9 @@ let rec ty_rule_of_gram = function let tok = Atoken (Lexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r -| GramNonTerminal (_, t, tok, idopt) :: rem -> +| GramNonTerminal (_, t, tok) :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let inj = match idopt with - | None -> None - | Some id -> Some (id, fun obj -> Genarg.in_gen t obj) - in + let inj = Some (fun obj -> Genarg.in_gen t obj) in let r = TyNext (rem, tok, inj) in AnyTyRule r @@ -50,13 +47,13 @@ let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = func | TyStop -> Extend.Stop | TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) -type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r +type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f -| TyNext (rem, tok, Some (id, inj)) -> fun f x -> - let f loc args = f loc ((id, inj x) :: args) in +| TyNext (rem, tok, Some inj) -> fun f x -> + let f loc args = f loc (inj x :: args) in ty_eval rem f let make_rule f prod = @@ -81,6 +78,6 @@ let get_extend_vernac_rule (s, i) = let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; - let mkact loc l = VernacExtend (s,List.map snd l) in + let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in grammar_extend nt None (None, [None, None, rules]) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index e3ae4e0118..8a494d70ba 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -16,7 +16,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * - ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item + ('s, 'a) Pcoq.entry_key -> 's grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> @@ -27,5 +27,5 @@ val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_ (** Utility function reused in Egramcoq : *) val make_rule : - (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'a) -> + (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> 'a grammar_prod_item list -> 'a Extend.production_rule diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 2c9894dad2..f79aa8d3dd 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1165,7 +1165,7 @@ GEXTEND Gram production_item: [ [ s = ne_string -> TacTerm s | nt = IDENT; - po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; + po = [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ] ; END diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 4957199903..daba18bad2 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -105,10 +105,9 @@ module Make else id let pr_production_item = function - | TacNonTerm (loc,nt,Some (p,sep)) -> + | TacNonTerm (loc, nt, (p, sep)) -> let pp_sep = if not (String.is_empty sep) then str "," ++ quote (str sep) else mt () in str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")" - | TacNonTerm (loc,nt,None) -> str nt | TacTerm s -> qs s let pr_comment pr_c = function diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 821283e946..6ba5f4f875 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -47,10 +47,9 @@ let add_token_obj s = Lib.add_anonymous_leaf (inToken s) let interp_prod_item lev = function | TacTerm s -> GramTerminal s - | TacNonTerm (loc, nt, po) -> - let sep = match po with Some (_,sep) -> sep | _ -> "" in + | TacNonTerm (loc, nt, (_, sep)) -> let EntryName (etyp, e) = interp_entry_name true (TgTactic lev) nt sep in - GramNonTerminal (loc, etyp, e, Option.map fst po) + GramNonTerminal (loc, etyp, e) let make_terminal_status = function | GramTerminal s -> Some s @@ -58,7 +57,7 @@ let make_terminal_status = function let rec make_tags = function | GramTerminal s :: l -> make_tags l - | GramNonTerminal (loc, etyp, _, po) :: l -> Genarg.unquote etyp :: make_tags l + | GramNonTerminal (loc, etyp, _) :: l -> Genarg.unquote etyp :: make_tags l | [] -> [] let make_fresh_key = @@ -128,17 +127,17 @@ let inTacticGrammar : tactic_grammar_obj -> obj = classify_function = classify_tactic_notation} let cons_production_parameter = function - | GramTerminal _ -> None - | GramNonTerminal (_, _, _, id) -> id +| TacTerm _ -> None +| TacNonTerm (_, _, (id, _)) -> Some id let add_tactic_notation (local,n,prods,e) = + let ids = List.map_filter cons_production_parameter prods in let prods = List.map (interp_prod_item n) prods in let tags = make_tags prods in let pprule = { Pptactic.pptac_args = tags; pptac_prods = (n, List.map make_terminal_status prods); } in - let ids = List.map_filter cons_production_parameter prods in let tac = Tacintern.glob_tactic_env ids (Global.env()) e in let parule = { tacgram_level = n; -- cgit v1.2.3 From 2c8275ee3e0e5cd4eb8afd24047fda7f864e0e4e Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 16:50:02 +0100 Subject: Remove useless rec flags. --- engine/evd.ml | 2 +- ide/sentence.ml | 4 ++-- printing/pptactic.ml | 2 +- tactics/tactics.ml | 2 +- toplevel/himsg.ml | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index d91b90caa2..8476db6646 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1230,7 +1230,7 @@ let pr_decl ((id,b,_),ok) = | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ print_constr c ++ str (if ok then ")" else "}") -let rec pr_evar_source = function +let pr_evar_source = function | Evar_kinds.QuestionMark _ -> str "underscore" | Evar_kinds.CasesType false -> str "pattern-matching return predicate" | Evar_kinds.CasesType true -> diff --git a/ide/sentence.ml b/ide/sentence.ml index dd6b10a461..8195051c6c 100644 --- a/ide/sentence.ml +++ b/ide/sentence.ml @@ -63,13 +63,13 @@ let grab_sentence_start (iter:GText.iter) soi = (** Search forward the first character immediately after a sentence end *) -let rec grab_sentence_stop (start:GText.iter) = +let grab_sentence_stop (start:GText.iter) = (forward_search is_sentence_end start)#forward_char (** Search forward the first character immediately after a "." sentence end (and not just a "\{" or "\}" or comment end *) -let rec grab_ending_dot (start:GText.iter) = +let grab_ending_dot (start:GText.iter) = let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in (forward_search is_ending_dot start)#forward_char diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 50a543968a..7800f1edb3 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1268,7 +1268,7 @@ module Make let pr_pat_and_constr_expr pr ((c,_),_) = pr c - let rec pr_glob_tactic_level env n t = + let pr_glob_tactic_level env n t = let glob_printers = (strip_prod_binders_glob_constr) in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 6d20bc3cdb..1349d55177 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2130,7 +2130,7 @@ let rewrite_hyp assert_style l2r id = Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) end } -let rec prepare_naming loc = function +let prepare_naming loc = function | IntroIdentifier id -> NamingMustBe (loc,id) | IntroAnonymous -> NamingAvoid [] | IntroFresh id -> NamingBasedOn (id,[]) diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 3308903dd7..3ac537297e 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -260,7 +260,7 @@ let explain_generalization env sigma (name,var) j = str "it has type" ++ spc () ++ pt ++ spc () ++ str "which should be Set, Prop or Type." -let rec explain_unification_error env sigma p1 p2 = function +let explain_unification_error env sigma p1 p2 = function | None -> mt() | Some e -> let rec aux p1 p2 = function -- cgit v1.2.3 From 82ac0604888679bc2fbdeda9ac264d7cd10f7928 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 16:52:33 +0100 Subject: Avoid warnings about loop indices. --- ide/document.ml | 2 +- ide/ideutils.ml | 2 +- kernel/nativelambda.ml | 2 +- lib/hashset.ml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ide/document.ml b/ide/document.ml index 9823e7576c..41d5a7564b 100644 --- a/ide/document.ml +++ b/ide/document.ml @@ -154,7 +154,7 @@ let cut_at d id = if stateid_opt_equal state_id (Some id) then CSig.Stop (n, zone) else CSig.Cont (n + 1, data :: zone) in let n, zone = CList.fold_left_until aux (0, []) d.stack in - for i = 1 to n do ignore(pop d) done; + for _i = 1 to n do ignore(pop d) done; List.rev zone let find_id d f = diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 2e4adba735..ffa07ead7e 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -31,7 +31,7 @@ let push_info,pop_info,clear_info = let size = ref 0 in (fun s -> incr size; ignore (status_context#push s)), (fun () -> decr size; status_context#pop ()), - (fun () -> for i = 1 to !size do status_context#pop () done; size := 0) + (fun () -> for _i = 1 to !size do status_context#pop () done; size := 0) let flash_info = let flash_context = status#new_context ~name:"Flash" in diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 4d033bc999..3ff9b5702c 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -485,7 +485,7 @@ module Renv = let pop env = Vect.pop env.name_rel let popn env n = - for i = 1 to n do pop env done + for _i = 1 to n do pop env done let get env n = Lrel (Vect.get_last env.name_rel (n-1), n) diff --git a/lib/hashset.ml b/lib/hashset.ml index 1ca6cc6418..0009ac6506 100644 --- a/lib/hashset.ml +++ b/lib/hashset.ml @@ -162,7 +162,7 @@ module Make (E : EqType) = t.hashes.(index) <- newhashes; if sz <= t.limit && newsz > t.limit then begin t.oversize <- t.oversize + 1; - for i = 0 to over_limit do test_shrink_bucket t done; + for _i = 0 to over_limit do test_shrink_bucket t done; end; if t.oversize > Array.length t.table / over_limit then resize t end else if Weak.check bucket i then begin -- cgit v1.2.3 From 5129c5b02bcab1426636d18583ec7a4a46195f0a Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 16:55:03 +0100 Subject: Reduce dependencies of interface files. --- pretyping/nativenorm.mli | 1 - pretyping/patternops.mli | 1 - pretyping/vnorm.mli | 1 - printing/pptacticsig.mli | 2 -- stm/lemmas.mli | 2 -- tactics/auto.mli | 1 - tactics/eauto.mli | 1 - tactics/tacintern.mli | 1 - toplevel/assumptions.mli | 1 - 9 files changed, 11 deletions(-) diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 0352038385..286cb2e079 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -8,7 +8,6 @@ open Term open Environ open Evd -open Nativelambda (** This module implements normalization by evaluation to OCaml code *) diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 0148280287..34191db344 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Term open Globnames open Glob_term diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 9421b2d859..b75fe7c928 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -8,7 +8,6 @@ open Term open Environ -open Evd (** {6 Reduction functions } *) val cbv_vm : env -> constr -> types -> constr diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 01f240f6b8..5b89266553 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -8,11 +8,9 @@ open Pp open Genarg -open Constrexpr open Tacexpr open Ppextend open Environ -open Pattern open Misctypes module type Pp = sig diff --git a/stm/lemmas.mli b/stm/lemmas.mli index e2ddf79df8..93f24b42cb 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -9,8 +9,6 @@ open Names open Term open Decl_kinds -open Constrexpr -open Vernacexpr open Pfedit type 'a declaration_hook diff --git a/tactics/auto.mli b/tactics/auto.mli index eca592ad6b..3e05d88217 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -10,7 +10,6 @@ open Names open Term open Clenv open Pattern -open Evd open Decl_kinds open Hints diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 8e20793c46..985c08f93f 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -8,7 +8,6 @@ open Term open Proof_type -open Evd open Hints val hintbases : hint_db_name list option Pcoq.Gram.entry diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli index a6e28d568d..1124756948 100644 --- a/tactics/tacintern.mli +++ b/tactics/tacintern.mli @@ -12,7 +12,6 @@ open Tacexpr open Genarg open Constrexpr open Misctypes -open Nametab (** Globalization of tactic expressions : Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli index 9c9f81bd2f..f89b395439 100644 --- a/toplevel/assumptions.mli +++ b/toplevel/assumptions.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util open Names open Term open Globnames -- cgit v1.2.3 From d531f81802c0e152e83868f467b46721e65445a9 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 16:55:35 +0100 Subject: Remove duplicate declarations. --- pretyping/reductionops.mli | 1 - tactics/taccoerce.mli | 3 --- 2 files changed, 4 deletions(-) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 43c98bbd47..30c7ded243 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -222,7 +222,6 @@ val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : env -> evar_map -> constr -> rel_context * constr -val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { mP : constr; (** the result type *) diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 0754c15363..56a90e8d5b 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -54,9 +54,6 @@ val coerce_to_ident : bool -> Environ.env -> Value.t -> Id.t val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr -val coerce_to_intro_pattern_naming : - Environ.env -> Value.t -> intro_pattern_naming_expr - val coerce_to_intro_pattern_naming : Environ.env -> Value.t -> intro_pattern_naming_expr -- cgit v1.2.3 From 57c7d751df85366ba3781c4e1107a745a660714d Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 16:56:42 +0100 Subject: Remove duplicate definition. --- tactics/auto.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/tactics/auto.ml b/tactics/auto.ml index 4fb4b32632..e6263f92c0 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -296,9 +296,6 @@ let tclTRY_dbg d tac = (* Papageno : cette fonction a été pas mal simplifiée depuis que la base de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) -let auto_unif_flags = - auto_unif_flags_of full_transparent_state empty_transparent_state false - let flags_of_state st = auto_unif_flags_of st st false -- cgit v1.2.3 From 3049b2930ec2bd4adf886fc90bf01a478b318477 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:01:28 +0100 Subject: Remove some useless module opening. --- lib/hMap.ml | 1 - proofs/proof_global.ml | 10 +++++----- stm/stm.ml | 2 +- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/lib/hMap.ml b/lib/hMap.ml index 8e900cd581..b5fc523150 100644 --- a/lib/hMap.ml +++ b/lib/hMap.ml @@ -333,7 +333,6 @@ struct struct module IntM = Int.Map.Monad(M) module ExtM = Map.Monad(M) - open M let fold f s accu = let ff _ m accu = ExtM.fold f m accu in diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5cfec1b0db..8808dbbacd 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -496,10 +496,10 @@ module Bullet = struct | NoBulletInUse -> None | ProofFinished -> None | Suggest b -> Some ("Focus next goal with bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + ^ Pp.string_of_ppcmds (pr_bullet b) ^".") | Unfinished b -> Some ("The current bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + ^ Pp.string_of_ppcmds (pr_bullet b) ^ " is unfinished.") (* give always a message. *) @@ -508,9 +508,9 @@ module Bullet = struct | NeedClosingBrace -> "Try unfocusing with \"}\"." | NoBulletInUse -> assert false (* This should never raise an error. *) | ProofFinished -> "No more subgoals." - | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " is mandatory here.") - | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) + | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " is not finished.") exception FailedBullet of t * suggestion @@ -519,7 +519,7 @@ module Bullet = struct Errors.register_handler (function | FailedBullet (b,sugg) -> - let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) ^ " : " in + let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " : " in Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg)) | _ -> raise Errors.Unhandled) diff --git a/stm/stm.ml b/stm/stm.ml index e0e7875036..96f127aa24 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1616,7 +1616,7 @@ end = struct (* {{{ *) let vernac_interp switch prev id q = assert(TaskQueue.n_workers (Option.get !queue) > 0); TaskQueue.enqueue_task (Option.get !queue) - QueryTask.({ QueryTask.t_where = prev; t_for = id; t_what = q }, switch) + QueryTask.({ t_where = prev; t_for = id; t_what = q }, switch) let init () = queue := Some (TaskQueue.create (if !Flags.async_proofs_full then 1 else 0)) -- cgit v1.2.3 From 74c29764359272b29af081b30762549777ae8825 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:05:03 +0100 Subject: Remove some useless type declarations. --- ide/ideutils.ml | 2 -- ide/wg_Find.ml | 2 -- library/declare.ml | 3 --- library/keys.ml | 2 -- parsing/egramml.ml | 2 +- 5 files changed, 1 insertion(+), 10 deletions(-) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index ffa07ead7e..51ae76ff54 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -9,8 +9,6 @@ open Preferences -exception Forbidden - let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index a0949ca0c8..dc7071c278 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -type mode = [ `FIND | `REPLACE ] - let b2c = Ideutils.byte_offset_to_char_offset class finder name (view : GText.view) = diff --git a/library/declare.ml b/library/declare.ml index 994a6557ad..c1697a434a 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -417,9 +417,6 @@ let assumption_message id = (** Global universe names, in a different summary *) -type universe_names = - (Univ.universe_level Idmap.t * Id.t Univ.LMap.t) - (* Discharged or not *) type universe_decl = polymorphic * (Id.t * Univ.universe_level) list diff --git a/library/keys.ml b/library/keys.ml index 3d277476f1..6b2466f3de 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -62,8 +62,6 @@ module Keyset = Keymap.Set (* Mapping structure for references to be considered equivalent *) -type keys = Keyset.t Keymap.t - let keys = Summary.ref Keymap.empty ~name:"Keys_decl" let add_kv k v m = diff --git a/parsing/egramml.ml b/parsing/egramml.ml index e95b85bc26..9a380822eb 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -49,7 +49,7 @@ let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = func type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r -let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f | TyNext (rem, tok, Some inj) -> fun f x -> -- cgit v1.2.3 From 3f91296b5cf1dc9097d5368c2df5c6f70a04210c Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:05:56 +0100 Subject: Remove keys for evar and meta, since they cannot occur. --- library/keys.ml | 26 ++++++++++---------------- 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/library/keys.ml b/library/keys.ml index 6b2466f3de..e30cf67175 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -12,35 +12,31 @@ open Globnames open Term open Libobject -type key = +type key = | KGlob of global_reference - | KLam + | KLam | KLet | KProd | KSort - | KEvar - | KCase - | KFix + | KCase + | KFix | KCoFix - | KRel - | KMeta + | KRel module KeyOrdered = struct type t = key let hash gr = match gr with - | KGlob gr -> 10 + RefOrdered.hash gr + | KGlob gr -> 8 + RefOrdered.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 | KSort -> 3 - | KEvar -> 4 - | KCase -> 5 - | KFix -> 6 - | KCoFix -> 7 - | KRel -> 8 - | KMeta -> 9 + | KCase -> 4 + | KFix -> 5 + | KCoFix -> 6 + | KRel -> 7 let compare gr1 gr2 = match gr1, gr2 with @@ -151,12 +147,10 @@ let pr_key pr_global = function | KLet -> str"Let" | KProd -> str"Product" | KSort -> str"Sort" - | KEvar -> str"Evar" | KCase -> str"Case" | KFix -> str"Fix" | KCoFix -> str"CoFix" | KRel -> str"Rel" - | KMeta -> str"Meta" let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) -- cgit v1.2.3 From 80bbdf335be5657f5ab33b4aa02e21420d341de2 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:11:03 +0100 Subject: Remove some unused functions. Note: they do not even seem to have a debugging purpose, so better remove them before they bitrot. --- engine/proofview_monad.ml | 5 ----- ide/coq.ml | 5 ----- ide/document.ml | 6 ------ ide/wg_ProofView.ml | 13 ------------- interp/constrextern.ml | 9 --------- interp/constrintern.ml | 13 ------------- kernel/declareops.ml | 2 -- kernel/nativevalues.ml | 27 --------------------------- kernel/safe_typing.ml | 7 ------- kernel/term.ml | 11 ----------- lib/heap.ml | 2 -- library/loadpath.ml | 4 ---- pretyping/evarsolve.ml | 15 --------------- pretyping/pretyping.ml | 14 -------------- pretyping/tacred.ml | 6 ------ printing/ppconstr.ml | 2 -- printing/pptactic.ml | 5 ----- proofs/redexpr.ml | 2 -- stm/asyncTaskQueue.ml | 4 +--- tactics/auto.ml | 3 --- tactics/class_tactics.ml | 8 -------- tactics/hints.ml | 21 --------------------- tactics/tacinterp.ml | 3 --- 23 files changed, 1 insertion(+), 186 deletions(-) diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index a9faf0a833..88c5925ceb 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -108,11 +108,6 @@ module Info = struct and compress f = CList.map_filter compress_tree f - let rec is_empty = let open Trace in function - | Seq(Dispatch,brs) -> List.for_all is_empty brs - | Seq(DBranch,br) -> List.for_all is_empty br - | _ -> false - (** [with_sep] is [true] when [Tactic m] must be printed with a trailing semi-colon. *) let rec pr_tree with_sep = let open Trace in function diff --git a/ide/coq.ml b/ide/coq.ml index a60f327b4f..268a95a336 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -99,9 +99,6 @@ let display_coqtop_answer cmd lines = "Command was: "^cmd^"\n"^ "Answer was: "^(String.concat "\n " lines)) -let check_remaining_opt arg = - if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg) - let rec filter_coq_opts args = let argstr = String.concat " " (List.map Filename.quote args) in let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in @@ -200,8 +197,6 @@ module GlibMainLoop = struct let read_all = Ideutils.io_read_all let async_chan_of_file fd = Glib.Io.channel_of_descr fd let async_chan_of_socket s = !gio_channel_of_descr_socket s - let add_timeout ~sec callback = - ignore(Glib.Timeout.add ~ms:(sec * 1000) ~callback) end module CoqTop = Spawn.Async(GlibMainLoop) diff --git a/ide/document.ml b/ide/document.ml index 41d5a7564b..bb431e7914 100644 --- a/ide/document.ml +++ b/ide/document.ml @@ -124,12 +124,6 @@ let context d = let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in List.map (flat pair true) top, List.map (flat pair true) bot -let iter d f = - let a, s, b = to_lists d in - List.iter (flat f false) a; - List.iter (flat f true) s; - List.iter (flat f false) b - let stateid_opt_equal = Option.equal Stateid.equal let is_in_focus d id = diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 148add6e9c..642a577878 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -114,19 +114,6 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with (Some Tags.Proof.goal))); ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) -let mode_cesar (proof : #GText.view_skel) = function - | [] -> assert false - | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ -> - proof#buffer#insert " *** Declarative Mode ***\n"; - List.iter - (fun hyp -> insert_xml proof#buffer hyp; proof#buffer#insert "\n") - hyps; - proof#buffer#insert "______________________________________\n"; - proof#buffer#insert "thesis := \n "; - insert_xml proof#buffer cur_goal; - proof#buffer#insert "\n"; - ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT)) - let rec flatten = function | [] -> [] | (lg, rg) :: l -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index ed85c38de0..5c9e80df3d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -462,15 +462,6 @@ let is_needed_for_correct_partial_application tail imp = exception Expl -let params_implicit n impl = - let rec aux n impl = - if n == 0 then true - else match impl with - | [] -> false - | imp :: impl when is_status_implicit imp -> aux (pred n) impl - | _ -> false - in aux n impl - (* Implicit args indexes are in ascending order *) (* inctx is useful only if there is a last argument to be deduced from ctxt *) let explicitize loc inctx impl (cf,f) args = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index d4cb797759..f9de8c4663 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -698,19 +698,6 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = (* [id] a goal variable *) GVar (loc,id), [], [], [] -let proj_impls r impls = - let env = Global.env () in - let f (x, l) = x, projection_implicits env r l in - List.map f impls - -let proj_scopes n scopes = - List.skipn_at_least n scopes - -let proj_impls_scopes p impls scopes = - match p with - | Some (r, n) -> proj_impls r impls, proj_scopes n scopes - | None -> impls, scopes - let find_appl_head_data c = match c with | GRef (loc,ref,_) as x -> diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 73cfd01221..803df78270 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -391,5 +391,3 @@ and hcons_module_body mb = mod_delta = delta'; mod_retroknowledge = retroknowledge'; } - -and hcons_module_type_body mtb = hcons_module_body mtb diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 40bef4bc67..6e097b6133 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -78,8 +78,6 @@ let accumulate_code (k:accumulator) (x:t) = let rec accumulate (x:t) = accumulate_code (Obj.magic accumulate) x -let raccumulate = ref accumulate - let mk_accu_gen rcode (a:atom) = (* Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *) let r = Obj.new_block 0 3 in @@ -160,31 +158,6 @@ let is_accu x = let o = Obj.repr x in Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag -(*let accumulate_fix_code (k:accumulator) (a:t) = - match atom_of_accu k with - | Afix(frec,_,rec_pos,_,_) -> - let nargs = accu_nargs k in - if nargs <> rec_pos || is_accu a then - accumulate_code k a - else - let r = ref frec in - for i = 0 to nargs - 1 do - r := !r (arg_of_accu k i) - done; - !r a - | _ -> assert false - - -let rec accumulate_fix (x:t) = - accumulate_fix_code (Obj.magic accumulate_fix) x - -let raccumulate_fix = ref accumulate_fix *) - -let is_atom_fix (a:atom) = - match a with - | Afix _ -> true - | _ -> false - let mk_fix_accu rec_pos pos types bodies = mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos)) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index c7ab6491d7..33aa2972b2 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -222,13 +222,6 @@ let inline_private_constants_in_constr = Term_typing.inline_side_effects let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x) -let constant_entry_of_private_constant = function - | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } -> - [ kn, Term_typing.constant_entry_of_side_effect cb eff_env ] - | { Entries.eff = Entries.SEscheme (l,_) } -> - List.map (fun (_,kn,cb,eff_env) -> - kn, Term_typing.constant_entry_of_side_effect cb eff_env) l - let private_con_of_con env c = let cbo = Environ.lookup_constant c env.env in { Entries.from_env = Ephemeron.create env.revstruct; diff --git a/kernel/term.ml b/kernel/term.ml index 455248dd52..2060c7b6e9 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -486,8 +486,6 @@ let lambda_applist c l = let lambda_appvect c v = lambda_applist c (Array.to_list v) -let lambda_app c a = lambda_applist c [a] - let lambda_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then @@ -501,15 +499,6 @@ let lambda_applist_assum n c l = let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) -(* pseudo-reduction rule: - * [prod_app s (Prod(_,B)) N --> B[N] - * with an strip_outer_cast on the first argument to produce a product *) - -let prod_app t n = - match kind_of_term (strip_outer_cast t) with - | Prod (_,_,b) -> subst1 n b - | _ -> anomaly (str"Needed a product, but didn't find one") - (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist c l = let rec app subst c l = diff --git a/lib/heap.ml b/lib/heap.ml index a19bc0d1c3..5682b87bb6 100644 --- a/lib/heap.ml +++ b/lib/heap.ml @@ -62,8 +62,6 @@ module Functional(X : Ordered) = struct let empty = Leaf - let is_empty t = t = Leaf - let rec add x = function | Leaf -> Node (Leaf, x, Leaf) diff --git a/library/loadpath.ml b/library/loadpath.ml index 16b4194544..f77bd1ef53 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -84,10 +84,6 @@ let add_load_path phys_path coq_path ~implicit = end | _ -> anomaly_too_many_paths phys_path -let extend_path_with_dirpath p dir = - List.fold_left Filename.concat p - (List.rev_map Id.to_string (DirPath.repr dir)) - let filter_path f = let rec aux = function | [] -> [] diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index fe26dcd282..69e8e9d988 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1007,21 +1007,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = * Note: argument f is the function used to instantiate evars. *) -let are_canonical_instances args1 args2 env = - let n1 = Array.length args1 in - let n2 = Array.length args2 in - let rec aux n = function - | (id,_,c)::sign - when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) -> - aux (n+1) sign - | [] -> - let rec aux2 n = - Int.equal n n1 || - (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1)) - in aux2 n - | _ -> false in - Int.equal n1 n2 && aux 0 (named_context env) - let filter_compatible_candidates conv_algo env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match conv_algo env evd Reduction.CONV rhs c' with diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f5b89e7895..7d54969171 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -444,26 +444,12 @@ let new_type_evar env evdref loc = univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref in e -let get_projection env cst = - let cb = lookup_constant cst env in - match cb.Declarations.const_proj with - | Some {Declarations.proj_ind = mind; proj_npars = n; - proj_arg = m; proj_type = ty} -> - (cst,mind,n,m,ty) - | None -> raise Not_found - let (f_genarg_interp, genarg_interp_hook) = Hook.make () (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) -let is_GHole = function - | GHole _ -> true - | _ -> false - -let evars = ref Id.Map.empty - let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t = let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in let pretype_type = pretype_type k0 resolve_tc in diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 48911a5a9f..31e75e5508 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -940,8 +940,6 @@ let matches_head env sigma c t = | Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p)) | _ -> raise Constr_matching.PatternMatchingFailure -let is_pattern_meta = function Pattern.PMeta _ -> true | _ -> false - (** FIXME: Specific function to handle projections: it ignores what happens on the parameters. This is a temporary fix while rewrite etc... are not up to equivalence of the projection and its eta expanded form. @@ -1055,10 +1053,6 @@ let unfold env sigma name = else error (string_of_evaluable_ref env name^" is opaque.") -let is_projection env = function - | EvalVarRef _ -> false - | EvalConstRef c -> Environ.is_projection c env - (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)] * Unfolds the constant name in a term c following a list of occurrences occl. * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences. diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index d15c3ee2f1..c07057a096 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -136,8 +136,6 @@ end) = struct let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c) - let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" - let pr_univ l = match l with | [_,x] -> str x diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 7800f1edb3..a5716279f3 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -685,11 +685,6 @@ module Make | l -> spc () ++ hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) - let string_of_debug = function - | Off -> "" - | Debug -> "debug " - | Info -> "info_" - let pr_then () = str ";" let ltop = (5,E) diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index be92f2b04c..89ecdb0df2 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -158,8 +158,6 @@ let make_flag env f = f.rConst red in red -let is_reference = function PRef _ | PVar _ -> true | _ -> false - (* table of custom reductino fonctions, not synchronized, filled via ML calls to [declare_reduction] *) let reduction_tab = ref String.Map.empty diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index e525031e63..863bab7cc9 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -60,9 +60,7 @@ module Make(T : Task) = struct type more_data = | MoreDataUnivLevel of Univ.universe_level list - - let request_expiry_of_task (t, c) = T.request_of_task t, c - + let slave_respond (Request r) = let res = T.perform r in Response res diff --git a/tactics/auto.ml b/tactics/auto.ml index e6263f92c0..d6552920f4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -67,9 +67,6 @@ let auto_unif_flags_of st1 st2 useeager = let auto_unif_flags = auto_unif_flags_of full_transparent_state empty_transparent_state false -let auto_flags_of_state st = - auto_unif_flags_of full_transparent_state st false - (* Try unification with the precompiled clause, then use registered Apply *) let connect_hint_clenv poly (c, _, ctx) clenv gl = diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 4f0ffa024e..8cd7b1ad60 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -569,14 +569,6 @@ let rec fix_limit limit (t : 'a tac) : 'a tac = if Int.equal limit 0 then fail_tac ReachedLimit else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } -let fix_iterative' t = - let rec aux depth = - { skft = fun sk fk gls -> - (fix_limit depth t).skft sk - (function NotApplicable as e -> fk e - | ReachedLimit -> (aux (succ depth)).skft sk fk gls) gls } - in aux 1 - let fix_iterative t = let rec aux depth = or_else_tac (fix_limit depth t) diff --git a/tactics/hints.ml b/tactics/hints.ml index 6d623f1c34..8d8b5fcc67 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -154,27 +154,6 @@ let fresh_key = in KerName.make mp dir (Label.of_id lbl) -let eq_hints_path_atom p1 p2 = match p1, p2 with -| PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 -| PathAny, PathAny -> true -| (PathHints _ | PathAny), _ -> false - -let eq_auto_tactic t1 t2 = match t1, t2 with -| Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2 -| ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2 -| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2 -| Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2 -| Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2 -| Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *) -| (Res_pf _ | ERes_pf _ | Give_exact _ | Res_pf_THEN_trivial_fail _ - | Unfold_nth _ | Extern _), _ -> false - -let eq_hint_metadata t1 t2 = - Int.equal t1.pri t2.pri && - Option.equal constr_pattern_eq t1.pat t2.pat && - eq_hints_path_atom t1.name t2.name && - eq_auto_tactic t1.code t2.code - let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) = let d = pri1 - pri2 in if Int.equal d 0 then id2 - id1 diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index a871815881..5450a00f4f 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1115,9 +1115,6 @@ let rec read_match_rule lfun ist env sigma = function (* misc *) -let mk_hyp_value ist env sigma c = - (mkVar (interp_hyp ist env sigma c)) - let interp_focussed wit f v = Ftactic.nf_enter begin fun gl -> let v = Genarg.out_gen (glbwit wit) v in -- cgit v1.2.3 From 5d26829704b2602ede45183cba54ab219e453c0e Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Sat, 2 Jan 2016 17:57:06 +0100 Subject: Use streams rather than strings to handle bullet suggestions. --- printing/printer.ml | 4 ++-- proofs/proof_global.ml | 32 +++++++++++++------------------- proofs/proof_global.mli | 4 ++-- proofs/proofview.ml | 7 +++---- proofs/proofview.mli | 2 +- 5 files changed, 21 insertions(+), 28 deletions(-) diff --git a/printing/printer.ml b/printing/printer.ml index 7c031ea536..b6dda93c22 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -639,8 +639,8 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = | _ , _, _ -> let end_cmd = str "This subproof is complete, but there are some unfocused goals." ++ - (match Proof_global.Bullet.suggest p - with None -> str"" | Some s -> fnl () ++ str s) ++ + (let s = Proof_global.Bullet.suggest p in + if Pp.is_empty s then s else fnl () ++ s) ++ fnl () in pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 8808dbbacd..22aab6585c 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -466,7 +466,7 @@ module Bullet = struct type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> std_ppcmds } let behaviors = Hashtbl.create 4 @@ -476,7 +476,7 @@ module Bullet = struct let none = { name = "None"; put = (fun x _ -> x); - suggest = (fun _ -> None) + suggest = (fun _ -> mt ()) } let _ = register_behavior none @@ -492,26 +492,20 @@ module Bullet = struct (* give a message only if more informative than the standard coq message *) let suggest_on_solved_goal sugg = match sugg with - | NeedClosingBrace -> Some "Try unfocusing with \"}\"." - | NoBulletInUse -> None - | ProofFinished -> None - | Suggest b -> Some ("Focus next goal with bullet " - ^ Pp.string_of_ppcmds (pr_bullet b) - ^".") - | Unfinished b -> Some ("The current bullet " - ^ Pp.string_of_ppcmds (pr_bullet b) - ^ " is unfinished.") + | NeedClosingBrace -> str"Try unfocusing with \"}\"." + | NoBulletInUse -> mt () + | ProofFinished -> mt () + | Suggest b -> str"Focus next goal with bullet " ++ pr_bullet b ++ str"." + | Unfinished b -> str"The current bullet " ++ pr_bullet b ++ str" is unfinished." (* give always a message. *) let suggest_on_error sugg = match sugg with - | NeedClosingBrace -> "Try unfocusing with \"}\"." + | NeedClosingBrace -> str"Try unfocusing with \"}\"." | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> "No more subgoals." - | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (pr_bullet b) - ^ " is mandatory here.") - | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (pr_bullet b) - ^ " is not finished.") + | ProofFinished -> str"No more subgoals." + | Suggest b -> str"Bullet " ++ pr_bullet b ++ str" is mandatory here." + | Unfinished b -> str"Current bullet " ++ pr_bullet b ++ str" is not finished." exception FailedBullet of t * suggestion @@ -519,8 +513,8 @@ module Bullet = struct Errors.register_handler (function | FailedBullet (b,sugg) -> - let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (pr_bullet b) ^ " : " in - Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg)) + let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in + Errors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg) | _ -> raise Errors.Unhandled) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 5f11589508..5d89044c3d 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -172,7 +172,7 @@ module Bullet : sig type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> Pp.std_ppcmds } (** A registered behavior can then be accessed in Coq @@ -189,7 +189,7 @@ module Bullet : sig (** Handles focusing/defocusing with bullets: *) val put : Proof.proof -> t -> Proof.proof - val suggest : Proof.proof -> string option + val suggest : Proof.proof -> Pp.std_ppcmds end diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 9ee7df14c8..e01bed5dad 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -353,7 +353,7 @@ exception NoSuchGoals of int (* This hook returns a string to be appended to the usual message. Primarily used to add a suggestion about the right bullet to use to focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> string option) ref = ref ((fun n -> None)) +let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) let set_nosuchgoals_hook f = nosuchgoals_hook := f @@ -361,10 +361,9 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f (* This uses the hook above *) let _ = Errors.register_handler begin function | NoSuchGoals n -> - let suffix:string option = (!nosuchgoals_hook) n in + let suffix = !nosuchgoals_hook n in Errors.errorlabstrm "" - (str "No such " ++ str (String.plural n "goal") ++ str "." - ++ pr_opt str suffix) + (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) | _ -> raise Errors.Unhandled end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index a92abcbbf1..96fe474f66 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -235,7 +235,7 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic This hook is used to add a suggestion about bullets when applicable. *) exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> string option) -> unit +val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit val tclFOCUS : int -> int -> 'a tactic -> 'a tactic -- cgit v1.2.3 From e5f5ea2da95297fefe1afebfe303c5d5ba7d41aa Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 4 Jan 2016 15:38:34 +0100 Subject: workers: purge short version of -load-vernac too (fix #4458) --- stm/asyncTaskQueue.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index e3fb0b607a..222f02c007 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -125,8 +125,9 @@ module Make(T : Task) = struct "-async-proofs-worker-priority"; Flags.string_of_priority !Flags.async_proofs_worker_priority] | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | ("-async-proofs" |"-toploop" |"-vi2vo" |"-compile" - |"-load-vernac-source" |"-compile-verbose" + | ("-async-proofs" |"-toploop" |"-vi2vo" + |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" + |"-compile" |"-compile-verbose" |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> set_slave_opt tl | x::tl -> x :: set_slave_opt tl in -- cgit v1.2.3 From d2b468a87cc50b1558feffc6cd3e1b866205c684 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 4 Jan 2016 16:00:11 +0100 Subject: par: check if the goal is not ground and fail (fix #4465) --- stm/stm.ml | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index 14142aa0c5..3d007004e2 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1471,17 +1471,29 @@ end = struct (* {{{ *) try Reach.known_state ~cache:`No id; let t, uc = Future.purify (fun () -> + let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in + let g = Evd.find sigma0 r_goal in + if not ( + Evarutil.is_ground_term sigma0 Evd.(evar_concl g) && + List.for_all (fun (_,bo,ty) -> + Evarutil.is_ground_term sigma0 ty && + Option.cata (Evarutil.is_ground_term sigma0) true bo) + Evd.(evar_context g)) + then + Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^ + "goals only")) + else begin vernac_interp r_state_fb r_ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> Errors.errorlabstrm "Stm" (str "no progress") | Evd.Evar_defined t -> - let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then t, Evd.evar_universe_context sigma - else Errors.errorlabstrm "Stm" (str"The solution is not ground")) - () in - RespBuiltSubProof (t,uc) + else Errors.errorlabstrm "Stm" (str"The solution is not ground") + end) () + in + RespBuiltSubProof (t,uc) with e when Errors.noncritical e -> RespError (Errors.print e) let name_of_task { t_name } = t_name -- cgit v1.2.3 From bb9acba7cfe83ba3a5116b0e7aa78ac7f1219f60 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 4 Jan 2016 16:55:44 +0100 Subject: Fix handling of side-effects in case of `Opaque side-effects as well. --- kernel/term_typing.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 74c2e7da37..aa60432a7e 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -429,9 +429,11 @@ let export_side_effects mb env ce = Environ.push_context ~strict:true cb.const_universes env else env | kn, cb, `Opaque(_, ctx), _ -> - let env = Environ.add_constant kn cb env in - Environ.push_context_set - ~strict:(not cb.const_polymorphic) ctx env in + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + let env = Environ.push_context ~strict:true cb.const_universes env in + Environ.push_context_set ~strict:true ctx env + else env in let rec translate_seff sl seff acc env = match sl, seff with | _, [] -> List.rev acc, ce -- cgit v1.2.3 From 456e2be8af1d4a0cf2461d62dc5e1b4b24b2a552 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Mon, 4 Jan 2016 18:04:18 +0100 Subject: Extraction: msg_notice instead of msg_info. --- plugins/extraction/extract_env.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 9964280336..657a91c0c1 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -542,7 +542,7 @@ let print_structure_to_file (fn,si,mo) dry struc = (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) if not (Int.equal (Buffer.length buf) 0) then begin - Pp.msg_info (str (Buffer.contents buf)); + Pp.msg_notice (str (Buffer.contents buf)); Buffer.reset buf end @@ -636,7 +636,7 @@ let simple_extraction r = in let ans = flag ++ print_one_decl struc (modpath_of_r r) d in reset (); - Pp.msg_info ans + Pp.msg_notice ans | _ -> assert false -- cgit v1.2.3 From 08fdf3c7361c75037e12c5cd0e9f965165fed498 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 4 Jan 2016 21:19:50 +0100 Subject: fixup d2b468a, evar normalization is needed --- stm/stm.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/stm/stm.ml b/stm/stm.ml index 3d007004e2..168d8bf084 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1488,6 +1488,7 @@ end = struct (* {{{ *) match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> Errors.errorlabstrm "Stm" (str "no progress") | Evd.Evar_defined t -> + let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then t, Evd.evar_universe_context sigma else Errors.errorlabstrm "Stm" (str"The solution is not ground") -- cgit v1.2.3 From e4a682e2f2c91fac47f55cd8619af2321b2e4c30 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 8 Dec 2015 12:49:01 +0100 Subject: COMMENTS: Predicate In the original version, ocamldoc markup wasn't used properly thus ocamldoc output did not in all places make sense. This commit makes sure that the documentation of the Predicate module is as clear as the documentation of the Set module (in the standard library). --- lib/predicate.ml | 9 +++--- lib/predicate.mli | 85 +++++++++++++++++++++++++++++++++---------------------- 2 files changed, 56 insertions(+), 38 deletions(-) diff --git a/lib/predicate.ml b/lib/predicate.ml index a60b3dadd4..1aa7db6af1 100644 --- a/lib/predicate.ml +++ b/lib/predicate.ml @@ -10,8 +10,6 @@ (* *) (************************************************************************) -(* Sets over ordered types *) - module type OrderedType = sig type t @@ -43,9 +41,10 @@ module Make(Ord: OrderedType) = struct module EltSet = Set.Make(Ord) - (* when bool is false, the denoted set is the complement of - the given set *) type elt = Ord.t + + (* (false, s) represents a set which is equal to the set s + (true, s) represents a set which is equal to the complement of set s *) type t = bool * EltSet.t let elements (b,s) = (b, EltSet.elements s) @@ -84,6 +83,7 @@ module Make(Ord: OrderedType) = let diff s1 s2 = inter s1 (complement s2) + (* assumes the set is infinite *) let subset s1 s2 = match (s1,s2) with ((false,p1),(false,p2)) -> EltSet.subset p1 p2 @@ -91,6 +91,7 @@ module Make(Ord: OrderedType) = | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2) | ((true,_),(false,_)) -> false + (* assumes the set is infinite *) let equal (b1,s1) (b2,s2) = b1=b2 && EltSet.equal s1 s2 diff --git a/lib/predicate.mli b/lib/predicate.mli index bcc89e7275..cee3b0bd39 100644 --- a/lib/predicate.mli +++ b/lib/predicate.mli @@ -1,67 +1,84 @@ +(** Infinite sets over a chosen [OrderedType]. -(** Module [Pred]: sets over infinite ordered types with complement. *) - -(** This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses the Set library. *) + All operations over sets are purely applicative (no side-effects). + *) +(** Input signature of the functor [Make]. *) module type OrderedType = sig type t - val compare: t -> t -> int + (** The type of the elements in the set. + + The chosen [t] {b must be infinite}. *) + + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that: + - [f e1 e2] is zero if the elements [e1] and [e2] are equal, + - [f e1 e2] is strictly negative if [e1] is smaller than [e2], + - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + *) end - (** The input signature of the functor [Pred.Make]. - [t] is the type of the set elements. - [compare] is a total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is - the generic structural comparison function [compare]. *) module type S = sig type elt - (** The type of the set elements. *) + (** The type of the elements in the set. *) + type t - (** The type of sets. *) + (** The type of sets. *) + val empty: t - (** The empty set. *) + (** The empty set. *) + val full: t - (** The whole type. *) + (** The set of all elements (of type [elm]). *) + val is_empty: t -> bool - (** Test whether a set is empty or not. *) + (** Test whether a set is empty or not. *) + val is_full: t -> bool - (** Test whether a set contains the whole type or not. *) + (** Test whether a set contains the whole type or not. *) + val mem: elt -> t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) + (** [mem x s] tests whether [x] belongs to the set [s]. *) + val singleton: elt -> t - (** [singleton x] returns the one-element set containing only [x]. *) + (** [singleton x] returns the one-element set containing only [x]. *) + val add: elt -> t -> t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], then [s] is returned unchanged. *) + val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) + except [x]. If [x] was not in [s], then [s] is returned unchanged. *) + val union: t -> t -> t + (** Set union. *) + val inter: t -> t -> t + (** Set intersection. *) + val diff: t -> t -> t + (** Set difference. *) + val complement: t -> t - (** Union, intersection, difference and set complement. *) + (** Set complement. *) + val equal: t -> t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) + the set [s2]. *) + val elements: t -> bool * elt list (** Gives a finite representation of the predicate: if the boolean is false, then the predicate is given in extension. if it is true, then the complement is given *) end -module Make(Ord: OrderedType): (S with type elt = Ord.t) - (** Functor building an implementation of the set structure - given a totally ordered type. *) +(** The [Make] functor constructs an implementation for any [OrderedType]. *) +module Make (Ord : OrderedType) : (S with type elt = Ord.t) -- cgit v1.2.3 From 8a9445fbf65d4ddf2c96348025d487b4d54a5d01 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 5 Jan 2016 19:36:02 +0100 Subject: Fix order of files in mllib. CString was linked after Serialize, although the later was using CString.equal. This had not been noticed so far because OCaml was ignoring functions marked as external in interfaces (which is the case of CString.equal) when considering link dependencies. This was changed on the OCaml side as part of the fix of PR#6956, so linking was now failing in several places. --- Makefile.build | 5 +++-- checker/check.mllib | 4 ++-- dev/printers.mllib | 4 ++-- grammar/grammar.mllib | 4 ++-- lib/clib.mllib | 4 ++-- 5 files changed, 11 insertions(+), 10 deletions(-) diff --git a/Makefile.build b/Makefile.build index 00ff6a7a4c..56fc5f0c7d 100644 --- a/Makefile.build +++ b/Makefile.build @@ -294,9 +294,10 @@ checker/check.cmxa: | md5chk checker/check.mllib.d # Csdp to micromega special targets ########################################################################### -plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) +plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) \ + $(addsuffix $(BESTLIB), lib/clib) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,nums unix) + $(HIDE)$(call bestocaml,,nums unix clib) ########################################################################### # CoqIde special targets diff --git a/checker/check.mllib b/checker/check.mllib index 49ca6bf051..0d36e3a0f1 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -17,6 +17,8 @@ Flags Control Pp_control Loc +CList +CString Serialize Stateid Feedback @@ -25,8 +27,6 @@ Segmenttree Unicodetable Unicode CObj -CList -CString CArray CStack Util diff --git a/dev/printers.mllib b/dev/printers.mllib index 07b48ed573..eeca6809ae 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -16,6 +16,8 @@ Backtrace IStream Pp_control Loc +CList +CString Compat Flags Control @@ -28,8 +30,6 @@ Segmenttree Unicodetable Unicode CObj -CList -CString CArray CStack Util diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 60ea0df026..71e5b8ae2c 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -16,13 +16,13 @@ Backtrace Pp_control Flags Loc +CList +CString Serialize Stateid Feedback Pp -CList -CString CArray CStack Util diff --git a/lib/clib.mllib b/lib/clib.mllib index 7ff1d29359..9c9607abdb 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -18,11 +18,11 @@ Pp_control Flags Control Loc +CList +CString Serialize Deque CObj -CList -CString CArray CStack Util -- cgit v1.2.3 From 64487121a35628512c1bd1b4e7039132f84ab270 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 5 Jan 2016 19:41:08 +0100 Subject: Avoid warning 31: test printer was linked twice with Dynlink and Str. Linking a module twice is unsafe and warning 31 will be fatal by default in OCaml 4.03. See PR#5461. --- Makefile.build | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Makefile.build b/Makefile.build index 56fc5f0c7d..d9090197a2 100644 --- a/Makefile.build +++ b/Makefile.build @@ -132,10 +132,11 @@ SYSMOD:=str unix dynlink threads SYSCMA:=$(addsuffix .cma,$(SYSMOD)) SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD)) +# We do not repeat the dependencies already in SYSMOD here ifeq ($(CAMLP4),camlp5) -P4CMA:=gramlib.cma str.cma +P4CMA:=gramlib.cma else -P4CMA:=dynlink.cma camlp4lib.cma str.cma +P4CMA:=camlp4lib.cma endif -- cgit v1.2.3 From ffc135337b479349a9e94c0da0a87531cf0684fa Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 5 Jan 2016 19:48:32 +0100 Subject: Disable warning 31 when generating coqtop from coqmktop. In OCaml 3.x, the toploop of OCaml was accessible from toplevellib.cma. In OCaml 4.x, it was replaced by compiler-libs. However, linking with compiler-libs produces a warning (fatal with OCaml 4.03) as soon as we have a file named errors.ml or lexer.ml... The only satisfactory solution seems to be to "pack" compiler libs. But it is not done currently in the OCaml distribution, and implementing it in coqmktop at this point would be too risky. So for now, I am disabling the warning until we hear from the OCaml team. In principle, this clash of modules names can break OCaml's type safety, so we are living dangerously. --- tools/coqmktop.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index be796e6956..e29cf60e36 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -280,7 +280,7 @@ let main () = (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - With the coq .cma, we MUST use the -linkall option. *) let args = - "-linkall" :: "-rectypes" :: flags @ copts @ options @ + "-linkall" :: "-rectypes" :: "-w" :: "-31" :: flags @ copts @ options @ (std_includes basedir) @ tolink @ [ main_file ] @ topstart in if !echo then begin -- cgit v1.2.3 From 23cbf43f353c50fa72b72d694611c5c14367cea2 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 6 Jan 2016 00:58:42 +0100 Subject: Protect code against changes in Map interface. The Map interface of upcoming OCaml 4.03 includes a new union operator. In order to make our homemade implementation of Maps compatible with OCaml versions from 3.12 to 4.03, we define our own signatures for Maps. --- checker/univ.mli | 2 +- kernel/names.mli | 10 +++++----- lib/cMap.ml | 2 +- lib/cMap.mli | 2 +- lib/cSig.mli | 31 +++++++++++++++++++++++++++++++ library/goptions.mli | 2 +- library/libnames.mli | 2 +- plugins/cc/ccalgo.mli | 6 +++--- plugins/extraction/table.mli | 2 +- plugins/firstorder/sequent.mli | 2 +- 10 files changed, 46 insertions(+), 15 deletions(-) diff --git a/checker/univ.mli b/checker/univ.mli index 02c1bbdb91..f3216feac4 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -130,7 +130,7 @@ val check_constraints : constraints -> universes -> bool (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) -module LMap : Map.S with type key = universe_level +module LMap : CSig.MapS with type key = universe_level module LSet : CSig.SetS with type elt = universe_level type 'a universe_map = 'a LMap.t diff --git a/kernel/names.mli b/kernel/names.mli index 7cc4443752..59419af2ef 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -395,7 +395,7 @@ end module Mindset : CSig.SetS with type elt = MutInd.t module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset -module Mindmap_env : Map.S with type key = MutInd.t +module Mindmap_env : CSig.MapS with type key = MutInd.t (** Beware: first inductive has index 0 *) type inductive = MutInd.t * int @@ -403,10 +403,10 @@ type inductive = MutInd.t * int (** Beware: first constructor has index 1 *) type constructor = inductive * int -module Indmap : Map.S with type key = inductive -module Constrmap : Map.S with type key = constructor -module Indmap_env : Map.S with type key = inductive -module Constrmap_env : Map.S with type key = constructor +module Indmap : CSig.MapS with type key = inductive +module Constrmap : CSig.MapS with type key = constructor +module Indmap_env : CSig.MapS with type key = inductive +module Constrmap_env : CSig.MapS with type key = constructor val ind_modpath : inductive -> ModPath.t val constr_modpath : constructor -> ModPath.t diff --git a/lib/cMap.ml b/lib/cMap.ml index cf590d96c3..048a690812 100644 --- a/lib/cMap.ml +++ b/lib/cMap.ml @@ -16,7 +16,7 @@ module type S = Map.S module type ExtS = sig - include Map.S + include CSig.MapS module Set : CSig.SetS with type elt = key val update : key -> 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t diff --git a/lib/cMap.mli b/lib/cMap.mli index 23d3801e08..9d0fbbad24 100644 --- a/lib/cMap.mli +++ b/lib/cMap.mli @@ -18,7 +18,7 @@ module type S = Map.S module type ExtS = sig - include Map.S + include CSig.MapS (** The underlying Map library *) module Set : CSig.SetS with type elt = key diff --git a/lib/cSig.mli b/lib/cSig.mli index 2a8bda2936..e095c82cb0 100644 --- a/lib/cSig.mli +++ b/lib/cSig.mli @@ -45,3 +45,34 @@ sig end (** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml documentation for more information. *) + +module type MapS = +sig + type key + type (+'a) t + val empty: 'a t + val is_empty: 'a t -> bool + val mem: key -> 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove: key -> 'a t -> 'a t + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: (key -> 'a -> bool) -> 'a t -> bool + val exists: (key -> 'a -> bool) -> 'a t -> bool + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find: key -> 'a t -> 'a + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t +end diff --git a/library/goptions.mli b/library/goptions.mli index 9d87c14c50..25b5315c2a 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -133,7 +133,7 @@ val declare_stringopt_option: string option option_sig -> string option write_fu (** {6 Special functions supposed to be used only in vernacentries.ml } *) -module OptionMap : Map.S with type key = option_name +module OptionMap : CSig.MapS with type key = option_name val get_string_table : option_name -> diff --git a/library/libnames.mli b/library/libnames.mli index b95c088715..c72f517532 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -60,7 +60,7 @@ val path_of_string : string -> full_path val string_of_path : full_path -> string val pr_path : full_path -> std_ppcmds -module Spmap : Map.S with type key = full_path +module Spmap : CSig.MapS with type key = full_path val restrict_path : int -> full_path -> full_path diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 0dcf3a870f..34c19958a9 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -20,8 +20,8 @@ type pa_fun= fnargs:int} -module PafMap : Map.S with type key = pa_fun -module PacMap : Map.S with type key = pa_constructor +module PafMap : CSig.MapS with type key = pa_fun +module PacMap : CSig.MapS with type key = pa_constructor type cinfo = {ci_constr: pconstructor; (* inductive type *) @@ -185,7 +185,7 @@ val empty_forest: unit -> forest (*type pa_constructor -module PacMap:Map.S with type key=pa_constructor +module PacMap:CSig.MapS with type key=pa_constructor type term = Symb of Term.constr diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 916cf3ad6b..4e638a0ace 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -13,7 +13,7 @@ open Miniml open Declarations module Refset' : CSig.SetS with type elt = global_reference -module Refmap' : Map.S with type key = global_reference +module Refmap' : CSig.MapS with type key = global_reference val safe_basename_of_global : global_reference -> Id.t diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index dc3f05be69..760168c9f6 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -13,7 +13,7 @@ open Globnames module OrderedConstr: Set.OrderedType with type t=constr -module CM: Map.S with type key=constr +module CM: CSig.MapS with type key=constr type h_item = global_reference * (int*constr) option -- cgit v1.2.3 From 8b5d02d8706f99015c2ce8efcad32b7af228dd53 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 6 Jan 2016 11:32:31 +0100 Subject: Prevent coq_makefile from parsing project files in the reverse order. (Fix bug #4477) The bug was a bit subtle. Function process_cmd_line can be called in three different ways: 1. tail-recursively to accumulate parsed options in reverse order, 2. directly to parse a file (coqide) or a command line (coq_makefile), 3. recursively to handle a "-f" option. Once its execution finished, the function reversed its accumulator so that the parsed options are in correct order. Due to the third case, this means that the final local order of options was depending on the parity of the depth of "-f" options. This commit fixes it by changing the function so that the recursive call gets the actual accumulator rather than its reversed version. Warning: this will break all the projects that were inadvertently (or not) relying on the bug. This might also require a further commit if coq_makefile itself was relying on the bug. --- ide/project_file.ml4 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index 152f76cc0e..07ab5344d2 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -48,7 +48,7 @@ let parse f = res let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function - | [] -> opts,List.rev l + | [] -> opts, l | ("-h"|"--help") :: _ -> raise Parsing_error | ("-no-opt"|"-byte") :: r -> @@ -128,6 +128,10 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) else if (Filename.check_suffix f ".mlpack") then MLPACK f else Subdir f) :: l) r +let process_cmd_line orig_dir opts l args = + let (opts, l) = process_cmd_line orig_dir opts l args in + opts, List.rev l + let rec post_canonize f = if Filename.basename f = Filename.current_dir_name then let dir = Filename.dirname f in -- cgit v1.2.3 From d0d46d9c5a93de25ecf0202a0ab3dbd83f1ed693 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 6 Jan 2016 14:49:31 +0100 Subject: Make code more readable by not mixing list traversal and option processing. --- ide/project_file.ml4 | 80 +++++++++++++++++++++++++--------------------------- 1 file changed, 38 insertions(+), 42 deletions(-) diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index 07ab5344d2..f66fd31c20 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -139,48 +139,44 @@ let rec post_canonize f = else f (* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *) -let split_arguments = - let rec aux = function - | V n :: r -> - let (v,m,o,s),i,d = aux r in ((CUnix.remove_path_dot n::v,m,o,s),i,d) - | ML n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) - | MLI n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) - | ML4 n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) - | MLLIB n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) - | MLPACK n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) - | Special (n,dep,is_phony,c) :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,is_phony,c)::o,s),i,d) - | Subdir n :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d) - | MLInclude p :: r -> - let t,(ml,q,r),d = aux r in (t,((CUnix.remove_path_dot (post_canonize p), - CUnix.canonical_path_name p)::ml,q,r),d) - | Include (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let i_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i_new::i,r),d) - | RInclude (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let r_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i,r_new::r),d) - | Def (v,def) :: r -> - let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs)) - | Arg a :: r -> - let t,i,(args,defs) = aux r in (t,i,(a::args,defs)) - | [] -> ([],([],[],[],[],[]),[],[]),([],[],[]),([],[]) - in aux +let split_arguments args = + List.fold_right + (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t), + (ml_inc,q_inc,r_inc as i),(args,defs as d)) -> + match a with + | V n -> + ((CUnix.remove_path_dot n::v,m,o,s),i,d) + | ML n -> + ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) + | MLI n -> + ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) + | ML4 n -> + ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) + | MLLIB n -> + ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) + | MLPACK n -> + ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) + | Special (n,dep,is_phony,c) -> + ((v,m,(n,dep,is_phony,c)::o,s),i,d) + | Subdir n -> + ((v,m,o,n::s),i,d) + | MLInclude p -> + let ml_new = (CUnix.remove_path_dot (post_canonize p), + CUnix.canonical_path_name p) in + (t,(ml_new::ml_inc,q_inc,r_inc),d) + | Include (p,l) -> + let q_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_new::q_inc,r_inc),d) + | RInclude (p,l) -> + let r_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_inc,r_new::r_inc),d) + | Def (v,def) -> + (t,i,(args,(v,def)::defs)) + | Arg a -> + (t,i,(a::args,defs))) + args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[])) let read_project_file f = split_arguments -- cgit v1.2.3 From 6599e31f04b6e8980de72e9d3913b70c04b6698c Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 6 Jan 2016 15:08:08 +0100 Subject: Remove deprecated command-line options such as "-as". --- checker/checker.ml | 2 -- ide/project_file.ml4 | 1 - tools/coqc.ml | 25 ++----------------------- tools/coqdep.ml | 7 ------- toplevel/coqtop.ml | 4 ---- 5 files changed, 2 insertions(+), 37 deletions(-) diff --git a/checker/checker.ml b/checker/checker.ml index a13d529e83..da93685f98 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -331,8 +331,6 @@ let parse_args argv = | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () - | "-R" :: d :: "-as" :: p :: rem -> set_rec_include d p;parse rem - | "-R" :: d :: "-as" :: [] -> usage () | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem | "-R" :: ([] | [_]) -> usage () diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index f66fd31c20..081094e2b6 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -86,7 +86,6 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r | "-I" :: d :: r -> process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r - | "-R" :: p :: "-as" :: lp :: r | "-R" :: p :: lp :: r -> process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ -> diff --git a/tools/coqc.ml b/tools/coqc.ml index e7239da682..034c9b7f4e 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -70,17 +70,6 @@ let parse_args () = | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem | "-opt" :: rem -> binary := "coqtop"; parse (cfiles,args) rem -(* Obsolete options *) - - | "-libdir" :: _ :: rem -> - print_string "Warning: option -libdir deprecated and ignored\n"; - flush stdout; - parse (cfiles,args) rem - | ("-db"|"-debugger") :: rem -> - print_string "Warning: option -db/-debugger deprecated and ignored\n"; - flush stdout; - parse (cfiles,args) rem - (* Informative options *) | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () @@ -124,21 +113,11 @@ let parse_args () = | s :: rem' -> parse (cfiles,s::o::args) rem' | [] -> usage () end + | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem (* Options for coqtop : c) options with 1 argument and possibly more *) - | ("-I"|"-include" as o) :: rem -> - begin - match rem with - | s :: "-as" :: t :: rem' -> parse (cfiles,t::"-as"::s::o::args) rem' - | s :: "-as" :: [] -> usage () - | s :: rem' -> parse (cfiles,s::o::args) rem' - | [] -> usage () - end - | "-R" :: s :: "-as" :: t :: rem -> parse (cfiles,t::"-as"::s::"-R"::args) rem - | "-R" :: s :: "-as" :: [] -> usage () - | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem - | "-Q" :: s :: t :: rem -> parse (cfiles,t::s::"-Q"::args) rem + | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem | ("-schedule-vio-checking" |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem -> let nodash, rem = diff --git a/tools/coqdep.ml b/tools/coqdep.ml index aacfccfd77..0634f97fa6 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -444,15 +444,8 @@ let rec parse = function | "-boot" :: ll -> option_boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll - | "-I" :: r :: "-as" :: ln :: ll -> - add_rec_dir_no_import add_known r []; - add_rec_dir_no_import add_known r (split_period ln); - parse ll - | "-I" :: r :: "-as" :: [] -> usage () | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () - | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll - | "-R" :: r :: "-as" :: [] -> usage () | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import add_known r (split_period ln); parse ll | "-R" :: ([] | [_]) -> usage () diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 2aad417e8d..bd0a79caf9 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -443,10 +443,6 @@ let parse_args arglist = end |"-R" -> begin match rem with - | d :: "-as" :: [] -> error_missing_arg opt - | d :: "-as" :: p :: rem -> - warning "option -R * -as * deprecated, remove the -as"; - set_include d p true; args := rem | d :: p :: rem -> set_include d p true; args := rem | _ -> error_missing_arg opt end -- cgit v1.2.3 From 905e3dd364e8be20771c39393e7e114f2e4b8cd8 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 6 Jan 2016 16:26:04 +0100 Subject: Fix description of command-line options in the manual. --- doc/refman/RefMan-com.tex | 225 +++++++++++++++++++++++++++------------------- 1 file changed, 132 insertions(+), 93 deletions(-) diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 8bb1cc331b..6f85849888 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -5,9 +5,9 @@ There are three \Coq~commands: \begin{itemize} -\item {\tt coqtop}: The \Coq\ toplevel (interactive mode) ; -\item {\tt coqc} : The \Coq\ compiler (batch compilation). -\item {\tt coqchk} : The \Coq\ checker (validation of compiled libraries) +\item {\tt coqtop}: the \Coq\ toplevel (interactive mode); +\item {\tt coqc}: the \Coq\ compiler (batch compilation); +\item {\tt coqchk}: the \Coq\ checker (validation of compiled libraries). \end{itemize} The options are (basically) the same for the first two commands, and roughly described below. You can also look at the \verb!man! pages of @@ -39,11 +39,10 @@ The {\tt coqc} command takes a name {\em file} as argument. Then it looks for a vernacular file named {\em file}{\tt .v}, and tries to compile it into a {\em file}{\tt .vo} file (See ~\ref{compiled}). -\Warning The name {\em file} must be a regular {\Coq} identifier, as -defined in the Section~\ref{lexical}. It -must only contain letters, digits or underscores -(\_). Thus it can be \verb+/bar/foo/toto.v+ but cannot be -\verb+/bar/foo/to-to.v+. +\Warning The name {\em file} should be a regular {\Coq} identifier, as +defined in Section~\ref{lexical}. It should contain only letters, digits +or underscores (\_). For instance, \verb+/bar/foo/toto.v+ is valid, but +\verb+/bar/foo/to-to.v+ is invalid. \section[Customization]{Customization at launch time} @@ -64,7 +63,7 @@ directories to the load path of \Coq. It is possible to skip the loading of the resource file with the option \verb:-q:. -\section{By environment variables\label{EnvVariables} +\subsection{By environment variables\label{EnvVariables} \index{Environment variables}\label{envars}} Load path can be specified to the \Coq\ system by setting up @@ -93,13 +92,13 @@ The following command-line options are recognized by the commands {\tt coqc} and {\tt coqtop}, unless stated otherwise: \begin{description} -\item[{\tt -I} {\em directory}, {\tt -include} {\em directory}]\ +\item[{\tt -I} {\em directory}, {\tt -include} {\em directory}]\ % -Add physical path {\em directory} to the {\ocaml} loadpath. + Add physical path {\em directory} to the {\ocaml} loadpath. \SeeAlso Section~\ref{Libraries} and the command {\tt Declare ML Module} Section \ref{compiled}. -\item[\texttt{-Q} \emph{directory} {\dirpath}]\ +\item[{\tt -Q} {\em directory} {\dirpath}]\ % Add physical path \emph{directory} to the list of directories where {\Coq} looks for a file and bind it to the the logical directory @@ -109,147 +108,184 @@ Add physical path {\em directory} to the {\ocaml} loadpath. \SeeAlso Section~\ref{Libraries}. -\item[{\tt -R} {\em directory} {\dirpath}]\ +\item[{\tt -R} {\em directory} {\dirpath}]\ % Do as \texttt{-Q} \emph{directory} {\dirpath} but make the subdirectory structure of \emph{directory} recursively visible so that the recursive contents of physical \emph{directory} is available from {\Coq} using short or partially qualified names. - + \SeeAlso Section~\ref{Libraries}. -\item[{\tt -top} {\dirpath}, {\tt -notop}]\ +\item[{\tt -top} {\dirpath}]\ % + + Set the toplevel module name to {\dirpath} instead of {\tt Top}. Not + valid for {\tt coqc} as the toplevel module name is inferred from the + name of the output file. + +\item[{\tt -notop}]\ % + + Use the empty logical path for the toplevel module name instead of {\tt + Top}. Not valid for {\tt coqc} as the toplevel module name is + inferred from the name of the output file. + +\item[{\tt -exclude-dir} {\em directory}]\ % - This sets the toplevel module name to {\dirpath}/the empty logical path instead - of {\tt Top}. Not valid for {\tt coqc}. + Exclude any subdirectory named {\em directory} while + processing options such as {\tt -R} and {\tt -Q}. By default, only the + conventional version control management directories named {\tt CVS} and + {\tt \_darcs} are excluded. -\item[{\tt -exclude-dir} {\em subdirectory}]\ +\item[{\tt -nois}]\ % - This tells to exclude any subdirectory named {\em subdirectory} - while processing option {\tt -R}. Without this option only the - conventional version control management subdirectories named {\tt - CVS} and {\tt \_darcs} are excluded. + Start from an empty state instead of loading the {\tt Init.Prelude} + module. -\item[{\tt -nois}]\ +\item[{\tt -init-file} {\em file}]\ % - Cause \Coq~to begin with an empty state. + Load {\em file} as the resource file instead of loading the default + resource file from the standard configuration directories. -\item[{\tt -init-file} {\em file}, {\tt -q}]\ +\item[{\tt -q}]\ % - Take {\em file} as the resource file. / - Cause \Coq~not to load the resource file. + Do not to load the default resource file. -\item[{\tt -load-ml-source} {\em file}]\ +\item[{\tt -load-ml-source} {\em file}]\ % Load the {\ocaml} source file {\em file}. -\item[{\tt -load-ml-object} {\em file}]\ +\item[{\tt -load-ml-object} {\em file}]\ % Load the {\ocaml} object file {\em file}. -\item[{\tt -l[v]} {\em file}, {\tt -load-vernac-source[-verbose]} {\em file}]\ +\item[{\tt -l} {\em file}, {\tt -load-vernac-source} {\em file}]\ % + + Load and execute the {\Coq} script from {\em file.v}. + +\item[{\tt -lv} {\em file}, {\tt -load-vernac-source-verbose} {\em + file}]\ % + + Load and execute the {\Coq} script from {\em file.v}. + Output its content on the standard input as it is executed. + +\item[{\tt -load-vernac-object} {\dirpath}]\ % + + Load \Coq~compiled library {\dirpath}. This is equivalent to running + {\tt Require} {\dirpath}. - Load \Coq~file {\em file}{\tt .v} optionally with copy it contents on the - standard input. +\item[{\tt -require} {\dirpath}]\ % -\item[{\tt -load-vernac-object} {\em path}]\ + Load \Coq~compiled library {\dirpath} and import it. This is equivalent + to running {\tt Require Import} {\dirpath}. - Load \Coq~compiled library {\em path} (equivalent to {\tt Require} {\em path}). +\item[{\tt -batch}]\ % -\item[{\tt -require} {\em path}]\ + Exit just after argument parsing. Available for {\tt coqtop} only. - Load \Coq~compiled library {\em path} and import it (equivalent to {\tt - Require Import} {\em path}). +\item[{\tt -compile} {\em file.v}]\ % -\item[{\tt -compile} {\em file.v},{\tt -compile-verbose} {\em file.v}, {\tt -batch}]\ + Compile file {\em file.v} into {\em file.vo}. This options imply {\tt + -batch} (exit just after argument parsing). It is available only + for {\tt coqtop}, as this behavior is the purpose of {\tt coqc}. - {\tt coqtop} options only used internally by {\tt coqc}. +\item[{\tt -compile-verbose} {\em file.v}]\ % - This compiles file {\em file.v} into {\em file}{\tt .vo} without/with a - copy of the contents of the file on standard input. This option implies options - {\tt -batch} (exit just after arguments parsing). It is only - available for {\tt coqtop}. + Same as {\tt -compile} but also output the content of {\em file.v} as + it is compiled. -\item[{\tt -verbose}]\ +\item[{\tt -verbose}]\ % - This option is only for {\tt coqc}. It tells to compile the file with - a copy of its contents on standard input. + Output the content of the input file as it is compiled. This option is + available for {\tt coqc} only; it is the counterpart of {\tt + -compile-verbose}. %Mostly unused in the code -%\item[{\tt -debug}]\ +%\item[{\tt -debug}]\ % % % Switch on the debug flag. -\item[{\tt -with-geoproof} (yes|no)]\ +\item[{\tt -with-geoproof} (yes|no)]\ % - Activate or not special functions for Geoproof within {\CoqIDE} (default is yes). + Enable or not special functions for Geoproof within {\CoqIDE} (default + is yes). -\item[{\tt -color} (on|off|auto)]\ +\item[{\tt -color} (on|off|auto)]\ % - Activate or not the coloring of output of {\tt coqtop}. The default, auto, - means that {\tt coqtop} will dynamically decide whether to activate it - depending if the output channels of {\tt coqtop} can handle ANSI styles. + Enable or not the coloring of output of {\tt coqtop}. Default is auto, + meaning that {\tt coqtop} dynamically decides, depending on whether the + output channel supports ANSI escape sequences. -\item[{\tt -beautify}]\ +\item[{\tt -beautify}]\ % - While compiling {\em file}, pretty prints each command just after having parsing - it in {\em file}{\tt .beautified} in order to get old-fashion - syntax/definitions/notations. + Pretty-print each command to {\em file.beautified} when compiling {\em + file.v}, in order to get old-fashioned syntax/definitions/notations. -\item[{\tt -emacs}, {\tt -ide-slave}]\ +\item[{\tt -emacs}, {\tt -ide-slave}]\ % - Start a special main loop to communicate with ide. + Start a special toplevel to communicate with a specific IDE. -\item[{\tt -impredicative-set}]\ +\item[{\tt -impredicative-set}]\ % Change the logical theory of {\Coq} by declaring the sort {\tt Set} - impredicative; warning: this is known to be inconsistent with + impredicative. Warning: this is known to be inconsistent with some standard axioms of classical mathematics such as the functional - axiom of choice or the principle of description + axiom of choice or the principle of description. -\item[{\tt -type-in-type}]\ +\item[{\tt -type-in-type}]\ % - This collapses the universe hierarchy of {\Coq} making the logic inconsistent. + Collapse the universe hierarchy of {\Coq}. Warning: this makes the + logic inconsistent. -\item[{\tt -compat} {\em version}] \mbox{} +\item[{\tt -compat} {\em version}]\ % - Attempt to maintain some of the incompatible changes in their {\em version} - behavior. + Attempt to maintain some backward-compatibility with a previous version. -\item[{\tt -dump-glob} {\em file}]\ +\item[{\tt -dump-glob} {\em file}]\ % - This dumps references for global names in file {\em file} - (to be used by coqdoc, see~\ref{coqdoc}) + Dump references for global names in file {\em file} (to be used + by {\tt coqdoc}, see~\ref{coqdoc}). By default, if {\em file.v} is being + compiled, {\em file.glob} is used. -\item[{\tt -no-hash-consing}] \mbox{} +\item[{\tt -no-glob}]\ % -\item[{\tt -image} {\em file}]\ + Disable the dumping of references for global names. - This option sets the binary image to be used by {\tt coqc} to be {\em file} +%\item[{\tt -no-hash-consing}]\ % + +\item[{\tt -image} {\em file}]\ % + + Set the binary image to be used by {\tt coqc} to be {\em file} instead of the standard one. Not of general use. -\item[{\tt -bindir} {\em directory}]\ +\item[{\tt -bindir} {\em directory}]\ % + + Set the directory containing {\Coq} binaries to be used by {\tt coqc}. + It is equivalent to doing \texttt{export COQBIN=}{\em directory} before + launching {\tt coqc}. + +\item[{\tt -where}]\ % + + Print the location of \Coq's standard library and exit. - Set for {\tt coqc} the directory containing \Coq\ binaries. - It is equivalent to do \texttt{export COQBIN=}{\em directory} - before launching {\tt coqc}. +\item[{\tt -config}]\ % -\item[{\tt -where}, {\tt -config}, {\tt -filteropts}]\ + Print the locations of \Coq's binaries, dependencies, and libraries, then exit. - Print the \Coq's standard library location or \Coq's binaries, dependencies, - libraries locations or the list of command line arguments that {\tt coqtop} has - recognize as options and exit. +\item[{\tt -filteropts}]\ % -\item[{\tt -v}]\ + Print the list of command line arguments that {\tt coqtop} has + recognized as options and exit. - Print the \Coq's version and exit. +\item[{\tt -v}]\ % -\item[{\tt -list-tags}]\ + Print \Coq's version and exit. - Print the highlight tags known by \Coq as well as their currently associated - color. +\item[{\tt -list-tags}]\ % -\item[{\tt -h}, {\tt --help}]\ + Print the highlight tags known by {\Coq} as well as their currently associated + color and exit. + +\item[{\tt -h}, {\tt --help}]\ % Print a short usage and exit. @@ -293,18 +329,21 @@ Command-line options {\tt -I}, {\tt -R}, {\tt -where} and {\tt -impredicative-set} are supported by {\tt coqchk} and have the same meaning as for {\tt coqtop}. Extra options are: \begin{description} -\item[{\tt -norec} $module$]\ +\item[{\tt -norec} {\em module}]\ % + + Check {\em module} but do not check its dependencies. - Check $module$ but do not force check of its dependencies. -\item[{\tt -admit} $module$] \ +\item[{\tt -admit} {\em module}]\ % - Do not check $module$ and any of its dependencies, unless + Do not check {\em module} and any of its dependencies, unless explicitly required. -\item[{\tt -o}]\ + +\item[{\tt -o}]\ % At exit, print a summary about the context. List the names of all assumptions and variables (constants without body). -\item[{\tt -silent}]\ + +\item[{\tt -silent}]\ % Do not write progress information in standard output. \end{description} -- cgit v1.2.3 From e309d8119cd82bdf1216751fb076d438782fb60f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 7 Jan 2016 17:20:51 +0100 Subject: Fix bug #4480: progress was not checked for setoid_rewrite. Also ensure we stay compatible with 8.4: progress could now be made simply because of beta redexes in the goal. --- tactics/rewrite.ml | 15 ++++++++------- test-suite/bugs/closed/4480.v | 12 ++++++++++++ 2 files changed, 20 insertions(+), 7 deletions(-) create mode 100644 test-suite/bugs/closed/4480.v diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index a230ea251a..6d61879e89 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1526,7 +1526,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") - | Some None -> Proofview.tclUNIT () + | Some None -> newfail 0 (str"Failed to progress") | Some (Some res) -> let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in @@ -1596,12 +1596,13 @@ let tactic_init_setoid () = (** Setoid rewriting when called with "rewrite_strat" *) let cl_rewrite_clause_strat strat clause = tclTHEN (tactic_init_setoid ()) - (fun gl -> - try Proofview.V82.of_tactic (cl_rewrite_clause_newtac strat clause) gl - with RewriteFailure e -> - errorlabstrm "" (str"setoid rewrite failed: " ++ e) - | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl) + (tclWEAK_PROGRESS + (fun gl -> + try Proofview.V82.of_tactic (cl_rewrite_clause_newtac strat clause) gl + with RewriteFailure e -> + errorlabstrm "" (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)) (** Setoid rewriting when called with "setoid_rewrite" *) let cl_rewrite_clause l left2right occs clause gl = diff --git a/test-suite/bugs/closed/4480.v b/test-suite/bugs/closed/4480.v new file mode 100644 index 0000000000..08a86330f2 --- /dev/null +++ b/test-suite/bugs/closed/4480.v @@ -0,0 +1,12 @@ +Require Import Setoid. + +Definition proj (P Q : Prop) := P. + +Lemma foo (P : Prop) : proj P P = P. +Admitted. +Lemma trueI : True <-> True. +Admitted. +Goal True. + Fail setoid_rewrite foo. + Fail setoid_rewrite trueI. + \ No newline at end of file -- cgit v1.2.3 From 29d2dcb5474e4eed7e0f0d02d1e388bff53ec82d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 7 Jan 2016 17:21:54 +0100 Subject: Fix a misleading comment for substn_vars --- kernel/vars.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kernel/vars.mli b/kernel/vars.mli index c0fbeeb6e6..9f034b288a 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -65,7 +65,7 @@ val subst_var : Id.t -> constr -> constr if two names are identical, the one of least indice is kept *) val subst_vars : Id.t list -> constr -> constr -(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] +(** [substn_vars n [id1;...;idk] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) val substn_vars : int -> Id.t list -> constr -> constr -- cgit v1.2.3 From 8b0fbcc6568308794ef198f8e96093b00ba90ca4 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Fri, 8 Jan 2016 10:46:26 +0100 Subject: Be more verbose about failure to compile libraries to native code. On a machine with only 1GB of memory (e.g. in a VM), the compiler might be abruptly killed by a segfault. We were not getting any feedback in that case, making it harder to debug. --- kernel/nativelib.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index b2142b43c7..81470f9015 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -77,7 +77,17 @@ let call_compiler ml_filename = ::include_dirs @ ["-impl"; ml_filename] in if !Flags.debug then Pp.msg_debug (Pp.str (compiler_name ^ " " ^ (String.concat " " args))); - try CUnix.sys_command compiler_name args = Unix.WEXITED 0, link_filename + try + let res = CUnix.sys_command compiler_name args in + let res = match res with + | Unix.WEXITED 0 -> true + | Unix.WEXITED n -> + Pp.(msg_warning (str "command exited with status " ++ int n)); false + | Unix.WSIGNALED n -> + Pp.(msg_warning (str "command killed by signal " ++ int n)); false + | Unix.WSTOPPED n -> + Pp.(msg_warning (str "command stopped by signal " ++ int n)); false in + res, link_filename with Unix.Unix_error (e,_,_) -> Pp.(msg_warning (str (Unix.error_message e))); false, link_filename -- cgit v1.2.3 From 418dceeea548a40c6e00b09aa99267a82949c70c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 8 Jan 2016 20:29:37 +0100 Subject: Monotonizing Ftactic. --- grammar/argextend.ml4 | 6 +-- tactics/ftactic.ml | 24 +++++++++-- tactics/ftactic.mli | 15 +++++-- tactics/tacinterp.ml | 110 +++++++++++++++++++++++++------------------------- 4 files changed, 89 insertions(+), 66 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 89a1cd8b83..639097afa8 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -193,10 +193,10 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = (** Compatibility layer, TODO: remove me *) <:expr< let f = $lid:f$ in - fun ist v -> Ftactic.nf_enter (fun gl -> + fun ist v -> Ftactic.nf_s_enter { Proofview.Goal.s_enter = fun gl -> let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in - Ftactic.bind (Ftactic.lift (Proofview.Unsafe.tclEVARS sigma)) (fun _ -> Ftactic.return v) - ) + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) + } >> in let subst = match h with | None -> diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml index f8437b5599..a8abffc8d1 100644 --- a/tactics/ftactic.ml +++ b/tactics/ftactic.ml @@ -37,16 +37,32 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function Proofview.tclDISPATCHL (List.map f l) >>= fun l -> Proofview.tclUNIT (Depends (List.concat l)) +let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) +let set_sigma r = + let Sigma.Sigma (ans, sigma, _) = r in + Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans + let nf_enter f = - bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) + bind goals + (fun gl -> + gl >>= fun gl -> + Proofview.Goal.normalize gl >>= fun nfgl -> + Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) + +let nf_s_enter f = + bind goals (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f nfgl)) + Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) let enter f = - bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) + bind goals + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) + +let s_enter f = + bind goals + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) let with_env t = t >>= function diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli index a20d8a9c3c..f0466341f0 100644 --- a/tactics/ftactic.mli +++ b/tactics/ftactic.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Proofview.Notations + (** Potentially focussing tactics *) type +'a focus @@ -37,14 +39,19 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : (([ `NF ], 'r) Proofview.Goal.t -> 'a t) -> 'a t +val nf_enter : ([ `NF ], 'a t) enter -> 'a t (** Enter a goal. The resulting tactic is focussed. *) -(** FIXME: Should be polymorphic over the stage. *) -val enter : (([ `LZ ], 'r) Proofview.Goal.t -> 'a t) -> 'a t +val enter : ([ `LZ ], 'a t) enter -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) -(** FIXME: Should be polymorphic over the stage. *) + +val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t +(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) + +val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t +(** Enter a goal, without evar normalization and put back an evarmap. The + resulting tactic is focussed. *) val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 5450a00f4f..74ddd6b575 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -650,9 +650,9 @@ let pf_interp_constr ist gl = let new_interp_constr ist c k = let open Proofview in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let (sigma, c) = interp_constr ist (Goal.env gl) (Tacmach.New.project gl) c in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c) + Sigma.Unsafe.of_pair (k c, sigma) end } let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = @@ -822,12 +822,12 @@ let rec message_of_value v = Ftactic.return (str "") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end + Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end } else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Tacmach.New.project gl) c) - end + end } else if has_type v (topwit wit_unit) then Ftactic.return (str "()") else if has_type v (topwit wit_int) then @@ -835,18 +835,18 @@ let rec message_of_value v = else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Tacmach.New.project gl) c) p) - end + end } else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end } else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) (Tacmach.New.project gl) c) - end + end } else match Value.to_list v with | Some l -> Ftactic.List.map message_of_value l >>= fun l -> @@ -1116,13 +1116,13 @@ let rec read_match_rule lfun ist env sigma = function (* misc *) let interp_focussed wit f v = - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> let v = Genarg.out_gen (glbwit wit) v in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let v = in_gen (topwit wit) (f env sigma v) in Ftactic.return v - end + end } (* Interprets an l-tac expression into a value *) let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = @@ -1311,17 +1311,17 @@ and interp_tacarg ist arg : Val.t Ftactic.t = | TacGeneric arg -> interp_genarg ist arg | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> - Ftactic.enter begin fun gl -> + Ftactic.s_enter { s_enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - end + Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) + end } | UConstr c -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in Ftactic.return (Value.of_uconstr (interp_uconstr ist env c)) - end + end } | MetaIdArg (loc,_,id) -> assert false | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist r @@ -1331,19 +1331,18 @@ and interp_tacarg ist arg : Val.t Ftactic.t = Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> interp_app loc ist fv largs | TacFreshId l -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Tacmach.New.project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) - end + end } | TacPretype c -> - Ftactic.enter begin fun gl -> + Ftactic.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let c = interp_uconstr ist env c in - let Sigma (c, sigma, _) = (type_uconstr ist c).delayed env sigma in - let sigma = Sigma.to_evar_map sigma in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c)) - end + let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in + Sigma (Ftactic.return (Value.of_constr c), sigma, p) + end } | TacNumgoals -> Ftactic.lift begin let open Proofview.Notations in @@ -1497,16 +1496,16 @@ and interp_match ist lz constr lmr = Proofview.tclZERO ~info e end end >>= fun constr -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) - end + end } (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in @@ -1514,7 +1513,7 @@ and interp_match_goal ist lz lr lmr = let concl = Proofview.Goal.concl gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) - end + end } (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = @@ -1525,14 +1524,14 @@ and interp_genarg ist x : Val.t Ftactic.t = | VarArgType -> interp_focussed wit_var (interp_hyp ist) x | ConstrArgType -> - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_s_enter { s_enter = begin fun gl -> let c = Genarg.out_gen (glbwit wit_constr) x in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let (sigma, c) = interp_constr ist env sigma c in let c = in_gen (topwit wit_constr) c in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return c) - end + Sigma.Unsafe.of_pair (Ftactic.return c, sigma) + end } | ListArgType ConstrArgType -> interp_genarg_constr_list ist x | ListArgType VarArgType -> @@ -1573,23 +1572,23 @@ and interp_genarg ist x : Val.t Ftactic.t = independently of goals. *) and interp_genarg_constr_list ist x = - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in let lc = Value.of_list (val_tag wit_constr) lc in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return lc) - end + Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) + end } and interp_genarg_var_list ist x = - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in Ftactic.return (Value.of_list (val_tag wit_var) lc) - end + end } (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : constr Ftactic.t = @@ -1598,7 +1597,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = (val_interp ist e) begin function (err, info) -> match err with | Not_found -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in Proofview.tclLIFT begin debugging_step ist (fun () -> @@ -1606,11 +1605,11 @@ and interp_ltac_constr ist e : constr Ftactic.t = Pptactic.pr_glob_tactic env e) end <*> Proofview.tclZERO Not_found - end + end } | err -> Proofview.tclZERO ~info err end end >>= fun result -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let result = Value.normalize result in @@ -1627,7 +1626,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = let env = Proofview.Goal.env gl in Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ pr_inspect env e result) - end + end } (* Interprets tactic expressions : returns a "tactic" *) @@ -1845,7 +1844,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let sigma,l = @@ -1864,11 +1863,11 @@ and interp_atomic ist tac : unit Proofview.tactic = let l,lp = List.split l in let sigma,el = Option.fold_map (interp_constr_with_bindings ist env) sigma el in - name_atomic ~env + let tac = name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) - (Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) - (Tactics.induction_destruct isrec ev (l,el))) + (Tactics.induction_destruct isrec ev (l,el)) + in + Sigma.Unsafe.of_pair (tac, sigma) end } | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in @@ -2065,16 +2064,17 @@ and interp_atomic ist tac : unit Proofview.tactic = (Inv.inv_clause k ids_interp hyps dqhyps)) sigma end } | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + let tac = name_atomic ~env (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) (Leminv.lemInv_clause dqhyps c_interp hyps) + in + Sigma.Unsafe.of_pair (tac, sigma) end } (* Initial call for interpretation *) @@ -2156,18 +2156,18 @@ let () = let () = declare_uniform wit_pre_ident -let lift f = (); fun ist x -> Ftactic.nf_enter begin fun gl -> +let lift f = (); fun ist x -> Ftactic.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in Ftactic.return (f ist env sigma x) -end +end } -let lifts f = (); fun ist x -> Ftactic.nf_enter begin fun gl -> +let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let (sigma, v) = f ist env sigma x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) -end + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) +end } let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in @@ -2202,9 +2202,9 @@ let () = Geninterp.register_interp0 wit_tactic interp let () = - Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter begin fun gl -> + Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) - end) + end }) (***************************************************************************) (* Other entry points *) -- cgit v1.2.3 From 730e8b8445c6ff28540aff4a052e19b90159a86d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Jan 2016 17:10:36 +0100 Subject: Fix bug 4479: "Error: Rewriting base foo does not exist." should be catchable. --- tactics/autorewrite.ml | 5 +++-- test-suite/bugs/closed/4479.v | 3 +++ 2 files changed, 6 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/4479.v diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index e4ff1c9069..dce6f674a6 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -197,7 +197,8 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = try_do_hyps (fun id -> id) ids end }) -let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT()) +let auto_multi_rewrite ?(conds=Naive) lems cl = + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in @@ -206,7 +207,7 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = (* autorewrite with .... in clause using tac n'est sur que si clause represente soit le but soit UNE hypothese *) - gen_auto_multi_rewrite conds tac_main lbas cl + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) | _ -> Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") diff --git a/test-suite/bugs/closed/4479.v b/test-suite/bugs/closed/4479.v new file mode 100644 index 0000000000..921579d1e1 --- /dev/null +++ b/test-suite/bugs/closed/4479.v @@ -0,0 +1,3 @@ +Goal True. +Fail autorewrite with foo. +try autorewrite with foo. -- cgit v1.2.3 From 8a4a8758075e09da298762da1a035a5afac4d88b Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 21 Dec 2015 11:37:06 +0100 Subject: COMMENTS: added to the "Names.inductive" and "Names.constructor" types. --- kernel/names.ml | 15 ++++++++++----- kernel/names.mli | 15 ++++++++++----- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/kernel/names.ml b/kernel/names.ml index 0de752c7c5..d1e2c8afee 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -585,11 +585,16 @@ module Mindmap = HMap.Make(MutInd.CanOrd) module Mindset = Mindmap.Set module Mindmap_env = HMap.Make(MutInd.UserOrd) -(** Beware: first inductive has index 0 *) -(** Beware: first constructor has index 1 *) - -type inductive = MutInd.t * int -type constructor = inductive * int +(** Designation of a (particular) inductive type. *) +type inductive = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + +(** Designation of a (particular) constructor of a (particular) inductive type. *) +type constructor = inductive (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) let ind_modpath (mind,_) = MutInd.modpath mind let constr_modpath (ind,_) = ind_modpath ind diff --git a/kernel/names.mli b/kernel/names.mli index 38a51a3927..df296ab6c6 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -411,11 +411,16 @@ module Mindset : CSig.SetS with type elt = MutInd.t module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset module Mindmap_env : CSig.MapS with type key = MutInd.t -(** Beware: first inductive has index 0 *) -type inductive = MutInd.t * int - -(** Beware: first constructor has index 1 *) -type constructor = inductive * int +(** Designation of a (particular) inductive type. *) +type inductive = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + +(** Designation of a (particular) constructor of a (particular) inductive type. *) +type constructor = inductive (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) module Indmap : CSig.MapS with type key = inductive module Constrmap : CSig.MapS with type key = constructor -- cgit v1.2.3 From f8eb2ed4ddbe2199187696f51c42734014f4d9d0 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 21 Dec 2015 13:32:57 +0100 Subject: COMMENTS: of "Constr.case_info" type were updated. --- kernel/constr.ml | 20 ++++++++++++++------ kernel/constr.mli | 20 +++++++++++++------- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/kernel/constr.ml b/kernel/constr.ml index c3aebada26..3e7d888ede 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -41,15 +41,23 @@ type case_printing = { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *) cstr_tags : bool list array; (* whether each pattern var of each constructor is a let-in (true) or not (false) *) style : case_style } + +(* INVARIANT: + * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs + * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)), + * ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i) + *) type case_info = { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) ci_npar : int; (* number of parameters of the above inductive type *) - ci_cstr_ndecls : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (with let's) *) - ci_cstr_nargs : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (w/o let's) *) + ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines + the number of values that can be bound in a match-construct. + NOTE: parameters of the inductive type are therefore excluded from the count *) + ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines + the number of values that can be applied to the constructor, + in addition to the parameters of the related inductive type + NOTE: "lets" are therefore excluded from the count + NOTE: parameters of the inductive type are also excluded from the count *) ci_pp_info : case_printing (* not interpreted by the kernel *) } diff --git a/kernel/constr.mli b/kernel/constr.mli index edd4eb2310..ada2686063 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -30,16 +30,22 @@ type case_printing = cstr_tags : bool list array; (** tell whether letin or lambda in the signature of each constructor *) style : case_style } -(** the integer is the number of real args, needed for reduction *) +(* INVARIANT: + * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs + * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)), + * ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i) + *) type case_info = { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) ci_npar : int; (* number of parameters of the above inductive type *) - ci_cstr_ndecls : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (with let's) *) - ci_cstr_nargs : int array; (* number of arguments of individual constructors - (numbers of parameters of the inductive type are excluded from the count) - (w/o let's) *) + ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines + the number of values that can be bound in a match-construct. + NOTE: parameters of the inductive type are therefore excluded from the count *) + ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines + the number of values that can be applied to the constructor, + in addition to the parameters of the related inductive type + NOTE: "lets" are therefore excluded from the count + NOTE: parameters of the inductive type are also excluded from the count *) ci_pp_info : case_printing (* not interpreted by the kernel *) } -- cgit v1.2.3 From 35ffd67ae0ad50b7fa28669f78d4893b0f20f3ad Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 11 Jan 2016 10:18:52 +0100 Subject: Fix bug #3338 again, no progress is necessary for the success of rewrite_strat. --- tactics/rewrite.ml | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 6d61879e89..ec58ef25b1 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1521,12 +1521,13 @@ let assert_replacing id newt tac = let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) -let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = +let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") - | Some None -> newfail 0 (str"Failed to progress") + | Some None -> if progress then newfail 0 (str"Failed to progress") + else Proofview.tclUNIT () | Some (Some res) -> let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in @@ -1593,12 +1594,11 @@ let tactic_init_setoid () = try init_setoid (); tclIDTAC with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded") -(** Setoid rewriting when called with "rewrite_strat" *) -let cl_rewrite_clause_strat strat clause = +let cl_rewrite_clause_strat progress strat clause = tclTHEN (tactic_init_setoid ()) - (tclWEAK_PROGRESS + ((if progress then tclWEAK_PROGRESS else fun x -> x) (fun gl -> - try Proofview.V82.of_tactic (cl_rewrite_clause_newtac strat clause) gl + try Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~progress strat clause) gl with RewriteFailure e -> errorlabstrm "" (str"setoid rewrite failed: " ++ e) | Refiner.FailError (n, pp) -> @@ -1607,8 +1607,12 @@ let cl_rewrite_clause_strat strat clause = (** Setoid rewriting when called with "setoid_rewrite" *) let cl_rewrite_clause l left2right occs clause gl = let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in - cl_rewrite_clause_strat strat clause gl + cl_rewrite_clause_strat true strat clause gl +(** Setoid rewriting when called with "rewrite_strat" *) +let cl_rewrite_clause_strat strat clause = + cl_rewrite_clause_strat false strat clause + let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> let c sigma = let (sigma, c) = Pretyping.understand_tcc env sigma c in @@ -2014,7 +2018,8 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = tclWEAK_PROGRESS (tclTHEN (Refiner.tclEVARS evd) - (Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~abs:(Some abs) ~origsigma strat cl))) gl + (Proofview.V82.of_tactic + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) gl with RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl -- cgit v1.2.3 From 9d991d36c07efbb6428e277573bd43f6d56788fc Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 8 Jan 2016 10:00:21 +0100 Subject: CLEANUP: kernel/context.ml{,i} The structure of the Context module was refined in such a way that: - Types and functions related to rel-context declarations were put into the Context.Rel.Declaration module. - Types and functions related to rel-context were put into the Context.Rel module. - Types and functions related to named-context declarations were put into the Context.Named.Declaration module. - Types and functions related to named-context were put into the Context.Named module. - Types and functions related to named-list-context declarations were put into Context.NamedList.Declaration module. - Types and functions related to named-list-context were put into Context.NamedList module. Some missing comments were added to the *.mli file. The output of ocamldoc was checked whether it looks in a reasonable way. "TODO: cleanup" was removed The order in which are exported functions listed in the *.mli file was changed. (as in a mature modules, this order usually is not random) The order of exported functions in Context.{Rel,Named} modules is now consistent. (as there is no special reason why that order should be different) The order in which are functions defined in the *.ml file is the same as the order in which they are listed in the *.mli file. (as there is no special reason to define them in a different order) The name of the original fold_{rel,named}_context{,_reverse} functions was changed to better indicate what those functions do. (Now they are called Context.{Rel,Named}.fold_{inside,outside}) The original comments originally attached to the fold_{rel,named}_context{,_reverse} did not full make sense so they were updated. Thrown exceptions are now documented. Naming of formal parameters was made more consistent across different functions. Comments of similar functions in different modules are now consistent. Comments from *.mli files were copied to *.ml file. (We need that information in *.mli files because that is were ocamldoc needs it. It is nice to have it also in *.ml files because when we are using Merlin and jump to the definion of the function, we can see the comments also there and do not need to open a different file if we want to see it.) When we invoke ocamldoc, we instruct it to generate UTF-8 HTML instead of (default) ISO-8859-1. (UTF-8 characters are used in our ocamldoc markup) "open Context" was removed from all *.mli and *.ml files. (Originally, it was OK to do that. Now it is not.) An entry to dev/doc/changes.txt file was added that describes how the names of types and functions have changed. --- .gitignore | 2 + Makefile.build | 4 +- dev/doc/changes.txt | 50 ++++ engine/evd.mli | 9 +- engine/namegen.mli | 13 +- engine/termops.ml | 29 +- engine/termops.mli | 77 +++--- ide/ide_slave.ml | 4 +- interp/constrextern.mli | 3 +- interp/constrintern.ml | 4 +- interp/constrintern.mli | 5 +- kernel/context.ml | 356 ++++++++++++++++--------- kernel/context.mli | 243 ++++++++++------- kernel/cooking.ml | 6 +- kernel/csymtable.ml | 5 +- kernel/declarations.mli | 7 +- kernel/declareops.ml | 2 +- kernel/environ.ml | 27 +- kernel/environ.mli | 45 ++-- kernel/fast_typeops.ml | 2 +- kernel/indtypes.ml | 33 ++- kernel/indtypes.mli | 4 +- kernel/inductive.ml | 15 +- kernel/inductive.mli | 9 +- kernel/nativecode.ml | 9 +- kernel/opaqueproof.ml | 2 +- kernel/opaqueproof.mli | 2 +- kernel/pre_env.ml | 17 +- kernel/pre_env.mli | 13 +- kernel/reduction.ml | 17 +- kernel/reduction.mli | 7 +- kernel/term.ml | 33 ++- kernel/term.mli | 37 ++- kernel/term_typing.ml | 5 +- kernel/typeops.ml | 7 +- kernel/typeops.mli | 5 +- kernel/vars.ml | 11 +- kernel/vars.mli | 15 +- library/decls.ml | 3 +- library/global.mli | 4 +- library/lib.mli | 8 +- plugins/extraction/extraction.ml | 1 - plugins/firstorder/formula.mli | 3 +- plugins/funind/functional_principles_proofs.ml | 3 +- plugins/funind/functional_principles_types.ml | 3 +- plugins/funind/glob_term_to_relation.ml | 2 +- plugins/funind/merge.ml | 19 +- pretyping/cases.ml | 27 +- pretyping/cases.mli | 9 +- pretyping/constr_matching.ml | 5 +- pretyping/detyping.ml | 5 +- pretyping/detyping.mli | 3 +- pretyping/evarsolve.ml | 3 +- pretyping/evarutil.ml | 11 +- pretyping/evarutil.mli | 7 +- pretyping/find_subterm.mli | 5 +- pretyping/indrec.ml | 39 ++- pretyping/inductiveops.ml | 35 ++- pretyping/inductiveops.mli | 19 +- pretyping/patternops.mli | 1 - pretyping/pretyping.ml | 19 +- pretyping/reductionops.ml | 15 +- pretyping/reductionops.mli | 7 +- pretyping/retyping.mli | 3 +- pretyping/typeclasses.ml | 11 +- pretyping/typeclasses.mli | 7 +- pretyping/typeclasses_errors.ml | 3 +- pretyping/typeclasses_errors.mli | 5 +- pretyping/unification.ml | 4 +- pretyping/unification.mli | 2 +- pretyping/vnorm.ml | 2 +- printing/printer.ml | 8 +- printing/printer.mli | 13 +- printing/printmod.ml | 5 +- proofs/goal.mli | 2 +- proofs/logic.ml | 1 - proofs/logic.mli | 2 +- proofs/pfedit.ml | 2 +- proofs/proofview.mli | 2 +- proofs/refiner.ml | 4 +- proofs/refiner.mli | 3 +- proofs/tacmach.ml | 4 +- proofs/tacmach.mli | 11 +- tactics/auto.ml | 2 +- tactics/eqschemes.ml | 71 +++-- tactics/equality.ml | 4 +- tactics/extratactics.ml4 | 2 +- tactics/hints.mli | 3 +- tactics/inv.ml | 3 +- tactics/leminv.ml | 9 +- tactics/rewrite.mli | 2 +- tactics/tactic_matching.mli | 2 +- tactics/tacticals.ml | 5 +- tactics/tacticals.mli | 35 ++- tactics/tactics.ml | 57 ++-- tactics/tactics.mli | 37 ++- toplevel/assumptions.ml | 2 +- toplevel/assumptions.mli | 2 +- toplevel/auto_ind_decl.ml | 7 +- toplevel/class.ml | 5 +- toplevel/classes.ml | 2 +- toplevel/classes.mli | 5 +- toplevel/command.ml | 15 +- toplevel/discharge.ml | 7 +- toplevel/discharge.mli | 3 +- toplevel/obligations.ml | 5 +- toplevel/record.ml | 11 +- toplevel/record.mli | 7 +- toplevel/vernacentries.ml | 2 +- 109 files changed, 959 insertions(+), 830 deletions(-) diff --git a/.gitignore b/.gitignore index 0466eac855..5c932ad02a 100644 --- a/.gitignore +++ b/.gitignore @@ -98,6 +98,8 @@ doc/RecTutorial/RecTutorial.html doc/RecTutorial/RecTutorial.pdf doc/RecTutorial/RecTutorial.ps dev/doc/naming-conventions.pdf +dev/ocamldoc/*.html +dev/ocamldoc/*.css # .mll files diff --git a/Makefile.build b/Makefile.build index a3766a50f5..fc58166164 100644 --- a/Makefile.build +++ b/Makefile.build @@ -838,7 +838,7 @@ $(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi) mli-doc: $(DOCMLIS:.mli=.cmi) $(SHOW)'OCAMLDOC -html' - $(HIDE)$(OCAMLFIND) ocamldoc -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ + $(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ $(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \ -t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \ -css-style style.css @@ -860,7 +860,7 @@ OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) - $(OCAMLDOC_MLLIBD) ml-doc: - $(OCAMLFIND) ocamldoc -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) + $(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d $(OCAMLDOC_MLLIBD) diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 2f62be9aff..c143afd374 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -1,3 +1,53 @@ +========================================= += CHANGES BETWEEN COQ V8.5 AND CQQ V8.6 = +========================================= + +- The interface of the Context module was changed. + Related types and functions were put in separate submodules. + The mapping from old identifiers to new identifiers is the following: + + Context.named_declaration ---> Context.Named.Declaration.t + Context.named_list_declaration ---> Context.NamedList.Declaration.t + Context.rel_declaration ---> Context.Rel.Declaration.t + Context.map_named_declaration ---> Context.Named.Declaration.map + Context.map_named_list_declaration ---> Context.NamedList.Declaration.map + Context.map_rel_declaration ---> Context.Rel.Declaration.map + Context.fold_named_declaration ---> Context.Named.Declaration.fold + Context.fold_rel_declaration ---> Context.Rel.Declaration.fold + Context.exists_named_declaration ---> Context.Named.Declaration.exists + Context.exists_rel_declaration ---> Context.Rel.Declaration.exists + Context.for_all_named_declaration ---> Context.Named.Declaration.for_all + Context.for_all_rel_declaration ---> Context.Rel.Declaration.for_all + Context.eq_named_declaration ---> Context.Named.Declaration.equal + Context.eq_rel_declaration ---> Context.Rel.Declaration.equal + Context.named_context ---> Context.Named.t + Context.named_list_context ---> Context.NamedList.t + Context.rel_context ---> Context.Rel.t + Context.empty_named_context ---> Context.Named.empty + Context.add_named_decl ---> Context.Named.add + Context.vars_of_named_context ---> Context.Named.to_vars + Context.lookup_named ---> Context.Named.lookup + Context.named_context_length ---> Context.Named.length + Context.named_context_equal ---> Context.Named.equal + Context.fold_named_context ---> Context.Named.fold_outside + Context.fold_named_list_context ---> Context.NamedList.fold + Context.fold_named_context_reverse ---> Context.Named.fold_inside + Context.instance_from_named_context ---> Context.Named.to_instance + Context.extended_rel_list ---> Context.Rel.to_extended_list + Context.extended_rel_vect ---> Context.Rel.to_extended_vect + Context.fold_rel_context ---> Context.Rel.fold_outside + Context.fold_rel_context_reverse ---> Context.Rel.fold_inside + Context.map_rel_context ---> Context.Rel.map + Context.map_named_context ---> Context.Named.map + Context.iter_rel_context ---> Context.Rel.iter + Context.iter_named_context ---> Context.Named.iter + Context.empty_rel_context ---> Context.Rel.empty + Context.add_rel_decl ---> Context.Rel.add + Context.lookup_rel ---> Context.Rel.lookup + Context.rel_context_length ---> Context.Rel.length + Context.rel_context_nhyps ---> Context.Rel.nhyps + Context.rel_context_tags ---> Context.Rel.to_tags + ========================================= = CHANGES BETWEEN COQ V8.4 AND CQQ V8.5 = ========================================= diff --git a/engine/evd.mli b/engine/evd.mli index 57399f2b5e..34169b0214 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -10,7 +10,6 @@ open Util open Loc open Names open Term -open Context open Environ (** {5 Existential variables and unification states} @@ -105,8 +104,8 @@ type evar_info = { val make_evar : named_context_val -> types -> evar_info val evar_concl : evar_info -> constr -val evar_context : evar_info -> named_context -val evar_filtered_context : evar_info -> named_context +val evar_context : evar_info -> Context.Named.t +val evar_filtered_context : evar_info -> Context.Named.t val evar_hyps : evar_info -> named_context_val val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body @@ -223,7 +222,7 @@ val existential_opt_value : evar_map -> existential -> constr option (** Same as {!existential_value} but returns an option instead of raising an exception. *) -val evar_instance_array : (named_declaration -> 'a -> bool) -> evar_info -> +val evar_instance_array : (Context.Named.Declaration.t -> 'a -> bool) -> evar_info -> 'a array -> (Id.t * 'a) list val instantiate_evar_array : evar_info -> constr -> constr array -> constr @@ -423,7 +422,7 @@ val evar_list : constr -> existential list val evars_of_term : constr -> Evar.Set.t (** including evars in instances of evars *) -val evars_of_named_context : named_context -> Evar.Set.t +val evars_of_named_context : Context.Named.t -> Evar.Set.t val evars_of_filtered_evar_info : evar_info -> Evar.Set.t diff --git a/engine/namegen.mli b/engine/namegen.mli index f66bc6d88c..617f6e522a 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Environ (********************************************************************* @@ -39,13 +38,13 @@ val lambda_name : env -> Name.t * types * constr -> constr val prod_create : env -> types * types -> constr val lambda_create : env -> types * constr -> constr -val name_assumption : env -> rel_declaration -> rel_declaration -val name_context : env -> rel_context -> rel_context +val name_assumption : env -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t +val name_context : env -> Context.Rel.t -> Context.Rel.t -val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types -val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr -val it_mkProd_or_LetIn_name : env -> types -> rel_context -> types -val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr +val mkProd_or_LetIn_name : env -> types -> Context.Rel.Declaration.t -> types +val mkLambda_or_LetIn_name : env -> constr -> Context.Rel.Declaration.t -> constr +val it_mkProd_or_LetIn_name : env -> types -> Context.Rel.t -> types +val it_mkLambda_or_LetIn_name : env -> constr -> Context.Rel.t -> constr (********************************************************************* Fresh names *) diff --git a/engine/termops.ml b/engine/termops.ml index c10c55220b..ce640bacf1 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Environ (* Sorts and sort family *) @@ -700,9 +699,9 @@ let replace_term = replace_term_gen eq_constr let vars_of_env env = let s = - Context.fold_named_context (fun (id,_,_) s -> Id.Set.add id s) + Context.Named.fold_outside (fun (id,_,_) s -> Id.Set.add id s) (named_context env) ~init:Id.Set.empty in - Context.fold_rel_context + Context.Rel.fold_outside (fun (na,_,_) s -> match na with Name id -> Id.Set.add id s | _ -> s) (rel_context env) ~init:s @@ -728,12 +727,12 @@ let lookup_rel_of_name id names = let empty_names_context = [] let ids_of_rel_context sign = - Context.fold_rel_context + Context.Rel.fold_outside (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l) sign ~init:[] let ids_of_named_context sign = - Context.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[] + Context.Named.fold_outside (fun (id,_,_) idl -> id::idl) sign ~init:[] let ids_of_context env = (ids_of_rel_context (rel_context env)) @@ -788,7 +787,7 @@ let split_app c = match kind_of_term c with c::(Array.to_list prev), last | _ -> assert false -type subst = (rel_context*constr) Evar.Map.t +type subst = (Context.Rel.t * constr) Evar.Map.t exception CannotFilter @@ -825,7 +824,7 @@ let filtering env cv_pb c1 c2 = in aux env cv_pb c1 c2; !evm -let decompose_prod_letin : constr -> int * rel_context * constr = +let decompose_prod_letin : constr -> int * Context.Rel.t * constr = let rec prodec_rec i l c = match kind_of_term c with | Prod (n,t,c) -> prodec_rec (succ i) ((n,None,t)::l) c | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c @@ -861,7 +860,7 @@ let nb_prod_modulo_zeta x = | _ -> n in count 0 x -let align_prod_letin c a : rel_context * constr = +let align_prod_letin c a : Context.Rel.t * constr = let (lc,_,_) = decompose_prod_letin c in let (la,l,a) = decompose_prod_letin a in if not (la >= lc) then invalid_arg "align_prod_letin"; @@ -899,10 +898,10 @@ let process_rel_context f env = let sign = named_context_val env in let rels = rel_context env in let env0 = reset_with_named_context sign env in - Context.fold_rel_context f rels ~init:env0 + Context.Rel.fold_outside f rels ~init:env0 let assums_of_rel_context sign = - Context.fold_rel_context + Context.Rel.fold_outside (fun (na,c,t) l -> match c with Some _ -> l @@ -912,7 +911,7 @@ let assums_of_rel_context sign = let map_rel_context_in_env f env sign = let rec aux env acc = function | d::sign -> - aux (push_rel d env) (map_rel_declaration (f env) d :: acc) sign + aux (push_rel d env) (Context.Rel.Declaration.map (f env) d :: acc) sign | [] -> acc in @@ -920,10 +919,10 @@ let map_rel_context_in_env f env sign = let map_rel_context_with_binders f sign = let rec aux k = function - | d::sign -> map_rel_declaration (f k) d :: aux (k-1) sign + | d::sign -> Context.Rel.Declaration.map (f k) d :: aux (k-1) sign | [] -> [] in - aux (rel_context_length sign) sign + aux (Context.Rel.length sign) sign let substl_rel_context l = map_rel_context_with_binders (fun k -> substnl l (k-1)) @@ -955,7 +954,7 @@ let compact_named_context_reverse sign = if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 then (i1::l2,c2,t2)::q else ([i1],c1,t1)::l - in Context.fold_named_context_reverse compact ~init:[] sign + in Context.Named.fold_inside compact ~init:[] sign let compact_named_context sign = List.rev (compact_named_context_reverse sign) @@ -976,7 +975,7 @@ let global_vars_set_of_decl env = function let dependency_closure env sign hyps = if Id.Set.is_empty hyps then [] else let (_,lh) = - Context.fold_named_context_reverse + Context.Named.fold_inside (fun (hs,hl) (x,_,_ as d) -> if Id.Set.mem x hs then (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs), diff --git a/engine/termops.mli b/engine/termops.mli index 6083f1ab59..0fbd1ee82e 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -9,7 +9,6 @@ open Pp open Names open Term -open Context open Environ (** printers *) @@ -22,7 +21,7 @@ val set_print_constr : (env -> constr -> std_ppcmds) -> unit val print_constr : constr -> std_ppcmds val print_constr_env : env -> constr -> std_ppcmds val print_named_context : env -> std_ppcmds -val pr_rel_decl : env -> rel_declaration -> std_ppcmds +val pr_rel_decl : env -> Context.Rel.Declaration.t -> std_ppcmds val print_rel_context : env -> std_ppcmds val print_env : env -> std_ppcmds @@ -31,7 +30,7 @@ val push_rel_assum : Name.t * types -> env -> env val push_rels_assum : (Name.t * types) list -> env -> env val push_named_rec_types : Name.t array * types array * 'a -> env -> env -val lookup_rel_id : Id.t -> rel_context -> int * constr option * types +val lookup_rel_id : Id.t -> Context.Rel.t -> int * constr option * types (** Associates the contents of an identifier in a [rel_context]. Raise [Not_found] if there is no such identifier. *) @@ -42,20 +41,20 @@ val rel_vect : int -> int -> constr array val rel_list : int -> int -> constr list (** iterators/destructors on terms *) -val mkProd_or_LetIn : rel_declaration -> types -> types -val mkProd_wo_LetIn : rel_declaration -> types -> types +val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types +val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types val it_mkProd : types -> (Name.t * types) list -> types val it_mkLambda : constr -> (Name.t * types) list -> constr -val it_mkProd_or_LetIn : types -> rel_context -> types -val it_mkProd_wo_LetIn : types -> rel_context -> types -val it_mkLambda_or_LetIn : constr -> rel_context -> constr -val it_mkNamedProd_or_LetIn : types -> named_context -> types -val it_mkNamedProd_wo_LetIn : types -> named_context -> types -val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr +val it_mkProd_or_LetIn : types -> Context.Rel.t -> types +val it_mkProd_wo_LetIn : types -> Context.Rel.t -> types +val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr +val it_mkNamedProd_or_LetIn : types -> Context.Named.t -> types +val it_mkNamedProd_wo_LetIn : types -> Context.Named.t -> types +val it_mkNamedLambda_or_LetIn : constr -> Context.Named.t -> constr (* Ad hoc version reinserting letin, assuming the body is defined in the context where the letins are expanded *) -val it_mkLambda_or_LetIn_from_no_LetIn : constr -> rel_context -> constr +val it_mkLambda_or_LetIn_from_no_LetIn : constr -> Context.Rel.t -> constr (** {6 Generic iterators on constr} *) @@ -63,11 +62,11 @@ val map_constr_with_named_binders : (Name.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_binders_left_to_right : - (rel_declaration -> 'a -> 'a) -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : - (rel_declaration -> 'a -> 'a) -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate @@ -81,11 +80,11 @@ val fold_constr_with_binders : ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val fold_constr_with_full_binders : - (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val iter_constr_with_full_binders : - (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (**********************************************************************) @@ -110,7 +109,7 @@ val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool val dependent_univs : constr -> constr -> bool val dependent_univs_no_evar : constr -> constr -> bool -val dependent_in_decl : constr -> named_declaration -> bool +val dependent_in_decl : constr -> Context.Named.Declaration.t -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) @@ -164,11 +163,11 @@ exception CannotFilter (context,term), or raises [CannotFilter]. Warning: Outer-kernel sort subtyping are taken into account: c1 has to be smaller than c2 wrt. sorts. *) -type subst = (rel_context*constr) Evar.Map.t -val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst +type subst = (Context.Rel.t * constr) Evar.Map.t +val filtering : Context.Rel.t -> Reduction.conv_pb -> constr -> constr -> subst -val decompose_prod_letin : constr -> int * rel_context * constr -val align_prod_letin : constr -> constr -> rel_context * constr +val decompose_prod_letin : constr -> int * Context.Rel.t * constr +val align_prod_letin : constr -> constr -> Context.Rel.t * constr (** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction gives {% $ %}n{% $ %} (casts are ignored) *) @@ -197,51 +196,51 @@ val add_name : Name.t -> names_context -> names_context val lookup_name_of_rel : int -> names_context -> Name.t val lookup_rel_of_name : Id.t -> names_context -> int val empty_names_context : names_context -val ids_of_rel_context : rel_context -> Id.t list -val ids_of_named_context : named_context -> Id.t list +val ids_of_rel_context : Context.Rel.t -> Id.t list +val ids_of_named_context : Context.Named.t -> Id.t list val ids_of_context : env -> Id.t list val names_of_rel_context : env -> names_context (* [context_chop n Γ] returns (Γ₁,Γ₂) such that [Γ]=[Γ₂Γ₁], [Γ₁] has [n] hypotheses, excluding local definitions, and [Γ₁], if not empty, starts with an hypothesis (i.e. [Γ₁] has the form empty or [x:A;Γ₁'] *) -val context_chop : int -> rel_context -> rel_context * rel_context +val context_chop : int -> Context.Rel.t -> Context.Rel.t * Context.Rel.t (* [env_rel_context_chop n env] extracts out the [n] top declarations of the rel_context part of [env], counting both local definitions and hypotheses *) -val env_rel_context_chop : int -> env -> env * rel_context +val env_rel_context_chop : int -> env -> env * Context.Rel.t (** Set of local names *) val vars_of_env: env -> Id.Set.t val add_vname : Id.Set.t -> Name.t -> Id.Set.t (** other signature iterators *) -val process_rel_context : (rel_declaration -> env -> env) -> env -> env -val assums_of_rel_context : rel_context -> (Name.t * constr) list -val lift_rel_context : int -> rel_context -> rel_context -val substl_rel_context : constr list -> rel_context -> rel_context -val smash_rel_context : rel_context -> rel_context (** expand lets in context *) +val process_rel_context : (Context.Rel.Declaration.t -> env -> env) -> env -> env +val assums_of_rel_context : Context.Rel.t -> (Name.t * constr) list +val lift_rel_context : int -> Context.Rel.t -> Context.Rel.t +val substl_rel_context : constr list -> Context.Rel.t -> Context.Rel.t +val smash_rel_context : Context.Rel.t -> Context.Rel.t (** expand lets in context *) val map_rel_context_in_env : - (env -> constr -> constr) -> env -> rel_context -> rel_context + (env -> constr -> constr) -> env -> Context.Rel.t -> Context.Rel.t val map_rel_context_with_binders : - (int -> constr -> constr) -> rel_context -> rel_context + (int -> constr -> constr) -> Context.Rel.t -> Context.Rel.t val fold_named_context_both_sides : - ('a -> named_declaration -> named_declaration list -> 'a) -> - named_context -> init:'a -> 'a -val mem_named_context : Id.t -> named_context -> bool -val compact_named_context : named_context -> named_list_context -val compact_named_context_reverse : named_context -> named_list_context + ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) -> + Context.Named.t -> init:'a -> 'a +val mem_named_context : Id.t -> Context.Named.t -> bool +val compact_named_context : Context.Named.t -> Context.NamedList.t +val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t val clear_named_body : Id.t -> env -> env val global_vars : env -> constr -> Id.t list -val global_vars_set_of_decl : env -> named_declaration -> Id.Set.t +val global_vars_set_of_decl : env -> Context.Named.Declaration.t -> Id.Set.t (** Gives an ordered list of hypotheses, closed by dependencies, containing a given set *) -val dependency_closure : env -> named_context -> Id.Set.t -> Id.t list +val dependency_closure : env -> Context.Named.t -> Id.Set.t -> Id.t list (** Test if an identifier is the basename of a global reference *) val is_section_variable : Id.t -> bool diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index a6c42b28c2..d8b8bd4610 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -187,12 +187,12 @@ let process_goal sigma g = Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) in let process_hyp d (env,l) = - let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in + let d = Context.NamedList.Declaration.map (Reductionops.nf_evar sigma) d in let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in (List.fold_right Environ.push_named d' env, (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in let (_env, hyps) = - Context.fold_named_list_context process_hyp + Context.NamedList.fold process_hyp (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } diff --git a/interp/constrextern.mli b/interp/constrextern.mli index b797e455c0..ff8ca0b7cc 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Termops open Environ open Libnames @@ -42,7 +41,7 @@ val extern_reference : Loc.t -> Id.Set.t -> global_reference -> reference val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr val extern_sort : Evd.evar_map -> sorts -> glob_sort val extern_rel_context : constr option -> env -> Evd.evar_map -> - rel_context -> local_binder list + Context.Rel.t -> local_binder list (** Printing options *) val print_implicits : bool ref diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 8a86d30220..918b75b0c1 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -101,7 +101,7 @@ let global_reference id = let construct_reference ctx id = try - Term.mkVar (let _ = Context.lookup_named id ctx in id) + Term.mkVar (let _ = Context.Named.lookup id ctx in id) with Not_found -> global_reference id @@ -685,7 +685,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = str "variable " ++ pr_id id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) - let _ = Context.lookup_named id namedctx in + let _ = Context.Named.lookup id namedctx in try (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index b671c98815..c851fbb369 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Evd open Environ open Libnames @@ -161,7 +160,7 @@ val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> types val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> env -> evar_map ref -> local_binder list -> - internalization_env * ((env * rel_context) * Impargs.manual_implicits) + internalization_env * ((env * Context.Rel.t) * Impargs.manual_implicits) (* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) (* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) @@ -178,7 +177,7 @@ val interp_context_evars : val locate_reference : Libnames.qualid -> Globnames.global_reference val is_global : Id.t -> bool -val construct_reference : named_context -> Id.t -> constr +val construct_reference : Context.Named.t -> Id.t -> constr val global_reference : Id.t -> constr val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr diff --git a/kernel/context.ml b/kernel/context.ml index 5923048fa4..372f16a8d5 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -15,137 +15,233 @@ (* This file defines types and combinators regarding indexes-based and names-based contexts *) -open Util -open Names - -(***************************************************************************) -(* Type of assumptions *) -(***************************************************************************) - -type named_declaration = Id.t * Constr.t option * Constr.t -type named_list_declaration = Id.t list * Constr.t option * Constr.t -type rel_declaration = Name.t * Constr.t option * Constr.t - -let map_named_declaration_skel f (id, (v : Constr.t option), ty) = - (id, Option.map f v, f ty) -let map_named_list_declaration = map_named_declaration_skel -let map_named_declaration = map_named_declaration_skel - -let map_rel_declaration = map_named_declaration - -let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a) -let fold_rel_declaration = fold_named_declaration - -let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty -let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty - -let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty -let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty - -let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = - Id.equal i1 i2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 - -let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) = - Name.equal n1 n2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 - -(***************************************************************************) -(* Type of local contexts (telescopes) *) -(***************************************************************************) - -(*s Signatures of ordered optionally named variables, intended to be - accessed by de Bruijn indices (to represent bound variables) *) - -type rel_context = rel_declaration list - -let empty_rel_context = [] - -let add_rel_decl d ctxt = d::ctxt - -let rec lookup_rel n sign = - match n, sign with - | 1, decl :: _ -> decl - | n, _ :: sign -> lookup_rel (n-1) sign - | _, [] -> raise Not_found - -let rel_context_length = List.length +(** The modules defined below represent a {e local context} + as defined by Chapter 4 in the Reference Manual: -let rel_context_nhyps hyps = - let rec nhyps acc = function - | [] -> acc - | (_,None,_)::hyps -> nhyps (1+acc) hyps - | (_,Some _,_)::hyps -> nhyps acc hyps in - nhyps 0 hyps + A {e local context} is an ordered list of of {e local declarations} + of names that we call {e variables}. -let rel_context_tags ctx = - let rec aux l = function - | [] -> l - | (_,Some _,_)::ctx -> aux (true::l) ctx - | (_,None,_)::ctx -> aux (false::l) ctx - in aux [] ctx + A {e local declaration} of some variable can be either: + - a {e local assumption}, or + - a {e local definition}. +*) -(*s Signatures of named hypotheses. Used for section variables and - goal assumptions. *) - -type named_context = named_declaration list -type named_list_context = named_list_declaration list - -let empty_named_context = [] - -let add_named_decl d sign = d::sign - -let rec lookup_named id = function - | (id',_,_ as decl) :: _ when Id.equal id id' -> decl - | _ :: sign -> lookup_named id sign - | [] -> raise Not_found - -let named_context_length = List.length -let named_context_equal = List.equal eq_named_declaration - -let vars_of_named_context ctx = - List.fold_left (fun accu (id, _, _) -> Id.Set.add id accu) Id.Set.empty ctx - -let instance_from_named_context sign = - let filter = function - | (id, None, _) -> Some (Constr.mkVar id) - | (_, Some _, _) -> None - in - List.map_filter filter sign - -(** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] - with n = |Δ| and with the local definitions of [Γ] skipped in - [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) - -let extended_rel_list n hyps = - let rec reln l p = function - | (_, None, _) :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps - | (_, Some _, _) :: hyps -> reln l (p+1) hyps - | [] -> l - in - reln [] 1 hyps - -let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) - -let fold_named_context f l ~init = List.fold_right f l init -let fold_named_list_context f l ~init = List.fold_right f l init -let fold_named_context_reverse f ~init l = List.fold_left f init l - -(*s Signatures of ordered section variables *) -type section_context = named_context - -let fold_rel_context f l ~init:x = List.fold_right f l x -let fold_rel_context_reverse f ~init:x l = List.fold_left f x l - -let map_context f l = - let map_decl (n, body_o, typ as decl) = - let body_o' = Option.smartmap f body_o in - let typ' = f typ in - if body_o' == body_o && typ' == typ then decl else - (n, body_o', typ') - in - List.smartmap map_decl l - -let map_rel_context = map_context -let map_named_context = map_context +open Util +open Names -let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b) -let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b) +(** Representation of contexts that can capture anonymous as well as non-anonymous variables. + Individual declarations are then designated by de Bruijn indexes. *) +module Rel = + struct + (** Representation of {e local declarations}. + + [(name, None, typ)] represents a {e local assumption}. + In the Reference Manual we denote them as [(name:typ)]. + + [(name, Some value, typ)] represents a {e local definition}. + In the Reference Manual we denote them as [(name := value : typ)]. + *) + module Declaration = + struct + type t = Name.t * Constr.t option * Constr.t + + (** Map all terms in a given declaration. *) + let map f (n, v, ty) = (n, Option.map f v, f ty) + + (** Reduce all terms in a given declaration to a single value. *) + let fold f (_, v, ty) a = f ty (Option.fold_right f v a) + + (** Check whether any term in a given declaration satisfies a given predicate. *) + let exists f (_, v, ty) = Option.cata f false v || f ty + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + let for_all f (_, v, ty) = Option.cata f true v && f ty + + (** Check whether the two given declarations are equal. *) + let equal (n1, v1, ty1) (n2, v2, ty2) = + Name.equal n1 n2 && Option.equal Constr.equal v1 v2 && Constr.equal ty1 ty2 + end + + (** Rel-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list + + (** empty rel-context *) + let empty = [] + + (** Return a new rel-context enriched by with a given inner-most declaration. *) + let add d ctx = d :: ctx + + (** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated de Bruijn index is not present in the designated rel-context. *) + let rec lookup n ctx = + match n, ctx with + | 1, decl :: _ -> decl + | n, _ :: sign -> lookup (n-1) sign + | _, [] -> raise Not_found + + (** Map all terms in a given rel-context. *) + let map f = + let map_decl (n, body_o, typ as decl) = + let body_o' = Option.smartmap f body_o in + let typ' = f typ in + if body_o' == body_o && typ' == typ then decl else + (n, body_o', typ') + in + List.smartmap map_decl + + (** Reduce all terms in a given rel-context to a single value. + Innermost declarations are processed first. *) + let fold_inside f ~init = List.fold_left f init + + (** Reduce all terms in a given rel-context to a single value. + Outermost declarations are processed first. *) + let fold_outside f l ~init = List.fold_right f l init + + (** Perform a given action on every declaration in a given rel-context. *) + let iter f = List.iter (fun (_,b,t) -> f t; Option.iter f b) + + (** Return the number of {e local declarations} in a given context. *) + let length = List.length + + (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the local definitions of [Γ] skipped in + [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + let nhyps = + let rec nhyps acc = function + | [] -> acc + | (_,None,_)::hyps -> nhyps (1+acc) hyps + | (_,Some _,_)::hyps -> nhyps acc hyps in + nhyps 0 + + (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] + and each {e local definition} is mapped to [false]. *) + let to_tags = + let rec aux l = function + | [] -> l + | (_,Some _,_)::ctx -> aux (true::l) ctx + | (_,None,_)::ctx -> aux (false::l) ctx + in aux [] + + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the {e local definitions} of [Γ] skipped in + [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + let to_extended_list n = + let rec reln l p = function + | (_, None, _) :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps + | (_, Some _, _) :: hyps -> reln l (p+1) hyps + | [] -> l + in + reln [] 1 + + (** [extended_vect n Γ] does the same, returning instead an array. *) + let to_extended_vect n hyps = Array.of_list (to_extended_list n hyps) + end + +(** This module represents contexts that can capture non-anonymous variables. + Individual declarations are then designated by the identifiers they bind. *) +module Named = + struct + (** Representation of {e local declarations}. + + [(id, None, typ)] represents a {e local assumption}. + In the Reference Manual we denote them as [(name:typ)]. + + [(id, Some value, typ)] represents a {e local definition}. + In the Reference Manual we denote them as [(name := value : typ)]. + *) + module Declaration = + struct + (** Named-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Id.t * Constr.t option * Constr.t + + (** Map all terms in a given declaration. *) + let map = Rel.Declaration.map + + (** Reduce all terms in a given declaration to a single value. *) + let fold f (_, v, ty) a = f ty (Option.fold_right f v a) + + (** Check whether any term in a given declaration satisfies a given predicate. *) + let exists f (_, v, ty) = Option.cata f false v || f ty + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + let for_all f (_, v, ty) = Option.cata f true v && f ty + + (** Check whether the two given declarations are equal. *) + let equal (i1, v1, ty1) (i2, v2, ty2) = + Id.equal i1 i2 && Option.equal Constr.equal v1 v2 && Constr.equal ty1 ty2 + end + + type t = Declaration.t list + + (** empty named-context *) + let empty = [] + + (** empty named-context *) + let add d ctx = d :: ctx + + (** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated identifier is not present in the designated named-context. *) + let rec lookup id = function + | (id',_,_ as decl) :: _ when Id.equal id id' -> decl + | _ :: sign -> lookup id sign + | [] -> raise Not_found + + (** Map all terms in a given named-context. *) + let map f = + let map_decl (n, body_o, typ as decl) = + let body_o' = Option.smartmap f body_o in + let typ' = f typ in + if body_o' == body_o && typ' == typ then decl else + (n, body_o', typ') + in + List.smartmap map_decl + + (** Reduce all terms in a given named-context to a single value. + Innermost declarations are processed first. *) + let fold_inside f ~init = List.fold_left f init + + (** Reduce all terms in a given named-context to a single value. + Outermost declarations are processed first. *) + let fold_outside f l ~init = List.fold_right f l init + + (** Perform a given action on every declaration in a given named-context. *) + let iter f = List.iter (fun (_,b,t) -> f t; Option.iter f b) + + (** Return the number of {e local declarations} in a given named-context. *) + let length = List.length + + (** Check whether given two named-contexts are equal. *) + let equal = List.equal Declaration.equal + + (** Return the set of all identifiers bound in a given named-context. *) + let to_vars = + List.fold_left (fun accu (id, _, _) -> Id.Set.add id accu) Id.Set.empty + + (** [instance_from_named_context Ω] builds an instance [args] such + that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local + definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it + gives [Var id1, Var id3]. All [idj] are supposed distinct. *) + let to_instance = + let filter = function + | (id, None, _) -> Some (Constr.mkVar id) + | (_, Some _, _) -> None + in + List.map_filter filter + end + +module NamedList = + struct + module Declaration = + struct + type t = Id.t list * Constr.t option * Constr.t + let map = Named.Declaration.map + end + type t = Declaration.t list + let fold f l ~init = List.fold_right f l init + end + +type section_context = Named.t diff --git a/kernel/context.mli b/kernel/context.mli index 7354677474..0db82beb57 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -6,131 +6,186 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** The modules defined below represent a {e local context} + as defined by Chapter 4 in the Reference Manual: + + A {e local context} is an ordered list of of {e local declarations} + of names that we call {e variables}. + + A {e local declaration} of some variable can be either: + - a {e local assumption}, or + - a {e local definition}. + + {e Local assumptions} are denoted in the Reference Manual as [(name : typ)] and + {e local definitions} are there denoted as [(name := value : typ)]. +*) + open Names -(** TODO: cleanup *) +(** Representation of contexts that can capture anonymous as well as non-anonymous variables. + Individual declarations are then designated by de Bruijn indexes. *) +module Rel : +sig + (** Representation of {e local declarations}. + + [(name, None, typ)] represents a {e local assumption}. + + [(name, Some value, typ)] represents a {e local definition}. + *) + module Declaration : + sig + type t = Name.t * Constr.t option * Constr.t + + (** Map all terms in a given declaration. *) + val map : (Constr.t -> Constr.t) -> t -> t + + (** Reduce all terms in a given declaration to a single value. *) + val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + + (** Check whether any term in a given declaration satisfies a given predicate. *) + val exists : (Constr.t -> bool) -> t -> bool + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + val for_all : (Constr.t -> bool) -> t -> bool + + (** Check whether the two given declarations are equal. *) + val equal : t -> t -> bool + end + + (** Rel-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list + + (** empty rel-context *) + val empty : t + + (** Return a new rel-context enriched by with a given inner-most declaration. *) + val add : Declaration.t -> t -> t + + (** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated de Bruijn index outside the range. *) + val lookup : int -> t -> Declaration.t + + (** Map all terms in a given rel-context. *) + val map : (Constr.t -> Constr.t) -> t -> t -(** {6 Declarations} *) -(** A {e declaration} has the form [(name,body,type)]. It is either an - {e assumption} if [body=None] or a {e definition} if - [body=Some actualbody]. It is referred by {e name} if [na] is an - identifier or by {e relative index} if [na] is not an identifier - (in the latter case, [na] is of type [name] but just for printing - purpose) *) + (** Reduce all terms in a given rel-context to a single value. + Innermost declarations are processed first. *) + val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a -type named_declaration = Id.t * Constr.t option * Constr.t -type named_list_declaration = Id.t list * Constr.t option * Constr.t -type rel_declaration = Name.t * Constr.t option * Constr.t + (** Reduce all terms in a given rel-context to a single value. + Outermost declarations are processed first. *) + val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a -val map_named_declaration : - (Constr.t -> Constr.t) -> named_declaration -> named_declaration -val map_named_list_declaration : - (Constr.t -> Constr.t) -> named_list_declaration -> named_list_declaration -val map_rel_declaration : - (Constr.t -> Constr.t) -> rel_declaration -> rel_declaration + (** Perform a given action on every declaration in a given rel-context. *) + val iter : (Constr.t -> unit) -> t -> unit -val fold_named_declaration : - (Constr.t -> 'a -> 'a) -> named_declaration -> 'a -> 'a -val fold_rel_declaration : - (Constr.t -> 'a -> 'a) -> rel_declaration -> 'a -> 'a + (** Return the number of {e local declarations} in a given context. *) + val length : t -> int -val exists_named_declaration : - (Constr.t -> bool) -> named_declaration -> bool -val exists_rel_declaration : - (Constr.t -> bool) -> rel_declaration -> bool + (** Return the number of {e local assumptions} in a given rel-context. *) + val nhyps : t -> int -val for_all_named_declaration : - (Constr.t -> bool) -> named_declaration -> bool -val for_all_rel_declaration : - (Constr.t -> bool) -> rel_declaration -> bool + (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] + and each {e local definition} is mapped to [false]. *) + val to_tags : t -> bool list -val eq_named_declaration : - named_declaration -> named_declaration -> bool + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the {e local definitions} of [Γ] skipped in + [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + val to_extended_list : int -> t -> Constr.t list -val eq_rel_declaration : - rel_declaration -> rel_declaration -> bool + (** [extended_vect n Γ] does the same, returning instead an array. *) + val to_extended_vect : int -> t -> Constr.t array +end -(** {6 Signatures of ordered named declarations } *) +(** This module represents contexts that can capture non-anonymous variables. + Individual declarations are then designated by the identifiers they bind. *) +module Named : +sig + (** Representation of {e local declarations}. -type named_context = named_declaration list -type section_context = named_context -type named_list_context = named_list_declaration list -type rel_context = rel_declaration list -(** In [rel_context], more recent declaration is on top *) + [(id, None, typ)] represents a {e local assumption}. -val empty_named_context : named_context -val add_named_decl : named_declaration -> named_context -> named_context -val vars_of_named_context : named_context -> Id.Set.t + [(id, Some value, typ)] represents a {e local definition}. + *) + module Declaration : + sig + type t = Id.t * Constr.t option * Constr.t -val lookup_named : Id.t -> named_context -> named_declaration + (** Map all terms in a given declaration. *) + val map : (Constr.t -> Constr.t) -> t -> t -(** number of declarations *) -val named_context_length : named_context -> int + (** Reduce all terms in a given declaration to a single value. *) + val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a -(** named context equality *) -val named_context_equal : named_context -> named_context -> bool + (** Check whether any term in a given declaration satisfies a given predicate. *) + val exists : (Constr.t -> bool) -> t -> bool -(** {6 Recurrence on [named_context]: older declarations processed first } *) -val fold_named_context : - (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a + (** Check whether all terms in a given declaration satisfy a given predicate. *) + val for_all : (Constr.t -> bool) -> t -> bool -val fold_named_list_context : - (named_list_declaration -> 'a -> 'a) -> named_list_context -> init:'a -> 'a + (** Check whether the two given declarations are equal. *) + val equal : t -> t -> bool + end -(** newer declarations first *) -val fold_named_context_reverse : - ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a + (** Rel-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list -(** {6 Section-related auxiliary functions } *) + (** empty named-context *) + val empty : t -(** [instance_from_named_context Ω] builds an instance [args] such - that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local - definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it - gives [Var id1, Var id3]. All [idj] are supposed distinct. *) -val instance_from_named_context : named_context -> Constr.t list + (** Return a new rel-context enriched by with a given inner-most declaration. *) + val add : Declaration.t -> t -> t -(** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] - with n = |Δ| and with the local definitions of [Γ] skipped in - [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) -val extended_rel_list : int -> rel_context -> Constr.t list + (** Return a declaration designated by an identifier of the variable bound in that declaration. + @raise Not_found if the designated identifier is not bound in a given named-context. *) + val lookup : Id.t -> t -> Declaration.t -(** [extended_rel_vect n Γ] does the same, returning instead an array. *) -val extended_rel_vect : int -> rel_context -> Constr.t array + (** Map all terms in a given named-context. *) + val map : (Constr.t -> Constr.t) -> t -> t -(** {6 ... } *) -(** Signatures of ordered optionally named variables, intended to be - accessed by de Bruijn indices *) + (** Reduce all terms in a given named-context to a single value. + Innermost declarations are processed first. *) + val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a -(** {6 Recurrence on [rel_context]: older declarations processed first } *) -val fold_rel_context : - (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a + (** Reduce all terms in a given named-context to a single value. + Outermost declarations are processed first. *) + val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a -(** newer declarations first *) -val fold_rel_context_reverse : - ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a + (** Perform a given action on every declaration in a given named-context. *) + val iter : (Constr.t -> unit) -> t -> unit -(** {6 Map function of [rel_context] } *) -val map_rel_context : (Constr.t -> Constr.t) -> rel_context -> rel_context + (** Return the number of {e local declarations} in a given named-context. *) + val length : t -> int -(** {6 Map function of [named_context] } *) -val map_named_context : (Constr.t -> Constr.t) -> named_context -> named_context + (** Check whether given two named-contexts are equal. *) + val equal : t -> t -> bool -(** {6 Map function of [rel_context] } *) -val iter_rel_context : (Constr.t -> unit) -> rel_context -> unit + (** Return the set of all identifiers bound in a given named-context. *) + val to_vars : t -> Id.Set.t -(** {6 Map function of [named_context] } *) -val iter_named_context : (Constr.t -> unit) -> named_context -> unit + (** [instance_from_named_context Ω] builds an instance [args] such + that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local + definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it + gives [Var id1, Var id3]. All [idj] are supposed distinct. *) + val to_instance : t -> Constr.t list +end -(** {6 Contexts of declarations referred to by de Bruijn indices } *) +module NamedList : +sig + module Declaration : + sig + type t = Id.t list * Constr.t option * Constr.t + val map : (Constr.t -> Constr.t) -> t -> t + end -val empty_rel_context : rel_context -val add_rel_decl : rel_declaration -> rel_context -> rel_context + type t = Declaration.t list -val lookup_rel : int -> rel_context -> rel_declaration -(** Size of the [rel_context] including LetIns *) -val rel_context_length : rel_context -> int -(** Size of the [rel_context] without LetIns *) -val rel_context_nhyps : rel_context -> int -(** Indicates whether a LetIn or a Lambda, starting from oldest declaration *) -val rel_context_tags : rel_context -> bool list + val fold : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a +end +type section_context = Named.t diff --git a/kernel/cooking.ml b/kernel/cooking.ml index be71bd7b41..1302e71c95 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -173,7 +173,7 @@ let expmod_constr_subst cache modlist subst c = let cook_constr { Opaqueproof.modlist ; abstract } c = let cache = RefTable.create 13 in let expmod = expmod_constr_subst cache modlist (pi2 abstract) in - let hyps = Context.map_named_context expmod (pi1 abstract) in + let hyps = Context.Named.map expmod (pi1 abstract) in abstract_constant_body (expmod c) hyps let lift_univs cb subst = @@ -195,13 +195,13 @@ let cook_constant env { from = cb; info } = let abstract, usubst, abs_ctx = abstract in let usubst, univs = lift_univs cb usubst in let expmod = expmod_constr_subst cache modlist usubst in - let hyps = Context.map_named_context expmod abstract in + let hyps = Context.Named.map expmod abstract in let body = on_body modlist (hyps, usubst, abs_ctx) (fun c -> abstract_constant_body (expmod c) hyps) cb.const_body in let const_hyps = - Context.fold_named_context (fun (h,_,_) hyps -> + Context.Named.fold_outside (fun (h,_,_) hyps -> List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index aa9ef66fe3..2067eb899e 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -15,7 +15,6 @@ open Util open Names open Term -open Context open Vm open Cemitcodes open Cbytecodes @@ -190,7 +189,7 @@ and slot_for_fv env fv = let nv = Pre_env.lookup_named_val id env in begin match force_lazy_val nv with | None -> - let _, b, _ = Context.lookup_named id env.env_named_context in + let _, b, _ = Context.Named.lookup id env.env_named_context in fill_fv_cache nv id val_of_named idfun b | Some (v, _) -> v end @@ -198,7 +197,7 @@ and slot_for_fv env fv = let rv = Pre_env.lookup_rel_val i env in begin match force_lazy_val rv with | None -> - let _, b, _ = lookup_rel i env.env_rel_context in + let _, b, _ = Context.Rel.lookup i env.env_rel_context in fill_fv_cache rv i val_of_rel env_of_rel b | Some (v, _) -> v end diff --git a/kernel/declarations.mli b/kernel/declarations.mli index dc5c17a75b..981dfe05ef 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -8,7 +8,6 @@ open Names open Term -open Context (** This module defines the internal representation of global declarations. This includes global constants/axioms, mutual @@ -38,7 +37,7 @@ type ('a, 'b) declaration_arity = | RegularArity of 'a | TemplateArity of 'b -type constant_type = (types, rel_context * template_arity) declaration_arity +type constant_type = (types, Context.Rel.t * template_arity) declaration_arity (** Inlining level of parameters at functor applications. None means no inlining *) @@ -117,7 +116,7 @@ type one_inductive_body = { mind_typename : Id.t; (** Name of the type: [Ii] *) - mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) + mind_arity_ctxt : Context.Rel.t; (** Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity : inductive_arity; (** Arity sort and original user arity *) @@ -171,7 +170,7 @@ type mutual_inductive_body = { mind_nparams_rec : int; (** Number of recursively uniform (i.e. ordinary) parameters *) - mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) + mind_params_ctxt : Context.Rel.t; (** The context of parameters (includes let-in declaration) *) mind_polymorphic : bool; (** Is it polymorphic or not *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 73cfd01221..6239d3c8d6 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -254,7 +254,7 @@ let subst_mind_body sub mib = mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; mind_params_ctxt = - Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt; + Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; mind_polymorphic = mib.mind_polymorphic; mind_universes = mib.mind_universes; diff --git a/kernel/environ.ml b/kernel/environ.ml index 09fe64d77b..da540bb051 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -24,7 +24,6 @@ open Errors open Util open Names open Term -open Context open Vars open Declarations open Pre_env @@ -70,7 +69,7 @@ let empty_context env = (* Rel context *) let lookup_rel n env = - lookup_rel n env.env_rel_context + Context.Rel.lookup n env.env_rel_context let evaluable_rel n env = match lookup_rel n env with @@ -81,7 +80,7 @@ let nb_rel env = env.env_nb_rel let push_rel = push_rel -let push_rel_context ctxt x = Context.fold_rel_context push_rel ctxt ~init:x +let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in @@ -120,7 +119,7 @@ let map_named_val f (ctxt,ctxtv) = in (map ctxt, ctxtv) -let empty_named_context = empty_named_context +let empty_named_context = Context.Named.empty let push_named = push_named let push_named_context = List.fold_right push_named @@ -130,11 +129,11 @@ let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val -let lookup_named id env = Context.lookup_named id env.env_named_context -let lookup_named_val id (ctxt,_) = Context.lookup_named id ctxt +let lookup_named id env = Context.Named.lookup id env.env_named_context +let lookup_named_val id (ctxt,_) = Context.Named.lookup id ctxt let eq_named_context_val c1 c2 = - c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2) + c1 == c2 || Context.Named.equal (named_context_of_val c1) (named_context_of_val c2) (* A local const is evaluable if it is defined *) @@ -153,7 +152,7 @@ let reset_with_named_context (ctxt,ctxtv) env = { env with env_named_context = ctxt; env_named_vals = ctxtv; - env_rel_context = empty_rel_context; + env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0 } @@ -176,7 +175,7 @@ let fold_named_context f env ~init = in fold_right env let fold_named_context_reverse f ~init env = - Context.fold_named_context_reverse f ~init:init (named_context env) + Context.Named.fold_inside f ~init:init (named_context env) (* Universe constraints *) @@ -389,11 +388,11 @@ let add_mind kn mib env = let lookup_constant_variables c env = let cmap = lookup_constant c env in - Context.vars_of_named_context cmap.const_hyps + Context.Named.to_vars cmap.const_hyps let lookup_inductive_variables (kn,i) env = let mis = lookup_mind kn env in - Context.vars_of_named_context mis.mind_hyps + Context.Named.to_vars mis.mind_hyps let lookup_constructor_variables (ind,_) env = lookup_inductive_variables ind env @@ -427,7 +426,7 @@ let global_vars_set env constr = contained in the types of the needed variables. *) let really_needed env needed = - Context.fold_named_context_reverse + Context.Named.fold_inside (fun need (id,copt,t) -> if Id.Set.mem id need then let globc = @@ -443,9 +442,9 @@ let really_needed env needed = let keep_hyps env needed = let really_needed = really_needed env needed in - Context.fold_named_context + Context.Named.fold_outside (fun (id,_,_ as d) nsign -> - if Id.Set.mem id really_needed then add_named_decl d nsign + if Id.Set.mem id really_needed then Context.Named.add d nsign else nsign) (named_context env) ~init:empty_named_context diff --git a/kernel/environ.mli b/kernel/environ.mli index 2eab32e723..f3fe4d6aef 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Declarations open Univ @@ -42,8 +41,8 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> UGraph.t -val rel_context : env -> rel_context -val named_context : env -> named_context +val rel_context : env -> Context.Rel.t +val named_context : env -> Context.Named.t val named_context_val : env -> named_context_val val opaque_tables : env -> Opaqueproof.opaquetab @@ -60,25 +59,25 @@ val empty_context : env -> bool (** {5 Context of de Bruijn variables ([rel_context]) } *) val nb_rel : env -> int -val push_rel : rel_declaration -> env -> env -val push_rel_context : rel_context -> env -> env +val push_rel : Context.Rel.Declaration.t -> env -> env +val push_rel_context : Context.Rel.t -> env -> env val push_rec_types : rec_declaration -> env -> env (** Looks up in the context of local vars referred by indice ([rel_context]) raises [Not_found] if the index points out of the context *) -val lookup_rel : int -> env -> rel_declaration +val lookup_rel : int -> env -> Context.Rel.Declaration.t val evaluable_rel : int -> env -> bool (** {6 Recurrence on [rel_context] } *) val fold_rel_context : - (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a + (env -> Context.Rel.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a (** {5 Context of variables (section variables and goal assumptions) } *) -val named_context_of_val : named_context_val -> named_context +val named_context_of_val : named_context_val -> Context.Named.t val named_vals_of_val : named_context_val -> Pre_env.named_vals -val val_of_named_context : named_context -> named_context_val +val val_of_named_context : Context.Named.t -> named_context_val val empty_named_context_val : named_context_val @@ -88,18 +87,18 @@ val empty_named_context_val : named_context_val val map_named_val : (constr -> constr) -> named_context_val -> named_context_val -val push_named : named_declaration -> env -> env -val push_named_context : named_context -> env -> env +val push_named : Context.Named.Declaration.t -> env -> env +val push_named_context : Context.Named.t -> env -> env val push_named_context_val : - named_declaration -> named_context_val -> named_context_val + Context.Named.Declaration.t -> named_context_val -> named_context_val (** Looks up in the context of local vars referred by names ([named_context]) raises [Not_found] if the Id.t is not found *) -val lookup_named : variable -> env -> named_declaration -val lookup_named_val : variable -> named_context_val -> named_declaration +val lookup_named : variable -> env -> Context.Named.Declaration.t +val lookup_named_val : variable -> named_context_val -> Context.Named.Declaration.t val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option @@ -107,11 +106,11 @@ val named_body : variable -> env -> constr option (** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : - (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a + (env -> Context.Named.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : - ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a + ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a (** This forgets named and rel contexts *) val reset_context : env -> env @@ -228,7 +227,7 @@ val vars_of_global : env -> constr -> Id.Set.t val really_needed : env -> Id.Set.t -> Id.Set.t (** like [really_needed] but computes a well ordered named context *) -val keep_hyps : env -> Id.Set.t -> section_context +val keep_hyps : env -> Id.Set.t -> Context.section_context (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is @@ -258,22 +257,22 @@ exception Hyp_not_found return [tail::(f head (id,_,_) (rev tail))::head]. the value associated to id should not change *) val apply_to_hyp : named_context_val -> variable -> - (named_context -> named_declaration -> named_context -> named_declaration) -> + (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) -> named_context_val (** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into [tail::(id,_,_)::head] and return [(g tail)::(f (id,_,_))::head]. *) val apply_to_hyp_and_dependent_on : named_context_val -> variable -> - (named_declaration -> named_context_val -> named_declaration) -> - (named_declaration -> named_context_val -> named_declaration) -> + (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> + (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> named_context_val val insert_after_hyp : named_context_val -> variable -> - named_declaration -> - (named_context -> unit) -> named_context_val + Context.Named.Declaration.t -> + (Context.Named.t -> unit) -> named_context_val -val remove_hyps : Id.Set.t -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val +val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index b625478f25..85c74534ef 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -90,7 +90,7 @@ let judge_of_variable env id = variables of the current env *) (* TODO: check order? *) let check_hyps_inclusion env f c sign = - Context.fold_named_context + Context.Named.fold_outside (fun (id,_,ty1) () -> try let ty2 = named_type id env in diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 11df40caf3..da2d213ff1 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -12,7 +12,6 @@ open Names open Univ open Term open Vars -open Context open Declarations open Declareops open Inductive @@ -341,7 +340,7 @@ let typecheck_inductive env mie = type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int - | LocalNotConstructor of rel_context * constr list + | LocalNotConstructor of Context.Rel.t * constr list | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -361,7 +360,7 @@ let explain_ind_err id ntyp env nbpar c err = raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) | LocalNotConstructor (paramsctxt,args)-> - let nparams = rel_context_nhyps paramsctxt in + let nparams = Context.Rel.nhyps paramsctxt in raise (InductiveError (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams, List.length args - nparams))) @@ -384,7 +383,7 @@ let failwith_non_pos_list n ntypes l = (* Check the inductive type is called with the expected parameters *) let check_correct_par (env,n,ntypes,_) hyps l largs = - let nparams = rel_context_nhyps hyps in + let nparams = Context.Rel.nhyps hyps in let largs = Array.of_list largs in if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); @@ -465,8 +464,8 @@ let array_min nmr a = if Int.equal nmr 0 then 0 else arguments (used to generate induction schemes, so a priori less relevant to the kernel). *) let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = - let lparams = rel_context_length hyps in - let nmr = rel_context_nhyps hyps in + let lparams = Context.Rel.length hyps in + let nmr = Context.Rel.nhyps hyps in (** Positivity of one argument [c] of a constructor (i.e. the constructor [cn] has a type of the shape [… -> c … -> P], where, more generally, the arrows may be dependent). *) @@ -617,13 +616,13 @@ let check_positivity kn env_ar params inds = let ntypes = Array.length inds in let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = Array.rev_to_list rc in - let lparams = rel_context_length params in - let nmr = rel_context_nhyps params in + let lparams = Context.Rel.length params in + let nmr = Context.Rel.nhyps params in let check_one i (_,lcnames,lc,(sign,_)) = let ra_env = List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in - let nargs = rel_context_nhyps sign - nmr in + let nargs = Context.Rel.nhyps sign - nmr in check_positivity_one ienv params (kn,i) nargs lcnames lc in let irecargs_nmr = Array.mapi check_one inds in @@ -697,7 +696,7 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params matching with a parameter context. *) let indty, paramsletsubst = (* [ty] = [Ind inst] is typed in context [params] *) - let inst = extended_rel_vect 0 paramslet in + let inst = Context.Rel.to_extended_vect 0 paramslet in let ty = mkApp (mkIndU indu, inst) in (* [Ind inst] is typed in context [params-wo-let] *) let inst' = rel_list 0 nparamargs in @@ -710,7 +709,7 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params in let ci = let print_info = - { ind_tags = []; cstr_tags = [|rel_context_tags ctx|]; style = LetStyle } in + { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in { ci_ind = ind; ci_npar = nparamargs; ci_cstr_ndecls = mind_consnrealdecls; @@ -783,8 +782,8 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in - let nparamargs = rel_context_nhyps params in - let nparamdecls = rel_context_length params in + let nparamargs = Context.Rel.nhyps params in + let nparamdecls = Context.Rel.length params in let subst, ctx = Univ.abstract_universes p ctx in let params = Vars.subst_univs_level_context subst params in let env_ar = @@ -799,10 +798,10 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in let consnrealdecls = - Array.map (fun (d,_) -> rel_context_length d - rel_context_length params) + Array.map (fun (d,_) -> Context.Rel.length d - Context.Rel.length params) splayed_lc in let consnrealargs = - Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params) + Array.map (fun (d,_) -> Context.Rel.nhyps d - Context.Rel.nhyps params) splayed_lc in (* Elimination sorts *) let arkind,kelim = @@ -835,8 +834,8 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re { mind_typename = id; mind_arity = arkind; mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign; - mind_nrealargs = rel_context_nhyps ar_sign - nparamargs; - mind_nrealdecls = rel_context_length ar_sign - nparamdecls; + mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs; + mind_nrealdecls = Context.Rel.length ar_sign - nparamdecls; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealdecls; diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 01acdce5c8..1fe47b1a50 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -42,6 +42,6 @@ val enforce_indices_matter : unit -> unit val is_indices_matter : unit -> bool val compute_projections : pinductive -> Id.t -> Id.t -> - int -> Context.rel_context -> int array -> int array -> - Context.rel_context -> Context.rel_context -> + int -> Context.Rel.t -> int array -> int array -> + Context.Rel.t -> Context.Rel.t -> (constant array * projection_body array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 632b4daeae..f9a6e04c12 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -12,7 +12,6 @@ open Names open Univ open Term open Vars -open Context open Declarations open Declareops open Environ @@ -77,7 +76,7 @@ let instantiate_params full t u args sign = let fail () = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = - Context.fold_rel_context + Context.Rel.fold_outside (fun (_,copt,_) (largs,subs,ty) -> match (copt, largs, kind_of_term ty) with | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) @@ -297,7 +296,7 @@ let build_dependent_inductive ind (_,mip) params = applist (mkIndU ind, List.map (lift mip.mind_nrealdecls) params - @ extended_rel_list 0 realargs) + @ Context.Rel.to_extended_list 0 realargs) (* This exception is local *) exception LocalArity of (sorts_family * sorts_family * arity_error) option @@ -350,12 +349,12 @@ let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (cstrsign,ccl) = decompose_prod_assum typi in - let nargs = rel_context_length cstrsign in + let nargs = Context.Rel.length cstrsign in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstructU (cstr,u),lparams@(extended_rel_list 0 cstrsign)) in + let dep_cstr = applist (mkConstructU (cstr,u),lparams@(Context.Rel.to_extended_list 0 cstrsign)) in vargs @ [dep_cstr] in let base = lambda_appvect_assum (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base cstrsign in @@ -499,7 +498,7 @@ let subterm_var p renv = with Failure _ | Invalid_argument _ -> Not_subterm let push_ctxt_renv renv ctxt = - let n = rel_context_length ctxt in + let n = Context.Rel.length ctxt in { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } @@ -701,7 +700,7 @@ let restrict_spec env spec p = else let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) - if noccur_with_meta 1 (rel_context_length absctx) ar then spec + if noccur_with_meta 1 (Context.Rel.length absctx) ar then spec else let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in @@ -843,7 +842,7 @@ let filter_stack_domain env ci p stack = let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) - if noccur_with_meta 1 (rel_context_length absctx) ar then stack + if noccur_with_meta 1 (Context.Rel.length absctx) ar then stack else let env = push_rel_context absctx env in let rec filter_stack env ar stack = let t = whd_betadeltaiota env ar in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 5847d25f6f..541fb8282b 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Univ open Declarations open Environ @@ -35,7 +34,7 @@ val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list -val inductive_paramdecls : mutual_inductive_body puniverses -> rel_context +val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t val instantiate_inductive_constraints : mutual_inductive_body -> universe_instance -> constraints @@ -86,7 +85,7 @@ val build_branches_type : constr list -> constr -> types array (** Return the arity of an inductive type *) -val mind_arity : one_inductive_body -> rel_context * sorts_family +val mind_arity : one_inductive_body -> Context.Rel.t * sorts_family val inductive_sort_family : one_inductive_body -> sorts_family @@ -111,8 +110,8 @@ exception SingletonInductiveBecomesProp of Id.t val max_inductive_sort : sorts array -> universe -val instantiate_universes : env -> rel_context -> - template_arity -> constr Lazy.t array -> rel_context * sorts +val instantiate_universes : env -> Context.Rel.t -> + template_arity -> constr Lazy.t array -> Context.Rel.t * sorts (** {6 Debug} *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 98b2d6d2e9..dd6ef1c66e 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -8,7 +8,6 @@ open Errors open Names open Term -open Context open Declarations open Util open Nativevalues @@ -1826,15 +1825,15 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = in let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in let auxdefs = List.fold_right get_named_val fv_named auxdefs in - let lvl = rel_context_length env.env_rel_context in + let lvl = Context.Rel.length env.env_rel_context in let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in let aux_name = fresh_lname Anonymous in auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = - let (_,body,_) = lookup_rel n env.env_rel_context in - let n = rel_context_length env.env_rel_context - n in + let (_,body,_) = Context.Rel.lookup n env.env_rel_context in + let n = Context.Rel.length env.env_rel_context - n in match body with | Some t -> let code = lambda_of_constr env sigma t in @@ -1844,7 +1843,7 @@ and compile_rel env sigma univ auxdefs n = Glet(Grel n, MLprimitive (Mk_rel n))::auxdefs and compile_named env sigma univ auxdefs id = - let (_,body,_) = lookup_named id env.env_named_context in + let (_,body,_) = Context.Named.lookup id env.env_named_context in match body with | Some t -> let code = lambda_of_constr env sigma t in diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index badb15b561..bfddf82864 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -16,7 +16,7 @@ type work_list = (Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } + abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } type proofterm = (constr * Univ.universe_context_set) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 009ff82ff5..5b743a4c72 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -48,7 +48,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } + abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } (* The type has two caveats: 1) cook_constr is defined after diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 615b9d49ba..9fcec11143 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -15,7 +15,6 @@ open Util open Names -open Context open Univ open Term open Declarations @@ -66,9 +65,9 @@ type named_vals = (Id.t * lazy_val) list type env = { env_globals : globals; - env_named_context : named_context; + env_named_context : Context.Named.t; env_named_vals : named_vals; - env_rel_context : rel_context; + env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; env_stratification : stratification; @@ -77,7 +76,7 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = named_context * named_vals +type named_context_val = Context.Named.t * named_vals let empty_named_context_val = [],[] @@ -87,9 +86,9 @@ let empty_env = { env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; - env_named_context = empty_named_context; + env_named_context = Context.Named.empty; env_named_vals = []; - env_rel_context = empty_rel_context; + env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0; env_stratification = { @@ -107,7 +106,7 @@ let nb_rel env = env.env_nb_rel let push_rel d env = let rval = ref VKnone in { env with - env_rel_context = add_rel_decl d env.env_rel_context; + env_rel_context = Context.Rel.add d env.env_rel_context; env_rel_val = rval :: env.env_rel_val; env_nb_rel = env.env_nb_rel + 1 } @@ -127,7 +126,7 @@ let env_of_rel n env = let push_named_context_val d (ctxt,vals) = let id,_,_ = d in let rval = ref VKnone in - add_named_decl d ctxt, (id,rval)::vals + Context.Named.add d ctxt, (id,rval)::vals let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); @@ -135,7 +134,7 @@ let push_named d env = let id,body,_ = d in let rval = ref VKnone in { env_globals = env.env_globals; - env_named_context = Context.add_named_decl d env.env_named_context; + env_named_context = Context.Named.add d env.env_named_context; env_named_vals = (id, rval) :: env.env_named_vals; env_rel_context = env.env_rel_context; env_rel_val = env.env_rel_val; diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index b499ac0c52..9cd940a881 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Declarations open Univ @@ -46,9 +45,9 @@ type named_vals = (Id.t * lazy_val) list type env = { env_globals : globals; - env_named_context : named_context; + env_named_context : Context.Named.t; env_named_vals : named_vals; - env_rel_context : rel_context; + env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; env_stratification : stratification; @@ -57,7 +56,7 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = named_context * named_vals +type named_context_val = Context.Named.t * named_vals val empty_named_context_val : named_context_val @@ -66,15 +65,15 @@ val empty_env : env (** Rel context *) val nb_rel : env -> int -val push_rel : rel_declaration -> env -> env +val push_rel : Context.Rel.Declaration.t -> env -> env val lookup_rel_val : int -> env -> lazy_val val env_of_rel : int -> env -> env (** Named context *) val push_named_context_val : - named_declaration -> named_context_val -> named_context_val -val push_named : named_declaration -> env -> env + Context.Named.Declaration.t -> named_context_val -> named_context_val +val push_named : Context.Named.Declaration.t -> env -> env val lookup_named_val : Id.t -> env -> lazy_val val env_of_named : Id.t -> env -> env diff --git a/kernel/reduction.ml b/kernel/reduction.ml index bf2ee27077..78222c6b6d 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -20,7 +20,6 @@ open Util open Names open Term open Vars -open Context open Univ open Environ open Closure @@ -741,10 +740,10 @@ let dest_prod env = match kind_of_term t with | Prod (n,a,c0) -> let d = (n,None,a) in - decrec (push_rel d env) (add_rel_decl d m) c0 + decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in - decrec env empty_rel_context + decrec env Context.Rel.empty (* The same but preserving lets in the context, not internal ones. *) let dest_prod_assum env = @@ -753,17 +752,17 @@ let dest_prod_assum env = match kind_of_term rty with | Prod (x,t,c) -> let d = (x,None,t) in - prodec_rec (push_rel d env) (add_rel_decl d l) c + prodec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = (x,Some b,t) in - prodec_rec (push_rel d env) (add_rel_decl d l) c + prodec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let rty' = whd_betadeltaiota env rty in if Term.eq_constr rty' rty then l, rty else prodec_rec env l rty' in - prodec_rec env empty_rel_context + prodec_rec env Context.Rel.empty let dest_lam_assum env = let rec lamec_rec env l ty = @@ -771,14 +770,14 @@ let dest_lam_assum env = match kind_of_term rty with | Lambda (x,t,c) -> let d = (x,None,t) in - lamec_rec (push_rel d env) (add_rel_decl d l) c + lamec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = (x,Some b,t) in - lamec_rec (push_rel d env) (add_rel_decl d l) c + lamec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty in - lamec_rec env empty_rel_context + lamec_rec env Context.Rel.empty exception NotArity diff --git a/kernel/reduction.mli b/kernel/reduction.mli index f7a8d88c27..35daff7b59 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -7,7 +7,6 @@ (************************************************************************) open Term -open Context open Environ (*********************************************************************** @@ -99,9 +98,9 @@ val betazeta_appvect : int -> constr -> constr array -> constr (*********************************************************************** s Recognizing products and arities modulo reduction *) -val dest_prod : env -> types -> rel_context * types -val dest_prod_assum : env -> types -> rel_context * types -val dest_lam_assum : env -> types -> rel_context * types +val dest_prod : env -> types -> Context.Rel.t * types +val dest_prod_assum : env -> types -> Context.Rel.t * types +val dest_lam_assum : env -> types -> Context.Rel.t * types exception NotArity diff --git a/kernel/term.ml b/kernel/term.ml index 455248dd52..19f4b7a234 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -10,7 +10,6 @@ open Util open Pp open Errors open Names -open Context open Vars (**********************************************************************) @@ -590,24 +589,24 @@ let decompose_lam_n n = let decompose_prod_assum = let rec prodec_rec l c = match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) c - | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c + | Prod (x,t,c) -> prodec_rec (Context.Rel.add (x,None,t) l) c + | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (x,Some b,t) l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in - prodec_rec empty_rel_context + prodec_rec Context.Rel.empty (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam_assum = let rec lamdec_rec l c = match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) c - | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (x,None,t) l) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (x,Some b,t) l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in - lamdec_rec empty_rel_context + lamdec_rec Context.Rel.empty (* Given a positive integer n, decompose a product or let-in term of the form [forall (x1:T1)..(xi:=ci:Ti)..(xn:Tn), T] into the pair @@ -619,12 +618,12 @@ let decompose_prod_n_assum n = let rec prodec_rec l n c = if Int.equal n 0 then l,c else match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c + | Prod (x,t,c) -> prodec_rec (Context.Rel.add (x,None,t) l) (n-1) c + | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (x,Some b,t) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in - prodec_rec empty_rel_context n + prodec_rec Context.Rel.empty n (* Given a positive integer n, decompose a lambda or let-in term [fun (x1:T1)..(xi:=ci:Ti)..(xn:Tn) => T] into the pair of the abstracted @@ -638,12 +637,12 @@ let decompose_lam_n_assum n = let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (x,None,t) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (x,Some b,t) l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in - lamdec_rec empty_rel_context n + lamdec_rec Context.Rel.empty n (* Same, counting let-in *) let decompose_lam_n_decls n = @@ -652,12 +651,12 @@ let decompose_lam_n_decls n = let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (x,None,t) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (x,Some b,t) l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_decls: not enough abstractions" in - lamdec_rec empty_rel_context n + lamdec_rec Context.Rel.empty n let prod_assum t = fst (decompose_prod_assum t) let prod_n_assum n t = fst (decompose_prod_n_assum n t) @@ -678,7 +677,7 @@ let strip_lam_n n t = snd (decompose_lam_n n t) Such a term can canonically be seen as the pair of a context of types and of a sort *) -type arity = rel_context * sorts +type arity = Context.Rel.t * sorts let destArity = let rec prodec_rec l c = diff --git a/kernel/term.mli b/kernel/term.mli index 972a67ebed..c45e043386 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Context (** {5 Redeclaration of types from module Constr and Sorts} @@ -213,14 +212,14 @@ val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr val mkNamedProd : Id.t -> types -> types -> types (** Constructs either [(x:t)c] or [[x=b:t]c] *) -val mkProd_or_LetIn : rel_declaration -> types -> types -val mkProd_wo_LetIn : rel_declaration -> types -> types -val mkNamedProd_or_LetIn : named_declaration -> types -> types -val mkNamedProd_wo_LetIn : named_declaration -> types -> types +val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types +val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types +val mkNamedProd_or_LetIn : Context.Named.Declaration.t -> types -> types +val mkNamedProd_wo_LetIn : Context.Named.Declaration.t -> types -> types (** Constructs either [[x:t]c] or [[x=b:t]c] *) -val mkLambda_or_LetIn : rel_declaration -> constr -> constr -val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr +val mkLambda_or_LetIn : Context.Rel.Declaration.t -> constr -> constr +val mkNamedLambda_or_LetIn : Context.Named.Declaration.t -> constr -> constr (** {5 Other term constructors. } *) @@ -262,8 +261,8 @@ val to_lambda : int -> constr -> constr where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *) val to_prod : int -> constr -> constr -val it_mkLambda_or_LetIn : constr -> rel_context -> constr -val it_mkProd_or_LetIn : types -> rel_context -> types +val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr +val it_mkProd_or_LetIn : types -> Context.Rel.t -> types (** In [lambda_applist c args], [c] is supposed to have the form [λΓ.c] with [Γ] without let-in; it returns [c] with the variables @@ -314,29 +313,29 @@ val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr (** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) -val decompose_prod_assum : types -> rel_context * types +val decompose_prod_assum : types -> Context.Rel.t * types (** Idem with lambda's *) -val decompose_lam_assum : constr -> rel_context * constr +val decompose_lam_assum : constr -> Context.Rel.t * constr (** Idem but extract the first [n] premisses, counting let-ins. *) -val decompose_prod_n_assum : int -> types -> rel_context * types +val decompose_prod_n_assum : int -> types -> Context.Rel.t * types (** Idem for lambdas, _not_ counting let-ins *) -val decompose_lam_n_assum : int -> constr -> rel_context * constr +val decompose_lam_n_assum : int -> constr -> Context.Rel.t * constr (** Idem, counting let-ins *) -val decompose_lam_n_decls : int -> constr -> rel_context * constr +val decompose_lam_n_decls : int -> constr -> Context.Rel.t * constr (** Return the premisses/parameters of a type/term (let-in included) *) -val prod_assum : types -> rel_context -val lam_assum : constr -> rel_context +val prod_assum : types -> Context.Rel.t +val lam_assum : constr -> Context.Rel.t (** Return the first n-th premisses/parameters of a type (let included and counted) *) -val prod_n_assum : int -> types -> rel_context +val prod_n_assum : int -> types -> Context.Rel.t (** Return the first n-th premisses/parameters of a term (let included but not counted) *) -val lam_n_assum : int -> constr -> rel_context +val lam_n_assum : int -> constr -> Context.Rel.t (** Remove the premisses/parameters of a type/term *) val strip_prod : types -> types @@ -369,7 +368,7 @@ val under_outer_cast : (constr -> constr) -> constr -> constr Such a term can canonically be seen as the pair of a context of types and of a sort *) -type arity = rel_context * sorts +type arity = Context.Rel.t * sorts (** Build an "arity" from its canonical form *) val mkArity : arity -> types diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index a566028d40..db50a393b5 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -16,7 +16,6 @@ open Errors open Util open Names open Term -open Context open Declarations open Environ open Entries @@ -246,8 +245,8 @@ let infer_declaration ~trust env kn dcl = let global_vars_set_constant_type env = function | RegularArity t -> global_vars_set env t | TemplateArity (ctx,_) -> - Context.fold_rel_context - (fold_rel_declaration + Context.Rel.fold_outside + (Context.Rel.Declaration.fold (fun t c -> Id.Set.union (global_vars_set env t) c)) ctx ~init:Id.Set.empty diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 4f32fdce83..35f53b7e7c 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -12,7 +12,6 @@ open Names open Univ open Term open Vars -open Context open Declarations open Environ open Entries @@ -99,7 +98,7 @@ let judge_of_variable env id = variables of the current env. Order does not have to be checked assuming that all names are distinct *) let check_hyps_inclusion env c sign = - Context.fold_named_context + Context.Named.fold_outside (fun (id,b1,ty1) () -> try let (_,b2,ty2) = lookup_named id env in @@ -561,6 +560,6 @@ let infer_local_decls env decls = | (id, d) :: l -> let (env, l) = inferec env l in let d = infer_local_decl env id d in - (push_rel d env, add_rel_decl d l) - | [] -> (env, empty_rel_context) in + (push_rel d env, Context.Rel.add d l) + | [] -> (env, Context.Rel.empty) in inferec env decls diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 010b2b6f03..bcaa6b63ee 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -9,7 +9,6 @@ open Names open Univ open Term -open Context open Environ open Entries open Declarations @@ -28,7 +27,7 @@ val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment val infer_local_decls : - env -> (Id.t * local_entry) list -> (env * rel_context) + env -> (Id.t * local_entry) list -> (env * Context.Rel.t) (** {6 Basic operations of the typing machine. } *) @@ -128,4 +127,4 @@ val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> constant_type (** Check that hyps are included in env and fails with error otherwise *) -val check_hyps_inclusion : env -> constr -> section_context -> unit +val check_hyps_inclusion : env -> constr -> Context.section_context -> unit diff --git a/kernel/vars.ml b/kernel/vars.ml index a00c7036fb..53543e0436 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -8,7 +8,6 @@ open Names open Esubst -open Context (*********************) (* Occurring *) @@ -160,9 +159,9 @@ let substnl laml n c = substn_many (make_subst laml) n c let substl laml c = substn_many (make_subst laml) 0 c let subst1 lam c = substn_many [|make_substituend lam|] 0 c -let substnl_decl laml k r = map_rel_declaration (fun c -> substnl laml k c) r -let substl_decl laml r = map_rel_declaration (fun c -> substnl laml 0 c) r -let subst1_decl lam r = map_rel_declaration (fun c -> subst1 lam c) r +let substnl_decl laml k r = Context.Rel.Declaration.map (fun c -> substnl laml k c) r +let substl_decl laml r = Context.Rel.Declaration.map (fun c -> substnl laml 0 c) r +let subst1_decl lam r = Context.Rel.Declaration.map (fun c -> subst1 lam c) r (* Build a substitution from an instance, inserting missing let-ins *) @@ -302,7 +301,7 @@ let subst_univs_level_constr subst c = if !changed then c' else c let subst_univs_level_context s = - map_rel_context (subst_univs_level_constr s) + Context.Rel.map (subst_univs_level_constr s) let subst_instance_constr subst c = if Univ.Instance.is_empty subst then c @@ -343,7 +342,7 @@ let subst_instance_constr subst c = let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx - else map_rel_context (fun x -> subst_instance_constr s x) ctx + else Context.Rel.map (fun x -> subst_instance_constr s x) ctx type id_key = constant tableKey let eq_id_key x y = Names.eq_table_key Constant.equal x y diff --git a/kernel/vars.mli b/kernel/vars.mli index a84cf0114e..659990806d 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -8,7 +8,6 @@ open Names open Constr -open Context (** {6 Occur checks } *) @@ -69,10 +68,10 @@ type substl = constr list as if usable in [applist] while the substitution is represented the other way round, i.e. ending with either [u₁] or [c₁], as if usable for [substl]. *) -val subst_of_rel_context_instance : rel_context -> constr list -> substl +val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl (** For compatibility: returns the substitution reversed *) -val adjust_subst_to_rel_context : rel_context -> constr list -> constr list +val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list (** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates @@ -92,13 +91,13 @@ val subst1 : constr -> constr -> constr accordingly indexes in [a₁],...,[an] and [c]. In terms of typing, if Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ', Ω ⊢ with |Γ'|=[k], then Γ, Γ', [substnl_decl [a₁;...;an]] k Ω ⊢. *) -val substnl_decl : substl -> int -> rel_declaration -> rel_declaration +val substnl_decl : substl -> int -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t (** [substl_decl σ Ω] is a short-hand for [substnl_decl σ 0 Ω] *) -val substl_decl : substl -> rel_declaration -> rel_declaration +val substl_decl : substl -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t (** [subst1_decl a Ω] is a short-hand for [substnl_decl [a] 0 Ω] *) -val subst1_decl : constr -> rel_declaration -> rel_declaration +val subst1_decl : constr -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t (** [replace_vars k [(id₁,c₁);...;(idn,cn)] t] substitutes [Var idj] by [cj] in [t]. *) @@ -136,11 +135,11 @@ val subst_univs_constr : universe_subst -> constr -> constr (** Level substitutions for polymorphism. *) val subst_univs_level_constr : universe_level_subst -> constr -> constr -val subst_univs_level_context : Univ.universe_level_subst -> rel_context -> rel_context +val subst_univs_level_context : Univ.universe_level_subst -> Context.Rel.t -> Context.Rel.t (** Instance substitution for polymorphism. *) val subst_instance_constr : universe_instance -> constr -> constr -val subst_instance_context : universe_instance -> rel_context -> rel_context +val subst_instance_context : universe_instance -> Context.Rel.t -> Context.Rel.t type id_key = constant tableKey val eq_id_key : id_key -> id_key -> bool diff --git a/library/decls.ml b/library/decls.ml index 8d5085f70e..b5f9143b8a 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -11,7 +11,6 @@ open Util open Names -open Context open Decl_kinds open Libnames @@ -55,7 +54,7 @@ let initialize_named_context_for_proof () = Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = - fold_named_context + Context.Named.fold_outside (fun (id,_,_) sec_ids -> try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids with Not_found -> sec_ids) diff --git a/library/global.mli b/library/global.mli index 09ed4eb0a8..d6547105d4 100644 --- a/library/global.mli +++ b/library/global.mli @@ -21,7 +21,7 @@ val env_is_initial : unit -> bool val universes : unit -> UGraph.t val named_context_val : unit -> Environ.named_context_val -val named_context : unit -> Context.named_context +val named_context : unit -> Context.Named.t (** {6 Enriching the global environment } *) @@ -73,7 +73,7 @@ val add_module_parameter : (** {6 Queries in the global environment } *) -val lookup_named : variable -> Context.named_declaration +val lookup_named : variable -> Context.Named.Declaration.t val lookup_constant : constant -> Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body diff --git a/library/lib.mli b/library/lib.mli index bb88317591..874fc89fb4 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -164,7 +164,7 @@ type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t val instance_from_variable_context : variable_context -> Names.Id.t array -val named_of_variable_context : variable_context -> Context.named_context +val named_of_variable_context : variable_context -> Context.Named.t val section_segment_of_constant : Names.constant -> abstr_info val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info @@ -175,8 +175,8 @@ val is_in_section : Globnames.global_reference -> bool val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit val add_section_context : Univ.universe_context_set -> unit val add_section_constant : bool (* is_projection *) -> - Names.constant -> Context.named_context -> unit -val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit + Names.constant -> Context.Named.t -> unit +val add_section_kn : Names.mutual_inductive -> Context.Named.t -> unit val replacement_context : unit -> Opaqueproof.work_list (** {6 Discharge: decrease the section level if in the current section } *) @@ -189,6 +189,6 @@ val discharge_inductive : Names.inductive -> Names.inductive (* discharging a constant in one go *) val full_replacement_context : unit -> Opaqueproof.work_list list val full_section_segment_of_constant : - Names.constant -> (Context.named_context -> Context.named_context) list + Names.constant -> (Context.Named.t -> Context.Named.t) list diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 2dc2420c46..923743eceb 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -11,7 +11,6 @@ open Util open Names open Term open Vars -open Context open Declarations open Declareops open Environ diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 6c7b093838..d306112ce7 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -7,7 +7,6 @@ (************************************************************************) open Term -open Context open Globnames val qflag : bool ref @@ -27,7 +26,7 @@ type counter = bool -> metavariable val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array val ind_hyps : int -> pinductive -> constr list -> - Proof_type.goal Tacmach.sigma -> rel_context array + Proof_type.goal Tacmach.sigma -> Context.Rel.t array type atoms = {positive:constr list;negative:constr list} diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f57f12f667..ad18ea95a4 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -3,7 +3,6 @@ open Errors open Util open Term open Vars -open Context open Namegen open Names open Declarations @@ -230,7 +229,7 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = +let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = let nochange ?t' msg = begin observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index bbe2f1a3ad..e2c3bbb978 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -3,7 +3,6 @@ open Errors open Util open Term open Vars -open Context open Namegen open Names open Pp @@ -30,7 +29,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:rel_context) : rel_context = + let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t = match predicates with | [] -> [] |(Name x,v,t)::predicates -> diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 5d92fca5ea..80de8e764d 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -357,7 +357,7 @@ let add_pat_variables pat typ env : Environ.env = let new_env = add_pat_variables env pat typ in let res = fst ( - Context.fold_rel_context + Context.Rel.fold_outside (fun (na,v,t) (env,ctxt) -> match na with | Anonymous -> assert false diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index e3455e7702..be04728e03 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -19,7 +19,6 @@ open Pp open Names open Term open Vars -open Context open Termops open Declarations open Glob_term @@ -258,27 +257,27 @@ type merge_infos = lnk2: int merged_arg array; (** rec params which remain rec param (ie not linked) *) - recprms1: rel_declaration list; - recprms2: rel_declaration list; + recprms1: Context.Rel.Declaration.t list; + recprms2: Context.Rel.Declaration.t list; nrecprms1: int; nrecprms2: int; (** rec parms which became non parm (either linked to something or because after a rec parm that became non parm) *) - otherprms1: rel_declaration list; - otherprms2: rel_declaration list; + otherprms1: Context.Rel.Declaration.t list; + otherprms2: Context.Rel.Declaration.t list; notherprms1:int; notherprms2:int; (** args which remain args in merge *) - args1:rel_declaration list; - args2:rel_declaration list; + args1:Context.Rel.Declaration.t list; + args2:Context.Rel.Declaration.t list; nargs1:int; nargs2:int; (** functional result args *) - funresprms1: rel_declaration list; - funresprms2: rel_declaration list; + funresprms1: Context.Rel.Declaration.t list; + funresprms2: Context.Rel.Declaration.t list; nfunresprms1:int; nfunresprms2:int; } @@ -851,7 +850,7 @@ let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift lident , bindlist , Some cstr_expr , lcstor_expr -let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = +let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with | (nme,None,t) -> let traw = Detyping.detype false [] (Global.env()) Evd.empty t in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index b894cb8ea4..adcaa64412 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Namegen open Declarations @@ -131,7 +130,7 @@ type tomatch_status = | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) | Alias of (bool*(Name.t * constr * (constr * types))) | NonDepAlias - | Abstract of int * rel_declaration + | Abstract of int * Context.Rel.Declaration.t type tomatch_stack = tomatch_status list @@ -602,7 +601,7 @@ let relocate_index_tomatch n1 n2 = NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in - Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d) + Abstract (i, Context.Rel.Declaration.map (relocate_index n1 n2 depth) d) :: genrec (depth+1) rest in genrec 0 @@ -635,7 +634,7 @@ let replace_tomatch n c = | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> - Abstract (i,map_rel_declaration (replace_term n c depth) d) + Abstract (i, Context.Rel.Declaration.map (replace_term n c depth) d) :: replrec (depth+1) rest in replrec 0 @@ -660,7 +659,7 @@ let rec liftn_tomatch_stack n depth = function NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i match kind_of_term par with | Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch - | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign) + | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list 0 sign) (lift_tomatch_stack n tms) in (* Pred is already dependent in the current term to match (if *) (* (na<>Anonymous) and its realargs; we just need to adjust it to *) @@ -1118,7 +1117,7 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with | [], _ -> brs,tomatch,pred,[] | n::deps, Abstract (i,d) :: tomatch -> - let d = map_rel_declaration (nf_evar evd) d in + let d = Context.Rel.Declaration.map (nf_evar evd) d in let is_d = match d with (_, None, _) -> false | _ -> true in if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck && Array.exists (is_dependent_branch k) brs then @@ -1187,7 +1186,7 @@ let group_equations pb ind current cstrs mat = let rec generalize_problem names pb = function | [] -> pb, [] | i::l -> - let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in + let (na,b,t as d) = Context.Rel.Declaration.map (lift i) (Environ.lookup_rel i pb.env) in let pb',deps = generalize_problem names pb l in begin match (na, b) with | Anonymous, Some _ -> pb', deps @@ -1230,7 +1229,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* We adjust the terms to match in the context they will be once the *) (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *) let typs' = - List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in + List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 typs in let extenv = push_rel_context typs pb.env in @@ -1560,8 +1559,8 @@ let matx_of_eqns env eqns = *) let adjust_to_extended_env_and_remove_deps env extenv subst t = - let n = rel_context_length (rel_context env) in - let n' = rel_context_length (rel_context extenv) in + let n = Context.Rel.length (rel_context env) in + let n' = Context.Rel.length (rel_context extenv) in (* We first remove the bindings that are dependently typed (they are difficult to manage and it is not sure these are so useful in practice); Notes: @@ -1673,8 +1672,8 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = | None -> (* This is the situation we are building a return predicate and we are in an impossible branch *) - let n = rel_context_length (rel_context env) in - let n' = rel_context_length (rel_context tycon_env) in + let n = Context.Rel.length (rel_context env) in + let n' = Context.Rel.length (rel_context tycon_env) in let impossible_case_type, u = e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in (lift (n'-n) impossible_case_type, mkSort u) @@ -1744,7 +1743,7 @@ let build_inversion_problem loc env sigma tms t = let n = List.length sign in let decls = - List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in + List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 sign in let pb_env = push_rel_context sign env in let decls = diff --git a/pretyping/cases.mli b/pretyping/cases.mli index c599766ab7..4ec71956b4 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Evd open Environ open Inductiveops @@ -45,11 +44,11 @@ val compile_cases : val constr_of_pat : Environ.env -> Evd.evar_map ref -> - rel_declaration list -> + Context.Rel.Declaration.t list -> Glob_term.cases_pattern -> Names.Id.t list -> Glob_term.cases_pattern * - (rel_declaration list * Term.constr * + (Context.Rel.Declaration.t list * Term.constr * (Term.types * Term.constr list) * Glob_term.cases_pattern) * Names.Id.t list @@ -83,7 +82,7 @@ type tomatch_status = | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) | Alias of (bool * (Name.t * constr * (constr * types))) | NonDepAlias - | Abstract of int * rel_declaration + | Abstract of int * Context.Rel.Declaration.t type tomatch_stack = tomatch_status list @@ -117,7 +116,7 @@ val prepare_predicate : Loc.t -> Environ.env -> Evd.evar_map -> (Term.types * tomatch_type) list -> - Context.rel_context list -> + Context.Rel.t list -> Constr.constr option -> 'a option -> (Evd.evar_map * Names.name list * Term.constr) list diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 5e99521a12..0b0bd8304e 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -17,7 +17,6 @@ open Termops open Reductionops open Term open Vars -open Context open Pattern open Patternops open Misctypes @@ -269,8 +268,8 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in - let n = rel_context_length ctx_b2 in - let n' = rel_context_length ctx_b2' in + let n = Context.Rel.length ctx_b2 in + let n' = Context.Rel.length ctx_b2' in if noccur_between 1 n b2 && noccur_between 1 n' b2' then let f l (na,_,t) = (Anonymous,na,t)::l in let ctx_br = List.fold_left f ctx ctx_b2 in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index dab82fa22b..4ca066feb0 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -12,7 +12,6 @@ open Util open Names open Term open Vars -open Context open Inductiveops open Environ open Glob_term @@ -199,7 +198,7 @@ let computable p k = engendrera un prédicat non dépendant) *) let sign,ccl = decompose_lam_assum p in - Int.equal (rel_context_length sign) (k + 1) + Int.equal (Context.Rel.length sign) (k + 1) && noccur_between 1 (k+1) ccl @@ -315,7 +314,7 @@ let is_nondep_branch c l = try (* FIXME: do better using tags from l *) let sign,ccl = decompose_lam_n_decls (List.length l) c in - noccur_between 1 (rel_context_length sign) ccl + noccur_between 1 (Context.Rel.length sign) ccl with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *) false diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index eb158686aa..f8f8093c0f 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Environ open Glob_term open Termops @@ -46,7 +45,7 @@ val detype_case : val detype_sort : evar_map -> sorts -> glob_sort val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> - evar_map -> rel_context -> glob_decl list + evar_map -> Context.Rel.t -> glob_decl list val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index fe26dcd282..c6c397135a 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -11,7 +11,6 @@ open Errors open Names open Term open Vars -open Context open Environ open Termops open Evd @@ -501,7 +500,7 @@ let solve_pattern_eqn env l c = match kind_of_term a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> - let d = map_rel_declaration (lift n) (lookup_rel n env) in + let d = Context.Rel.Declaration.map (lift n) (lookup_rel n env) in mkLambda_or_LetIn d c' | Var id -> let d = lookup_named id env in mkNamedLambda_or_LetIn d c' diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 3c3afac54e..f001d6e3e9 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -12,7 +12,6 @@ open Pp open Names open Term open Vars -open Context open Termops open Namegen open Pre_env @@ -78,12 +77,12 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} = let env_nf_evar sigma env = process_rel_context - (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env + (fun d e -> push_rel (Context.Rel.Declaration.map (nf_evar sigma) d) e) env let env_nf_betaiotaevar sigma env = process_rel_context (fun d e -> - push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env + push_rel (Context.Rel.Declaration.map (Reductionops.nf_betaiota sigma) d) e) env let nf_evars_universes evm = Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) @@ -106,10 +105,10 @@ let nf_evar_map_universes evm = Evd.raw_map (fun _ -> map_evar_info f) evm, f let nf_named_context_evar sigma ctx = - Context.map_named_context (nf_evar sigma) ctx + Context.Named.map (nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = - Context.map_rel_context (nf_evar sigma) ctx + Context.Rel.map (nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in @@ -303,7 +302,7 @@ let push_rel_context_to_named_context env typ = (* with vars of the rel context *) (* We do keep the instances corresponding to local definition (see above) *) let (subst, vsubst, _, env) = - Context.fold_rel_context + Context.Rel.fold_outside (fun (na,c,t) (subst, vsubst, avoid, env) -> let id = (* ppedrot: we want to infer nicer names for the refine tactic, but diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 96648bb111..867917c9cf 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Evd open Environ @@ -129,7 +128,7 @@ val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.M [nf_evar]. *) val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t -val undefined_evars_of_named_context : evar_map -> named_context -> Evar.Set.t +val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t (** [occur_evar_upto sigma k c] returns [true] if [k] appears in @@ -170,8 +169,8 @@ val jv_nf_evar : val tj_nf_evar : evar_map -> unsafe_type_judgment -> unsafe_type_judgment -val nf_named_context_evar : evar_map -> named_context -> named_context -val nf_rel_context_evar : evar_map -> rel_context -> rel_context +val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t +val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t val nf_env_evar : evar_map -> env -> env val nf_evar_info : evar_map -> evar_info -> evar_info diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 47d9654e57..1366c34ce2 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -7,7 +7,6 @@ (************************************************************************) open Locus -open Context open Term open Evd open Pretype_errors @@ -50,7 +49,7 @@ val replace_term_occ_modulo : occurrences or_like_first -> val replace_term_occ_decl_modulo : (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> - named_declaration -> named_declaration + Context.Named.Declaration.t -> Context.Named.Declaration.t (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), @@ -62,7 +61,7 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> closed [c] at positions [occl] by [Rel 1] in [decl]. *) val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> - constr -> named_declaration -> named_declaration * evar_map + constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map (** Miscellaneous *) val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 3f21842e39..40175dac91 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -19,7 +19,6 @@ open Globnames open Nameops open Term open Vars -open Context open Namegen open Declarations open Declareops @@ -61,7 +60,7 @@ let check_privacy_block mib = let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in - let indf = make_ind_family(pind, Context.extended_rel_list 0 lnamespar) in + let indf = make_ind_family(pind, Context.Rel.to_extended_list 0 lnamespar) in let constrs = get_constructors env indf in let projs = get_projections env indf in @@ -92,8 +91,8 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let pbody = appvect (mkRel (ndepar + nbprod), - if dep then Context.extended_rel_vect 0 deparsign - else Context.extended_rel_vect 1 arsign) in + if dep then Context.Rel.to_extended_vect 0 deparsign + else Context.Rel.to_extended_vect 1 arsign) in let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) @@ -165,7 +164,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let base = applist (lift i pk,realargs) in if depK then Reduction.beta_appvect - base [|applist (mkRel (i+1), Context.extended_rel_list 0 sign)|] + base [|applist (mkRel (i+1), Context.Rel.to_extended_list 0 sign)|] else base | _ -> assert false @@ -237,7 +236,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs - and arg = appvect (mkRel (i+1), Context.extended_rel_vect 0 hyps) in + and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in applist(lift i fk,realargs@[arg]) | _ -> assert false in @@ -312,29 +311,29 @@ let mis_make_indrec env sigma listdepkind mib u = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) - let args = Context.extended_rel_list (nrec+nbconstruct) lnamesparrec in + let args = Context.Rel.to_extended_list (nrec+nbconstruct) lnamesparrec in let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in let deparsign = (Anonymous,None,depind)::arsign in - let nonrecpar = rel_context_length lnonparrec in - let larsign = rel_context_length deparsign in + let nonrecpar = Context.Rel.length lnonparrec in + let larsign = Context.Rel.length deparsign in let ndepar = larsign - nonrecpar in let dect = larsign+nrec+nbconstruct in (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) - let args' = Context.extended_rel_list (dect+nrec) lnamesparrec in - let args'' = Context.extended_rel_list ndepar lnonparrec in + let args' = Context.Rel.to_extended_list (dect+nrec) lnamesparrec in + let args'' = Context.Rel.to_extended_list ndepar lnonparrec in let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in let fi = Termops.rel_vect (dect-i-nctyi) nctyi in let vecfi = Array.map - (fun f -> appvect (f, Context.extended_rel_vect ndepar lnonparrec)) + (fun f -> appvect (f, Context.Rel.to_extended_vect ndepar lnonparrec)) fi in Array.map3 @@ -355,9 +354,9 @@ let mis_make_indrec env sigma listdepkind mib u = let deparsign' = (Anonymous,None,depind')::arsign' in let pargs = - let nrpar = Context.extended_rel_list (2*ndepar) lnonparrec - and nrar = if dep then Context.extended_rel_list 0 deparsign' - else Context.extended_rel_list 1 arsign' + let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec + and nrar = if dep then Context.Rel.to_extended_list 0 deparsign' + else Context.Rel.to_extended_list 1 arsign' in nrpar@nrar in @@ -400,14 +399,14 @@ let mis_make_indrec env sigma listdepkind mib u = let typtyi = let concl = - let pargs = if dep then Context.extended_rel_vect 0 deparsign - else Context.extended_rel_vect 1 arsign + let pargs = if dep then Context.Rel.to_extended_vect 0 deparsign + else Context.Rel.to_extended_vect 1 arsign in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) in it_mkProd_or_LetIn_name env concl deparsign in - mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) + mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp) (deftyi::ldef) rest | [] -> let fixn = Array.of_list (List.rev ln) in @@ -428,7 +427,7 @@ let mis_make_indrec env sigma listdepkind mib u = else let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in - let vargs = Context.extended_rel_list (nrec+i+j) lnamesparrec in + let vargs = Context.Rel.to_extended_list (nrec+i+j) lnamesparrec in let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch @@ -442,7 +441,7 @@ let mis_make_indrec env sigma listdepkind mib u = in let rec put_arity env i = function | ((indi,u),_,_,dep,kinds)::rest -> - let indf = make_ind_family ((indi,u), Context.extended_rel_list i lnamesparrec) in + let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list i lnamesparrec) in let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) evdref kinds diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index f429c51eb8..1e3ff0fa2d 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -12,7 +12,6 @@ open Names open Univ open Term open Vars -open Context open Termops open Declarations open Declareops @@ -142,12 +141,12 @@ let constructor_nallargs_env env ((kn,i),j) = let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *) let (mib,mip) = Global.lookup_inductive indsp in - mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) + mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *) let mib = Environ.lookup_mind kn env in let mip = mib.mind_packets.(i) in - mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) + mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) (* Arity of constructors excluding params, excluding local defs *) @@ -213,21 +212,21 @@ let inductive_nparams_env env ind = let inductive_nparamdecls ind = let (mib,mip) = Global.lookup_inductive ind in - rel_context_length mib.mind_params_ctxt + Context.Rel.length mib.mind_params_ctxt let inductive_nparamdecls_env env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in - rel_context_length mib.mind_params_ctxt + Context.Rel.length mib.mind_params_ctxt (* Full length of arity (with local defs) *) let inductive_nalldecls ind = let (mib,mip) = Global.lookup_inductive ind in - rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls + Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls let inductive_nalldecls_env env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in - rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls + Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls (* Others *) @@ -249,13 +248,13 @@ let inductive_alldecls_env env (ind,u) = let constructor_has_local_defs (indsp,j) = let (mib,mip) = Global.lookup_inductive indsp in - let l1 = mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) in + let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in not (Int.equal l1 l2) let inductive_has_local_defs ind = let (mib,mip) = Global.lookup_inductive ind in - let l1 = rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls in + let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in let l2 = mib.mind_nparams + mip.mind_nrealargs in not (Int.equal l1 l2) @@ -273,11 +272,11 @@ let projection_nparams p = projection_nparams_env (Global.env ()) p let make_case_info env ind style = let (mib,mip) = Inductive.lookup_mind_specif env ind in let ind_tags = - rel_context_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in + Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in let cstr_tags = Array.map2 (fun c n -> let d,_ = decompose_prod_assum c in - rel_context_tags (List.firstn n d)) + Context.Rel.to_tags (List.firstn n d)) mip.mind_nf_lc mip.mind_consnrealdecls in let print_info = { ind_tags; cstr_tags; style } in { ci_ind = ind; @@ -292,7 +291,7 @@ type constructor_summary = { cs_cstr : pconstructor; cs_params : constr list; cs_nargs : int; - cs_args : rel_context; + cs_args : Context.Rel.t; cs_concl_realargs : constr array } @@ -306,10 +305,10 @@ let lift_constructor n cs = { (* Accept either all parameters or only recursively uniform ones *) let instantiate_params t params sign = - let nnonrecpar = rel_context_nhyps sign - List.length params in + let nnonrecpar = Context.Rel.nhyps sign - List.length params in (* Adjust the signature if recursively non-uniform parameters are not here *) let _,sign = context_chop nnonrecpar sign in - let _,t = decompose_prod_n_assum (rel_context_length sign) t in + let _,t = decompose_prod_n_assum (Context.Rel.length sign) t in let subst = subst_of_rel_context_instance sign params in substl subst t @@ -323,7 +322,7 @@ let get_constructor ((ind,u as indu),mib,mip,params) j = let vargs = List.skipn (List.length params) allargs in { cs_cstr = (ith_constructor_of_inductive ind j,u); cs_params = params; - cs_nargs = rel_context_length args; + cs_nargs = Context.Rel.length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } @@ -374,14 +373,14 @@ let build_dependent_constructor cs = applist (mkConstructU cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) - @(extended_rel_list 0 cs.cs_args)) + @(Context.Rel.to_extended_list 0 cs.cs_args)) let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist (mkIndU ind, - (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) + (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) @@ -506,7 +505,7 @@ let set_pattern_names env ind brv = let arities = Array.map (fun c -> - rel_context_length ((prod_assum c)) - + Context.Rel.length ((prod_assum c)) - mib.mind_nparams) mip.mind_nf_lc in Array.map2 (set_names env) arities brv diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 9036f521ec..42a00a7e22 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Declarations open Environ open Evd @@ -92,12 +91,12 @@ val inductive_nparamdecls : inductive -> int val inductive_nparamdecls_env : env -> inductive -> int (** @return params context *) -val inductive_paramdecls : pinductive -> rel_context -val inductive_paramdecls_env : env -> pinductive -> rel_context +val inductive_paramdecls : pinductive -> Context.Rel.t +val inductive_paramdecls_env : env -> pinductive -> Context.Rel.t (** @return full arity context, hence with letin *) -val inductive_alldecls : pinductive -> rel_context -val inductive_alldecls_env : env -> pinductive -> rel_context +val inductive_alldecls : pinductive -> Context.Rel.t +val inductive_alldecls_env : env -> pinductive -> Context.Rel.t (** {7 Extract information from a constructor name} *) @@ -133,9 +132,9 @@ val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> type constructor_summary = { cs_cstr : pconstructor; (* internal name of the constructor plus universes *) - cs_params : constr list; (* parameters of the constructor in current ctx *) - cs_nargs : int; (* length of arguments signature (letin included) *) - cs_args : rel_context; (* signature of the arguments (letin included) *) + cs_params : constr list; (* parameters of the constructor in current ctx *) + cs_nargs : int; (* length of arguments signature (letin included) *) + cs_args : Context.Rel.t; (* signature of the arguments (letin included) *) cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *) } val lift_constructor : int -> constructor_summary -> constructor_summary @@ -148,11 +147,11 @@ val get_projections : env -> inductive_family -> constant array option (** [get_arity] returns the arity of the inductive family instantiated with the parameters; if recursively non-uniform parameters are not part of the inductive family, they appears in the arity *) -val get_arity : env -> inductive_family -> rel_context * sorts_family +val get_arity : env -> inductive_family -> Context.Rel.t * sorts_family val build_dependent_constructor : constructor_summary -> constr val build_dependent_inductive : env -> inductive_family -> constr -val make_arity_signature : env -> bool -> inductive_family -> rel_context +val make_arity_signature : env -> bool -> inductive_family -> Context.Rel.t val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 0148280287..34191db344 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Term open Globnames open Glob_term diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ce6d189855..6d9ed9a30c 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -28,7 +28,6 @@ open Names open Evd open Term open Vars -open Context open Termops open Reductionops open Environ @@ -311,7 +310,7 @@ let ltac_interp_name_env k0 lvar env = specification of pretype which accepts to start with a non empty rel_context) *) (* tail is the part of the env enriched by pretyping *) - let n = rel_context_length (rel_context env) - k0 in + let n = Context.Rel.length (rel_context env) - k0 in let ctxt,_ = List.chop n (rel_context env) in let env = pop_rel_context n env in let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in @@ -529,14 +528,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let ty' = pretype_type empty_valcon env evdref lvar ty in let dcl = (na,None,ty'.utj_val) in let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl + type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in let dcl = (na,Some bd'.uj_val,ty'.utj_val) in let dcl' = (ltac_interp_name lvar na,Some bd'.uj_val,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl in - let ctxtv = Array.map (type_bl env empty_rel_context) bl in + type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in + let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in let larj = Array.map2 (fun e ar -> @@ -563,7 +562,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) + decompose_prod_n_assum (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in let nenv = push_rel_context ctxt newenv in let j = pretype (mk_tycon ty) nenv evdref lvar def in @@ -884,7 +883,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let pred = nf_evar !evdref pred in let p = nf_evar !evdref p in let f cs b = - let n = rel_context_length cs.cs_args in + let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist (pi, [build_dependent_constructor cs]) in let csgn = @@ -1017,7 +1016,7 @@ and pretype_type k0 resolve_tc valcon env evdref lvar = function let ise_pretype_gen flags env sigma lvar kind c = let evdref = ref sigma in - let k0 = rel_context_length (rel_context env) in + let k0 = Context.Rel.length (rel_context env) in let c' = match kind with | WithoutTypeConstraint -> (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val @@ -1059,7 +1058,7 @@ let on_judgment f j = let understand_judgment env sigma c = let evdref = ref sigma in - let k0 = rel_context_length (rel_context env) in + let k0 = Context.Rel.length (rel_context env) in let j = pretype k0 true empty_tycon env evdref empty_lvar c in let j = on_judgment (fun c -> let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in @@ -1067,7 +1066,7 @@ let understand_judgment env sigma c = in j, Evd.evar_universe_context !evdref let understand_judgment_tcc env evdref c = - let k0 = rel_context_length (rel_context env) in + let k0 = Context.Rel.length (rel_context env) in let j = pretype k0 true empty_tycon env evdref empty_lvar c in on_judgment (fun c -> let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 3f02e4bfb1..f59f880326 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -11,7 +11,6 @@ open Util open Names open Term open Vars -open Context open Termops open Univ open Evd @@ -1466,17 +1465,17 @@ let splay_prod_assum env sigma = match kind_of_term t with | Prod (x,t,c) -> prodec_rec (push_rel (x,None,t) env) - (add_rel_decl (x, None, t) l) c + (Context.Rel.add (x, None, t) l) c | LetIn (x,b,t,c) -> prodec_rec (push_rel (x, Some b, t) env) - (add_rel_decl (x, Some b, t) l) c + (Context.Rel.add (x, Some b, t) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let t' = whd_betadeltaiota env sigma t in if Term.eq_constr t t' then l,t else prodec_rec env l t' in - prodec_rec env empty_rel_context + prodec_rec env Context.Rel.empty let splay_arity env sigma c = let l, c = splay_prod env sigma c in @@ -1491,20 +1490,20 @@ let splay_prod_n env sigma n = match kind_of_term (whd_betadeltaiota env sigma c) with | Prod (n,a,c0) -> decrec (push_rel (n,None,a) env) - (m-1) (add_rel_decl (n,None,a) ln) c0 + (m-1) (Context.Rel.add (n,None,a) ln) c0 | _ -> invalid_arg "splay_prod_n" in - decrec env n empty_rel_context + decrec env n Context.Rel.empty let splay_lam_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Lambda (n,a,c0) -> decrec (push_rel (n,None,a) env) - (m-1) (add_rel_decl (n,None,a) ln) c0 + (m-1) (Context.Rel.add (n,None,a) ln) c0 | _ -> invalid_arg "splay_lam_n" in - decrec env n empty_rel_context + decrec env n Context.Rel.empty let is_sort env sigma t = match kind_of_term (whd_betadeltaiota env sigma t) with diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 43c98bbd47..5195784a4c 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Univ open Evd open Environ @@ -218,10 +217,10 @@ val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts val sort_of_arity : env -> evar_map -> constr -> sorts -val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr -val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr +val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr +val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr val splay_prod_assum : - env -> evar_map -> constr -> rel_context * constr + env -> evar_map -> constr -> Context.Rel.t * constr val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 89ba46dbc4..70345c5092 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -8,7 +8,6 @@ open Term open Evd -open Context open Environ (** This family of functions assumes its constr argument is known to be @@ -44,6 +43,6 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> val type_of_global_reference_knowing_conclusion : env -> evar_map -> constr -> types -> evar_map * types -val sorts_of_context : env -> evar_map -> rel_context -> sorts list +val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index deb03f5160..c4f22987f7 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -12,7 +12,6 @@ open Globnames open Decl_kinds open Term open Vars -open Context open Evd open Util open Typeclasses_errors @@ -59,10 +58,10 @@ type typeclass = { cl_impl : global_reference; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) - cl_context : (global_reference * bool) option list * rel_context; + cl_context : (global_reference * bool) option list * Context.Rel.t; (* Context of definitions and properties on defs, will not be shared *) - cl_props : rel_context; + cl_props : Context.Rel.t; (* The method implementaions as projections. *) cl_projs : (Name.t * (direction * int option) option * constant option) list; @@ -127,7 +126,7 @@ let typeclass_univ_instance (cl,u') = in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') in - let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in + let subst_ctx = Context.Rel.map (subst_univs_level_constr subst) in { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context); cl_props = subst_ctx cl.cl_props}, u' @@ -204,7 +203,7 @@ let discharge_class (_,cl) = (decl :: ctx', n :: subst) ) ctx ([], []) in let discharge_rel_context subst n rel = - let rel = map_rel_context (Cooking.expmod_constr repl) rel in + let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in let ctx, _ = List.fold_right (fun (id, b, t) (ctx, k) -> @@ -287,7 +286,7 @@ let build_subclasses ~check env sigma glob pri = | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = - Reductionops.whd_beta sigma (appvectc c (Context.extended_rel_vect 0 rels)) + Reductionops.whd_beta sigma (appvectc c (Context.Rel.to_extended_vect 0 rels)) in let projargs = Array.of_list (args @ [instapp]) in let projs = List.map_filter diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index b3170b9702..f56af19a02 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -9,7 +9,6 @@ open Names open Globnames open Term -open Context open Evd open Environ @@ -24,10 +23,10 @@ type typeclass = { (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses. The boolean indicates if the typeclass argument is a direct superclass and the global reference gives a direct link to the class itself. *) - cl_context : (global_reference * bool) option list * rel_context; + cl_context : (global_reference * bool) option list * Context.Rel.t; (** Context of definitions and properties on defs, will not be shared *) - cl_props : rel_context; + cl_props : Context.Rel.t; (** The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions or simply undefined if @@ -68,7 +67,7 @@ val dest_class_app : env -> constr -> typeclass puniverses * constr list val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option +val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index 585f066db4..7a918ee876 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -9,7 +9,6 @@ (*i*) open Names open Term -open Context open Environ open Constrexpr open Globnames @@ -20,7 +19,7 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr | UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *) - | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *) + | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *) exception TypeClassError of env * typeclass_error diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index 7982fc8524..b72d4db632 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -9,7 +9,6 @@ open Loc open Names open Term -open Context open Environ open Constrexpr open Globnames @@ -19,7 +18,7 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr | UnboundMethod of global_reference * Id.t located (** Class name, method *) - | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *) + | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *) exception TypeClassError of env * typeclass_error @@ -27,5 +26,5 @@ val not_a_class : env -> constr -> 'a val unbound_method : env -> global_reference -> Id.t located -> 'a -val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a +val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e8a0df4844..b42a70b340 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1582,7 +1582,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | AllOccurrences, InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in - if Context.eq_named_declaration d newdecl + if Context.Named.Declaration.equal d newdecl && not (indirectly_dependent c d depdecls) then if check_occs && not (in_every_hyp occs) @@ -1634,7 +1634,7 @@ type abstraction_request = type 'r abstraction_result = Names.Id.t * named_context_val * - Context.named_declaration list * Names.Id.t option * + Context.Named.Declaration.t list * Names.Id.t option * types * (constr, 'r) Sigma.sigma option let make_abstraction env evd ccl abs = diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 51a51f3752..14bcb4a06d 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -77,7 +77,7 @@ val finish_evar_resolution : ?flags:Pretyping.inference_flags -> type 'r abstraction_result = Names.Id.t * named_context_val * - Context.named_declaration list * Names.Id.t option * + Context.Named.Declaration.t list * Names.Id.t option * types * (constr, 'r) Sigma.sigma option val make_abstraction : env -> 'r Sigma.t -> constr -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c59e085e5b..38eea91700 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -53,7 +53,7 @@ let type_constructor mind mib u typ params = let s = ind_subst mind mib u in let ctyp = substl s typ in let ctyp = subst_instance_constr u ctyp in - let ndecls = Context.rel_context_length mib.mind_params_ctxt in + let ndecls = Context.Rel.length mib.mind_params_ctxt in if Int.equal ndecls 0 then ctyp else let _,ctyp = decompose_prod_n_assum ndecls ctyp in diff --git a/printing/printer.ml b/printing/printer.ml index 2e112f9ace..773127c772 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -293,7 +293,7 @@ let pr_named_context_of env sigma = hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl) let pr_named_context env sigma ne_context = - hv 0 (Context.fold_named_context + hv 0 (Context.Named.fold_outside (fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d) ne_context ~init:(mt ())) @@ -306,7 +306,7 @@ let pr_rel_context_of env sigma = (* Prints an env (variables and de Bruijn). Separator: newline *) let pr_context_unlimited env sigma = let sign_env = - Context.fold_named_list_context + Context.NamedList.fold (fun d pps -> let pidt = pr_var_list_decl env sigma d in (pps ++ fnl () ++ pidt)) @@ -333,7 +333,7 @@ let pr_context_limit n env sigma = else let k = lgsign-n in let _,sign_env = - Context.fold_named_list_context + Context.NamedList.fold (fun d (i,pps) -> if i < k then (i+1, (pps ++str ".")) @@ -726,7 +726,7 @@ let prterm = pr_lconstr type context_object = | Variable of Id.t (* A section variable or a Let definition *) - | Axiom of constant * (Label.t * Context.rel_context * types) list + | Axiom of constant * (Label.t * Context.Rel.t * types) list | Opaque of constant (* An opaque constant. *) | Transparent of constant diff --git a/printing/printer.mli b/printing/printer.mli index 5c60b89366..bdb295a478 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -10,7 +10,6 @@ open Pp open Names open Globnames open Term -open Context open Environ open Pattern open Evd @@ -109,13 +108,13 @@ val pr_pconstructor : env -> pconstructor -> std_ppcmds val pr_context_unlimited : env -> evar_map -> std_ppcmds val pr_ne_context_of : std_ppcmds -> env -> evar_map -> std_ppcmds -val pr_var_decl : env -> evar_map -> named_declaration -> std_ppcmds -val pr_var_list_decl : env -> evar_map -> named_list_declaration -> std_ppcmds -val pr_rel_decl : env -> evar_map -> rel_declaration -> std_ppcmds +val pr_var_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds +val pr_var_list_decl : env -> evar_map -> Context.NamedList.Declaration.t -> std_ppcmds +val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds -val pr_named_context : env -> evar_map -> named_context -> std_ppcmds +val pr_named_context : env -> evar_map -> Context.Named.t -> std_ppcmds val pr_named_context_of : env -> evar_map -> std_ppcmds -val pr_rel_context : env -> evar_map -> rel_context -> std_ppcmds +val pr_rel_context : env -> evar_map -> Context.Rel.t -> std_ppcmds val pr_rel_context_of : env -> evar_map -> std_ppcmds val pr_context_of : env -> evar_map -> std_ppcmds @@ -165,7 +164,7 @@ val prterm : constr -> std_ppcmds (** = pr_lconstr *) type context_object = | Variable of Id.t (** A section variable or a Let definition *) (** An axiom and the type it inhabits (if an axiom of the empty type) *) - | Axiom of constant * (Label.t * Context.rel_context * types) list + | Axiom of constant * (Label.t * Context.Rel.t * types) list | Opaque of constant (** An opaque constant. *) | Transparent of constant (** A transparent constant *) diff --git a/printing/printmod.ml b/printing/printmod.ml index d6f847cc71..d277d3782a 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -65,7 +65,6 @@ let get_new_id locals id = (** Inductive declarations *) -open Context open Termops open Reduction @@ -90,7 +89,7 @@ let print_one_inductive env sigma mib ((_,i) as ind) = else Univ.Instance.empty in let mip = mib.mind_packets.(i) in let params = Inductive.inductive_paramdecls (mib,u) in - let args = extended_rel_list 0 params in + let args = Context.Rel.to_extended_list 0 params in let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in @@ -144,7 +143,7 @@ let print_record env mind mib = in let mip = mib.mind_packets.(0) in let params = Inductive.inductive_paramdecls (mib,u) in - let args = extended_rel_list 0 params in + let args = Context.Rel.to_extended_list 0 params in let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in let cstrtype = hnf_prod_applist env cstrtypes.(0) args in diff --git a/proofs/goal.mli b/proofs/goal.mli index a00a95a2ff..46318b789f 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -67,7 +67,7 @@ module V82 : sig val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool (* Used for congruence closure *) - val new_goal_with : Evd.evar_map -> goal -> Context.named_context -> goal Evd.sigma + val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map diff --git a/proofs/logic.ml b/proofs/logic.ml index 1ba14e7d43..e80f5a64c7 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Environ open Reductionops diff --git a/proofs/logic.mli b/proofs/logic.mli index d034b73c56..d33f56bb7c 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -53,4 +53,4 @@ exception RefinerError of refiner_error val catchable_exception : exn -> bool val convert_hyp : bool -> Environ.named_context_val -> evar_map -> - Context.named_declaration -> Environ.named_context_val + Context.Named.Declaration.t -> Environ.named_context_val diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 9f2a00135b..155b2cfca4 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -215,7 +215,7 @@ let solve_by_implicit_tactic env sigma evk = match (!implicit_tactic, snd (evar_source evk sigma)) with | Some tac, (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _) when - Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps) + Context.Named.equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in (try diff --git a/proofs/proofview.mli b/proofs/proofview.mli index a92abcbbf1..aac56e565e 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -446,7 +446,7 @@ module Goal : sig environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) val concl : ([ `NF ], 'r) t -> Term.constr - val hyps : ([ `NF ], 'r) t -> Context.named_context + val hyps : ([ `NF ], 'r) t -> Context.Named.t val env : ('a, 'r) t -> Environ.env val sigma : ('a, 'r) t -> 'r Sigma.t val extra : ('a, 'r) t -> Evd.Store.t diff --git a/proofs/refiner.ml b/proofs/refiner.ml index ba62b2cb2d..de70250626 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -197,10 +197,10 @@ let tclNOTSAMEGOAL (tac : tactic) goal = destruct), this is not detected by this tactical. *) let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) :Proof_type.goal list Evd.sigma = - let oldhyps:Context.named_context = pf_hyps goal in + let oldhyps:Context.Named.t = pf_hyps goal in let rslt:Proof_type.goal list Evd.sigma = tac goal in let { it = gls; sigma = sigma; } = rslt in - let hyps:Context.named_context list = + let hyps:Context.Named.t list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in let newhyps = diff --git a/proofs/refiner.mli b/proofs/refiner.mli index a81555ff5e..2959787d4c 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Evd open Proof_type @@ -16,7 +15,7 @@ val sig_it : 'a sigma -> 'a val project : 'a sigma -> evar_map val pf_env : goal sigma -> Environ.env -val pf_hyps : goal sigma -> named_context +val pf_hyps : goal sigma -> Context.Named.t val unpackage : 'a sigma -> evar_map ref * 'a val repackage : evar_map ref -> 'a -> 'a sigma diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 57c60cbeed..dc0cf81a76 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -48,7 +48,7 @@ let pf_last_hyp gl = List.hd (pf_hyps gl) let pf_get_hyp gls id = try - Context.lookup_named id (pf_hyps gls) + Context.Named.lookup id (pf_hyps gls) with Not_found -> raise (RefinerError (NoSuchHyp id)) @@ -198,7 +198,7 @@ module New = struct let pf_get_hyp id gl = let hyps = Proofview.Goal.hyps gl in let sign = - try Context.lookup_named id hyps + try Context.Named.lookup id hyps with Not_found -> raise (RefinerError (NoSuchHyp id)) in sign diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index c45fd250cb..b7915e8371 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Environ open Evd open Proof_type @@ -34,18 +33,18 @@ val apply_sig_tac : val pf_concl : goal sigma -> types val pf_env : goal sigma -> env -val pf_hyps : goal sigma -> named_context +val pf_hyps : goal sigma -> Context.Named.t (*i val pf_untyped_hyps : goal sigma -> (Id.t * constr) list i*) val pf_hyps_types : goal sigma -> (Id.t * types) list val pf_nth_hyp_id : goal sigma -> int -> Id.t -val pf_last_hyp : goal sigma -> named_declaration +val pf_last_hyp : goal sigma -> Context.Named.Declaration.t val pf_ids_of_hyps : goal sigma -> Id.t list val pf_global : goal sigma -> Id.t -> constr val pf_unsafe_type_of : goal sigma -> constr -> types val pf_type_of : goal sigma -> constr -> evar_map * types val pf_hnf_type_of : goal sigma -> constr -> types -val pf_get_hyp : goal sigma -> Id.t -> named_declaration +val pf_get_hyp : goal sigma -> Id.t -> Context.Named.Declaration.t val pf_get_hyp_typ : goal sigma -> Id.t -> types val pf_get_new_id : Id.t -> goal sigma -> Id.t @@ -123,9 +122,9 @@ module New : sig val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list - val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t val pf_get_hyp_typ : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types - val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types diff --git a/tactics/auto.ml b/tactics/auto.ml index 4fb4b32632..a170c27fb9 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -327,7 +327,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in - let hyp = Context.map_named_declaration nf decl in + let hyp = Context.Named.Declaration.map nf decl in let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 64a68ba6bc..2c713a0210 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -49,7 +49,6 @@ open Util open Names open Term open Vars -open Context open Declarations open Environ open Inductive @@ -71,8 +70,8 @@ let build_dependent_inductive ind (mib,mip) = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist (mkIndU ind, - extended_rel_list mip.mind_nrealdecls mib.mind_params_ctxt - @ extended_rel_list 0 realargs) + Context.Rel.to_extended_list mip.mind_nrealdecls mib.mind_params_ctxt + @ Context.Rel.to_extended_list 0 realargs) let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s @@ -109,7 +108,7 @@ let get_sym_eq_data env (ind,u) = error "Inductive equalities with local definitions in arity not supported."; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then + if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; (* This can be relaxed... *) let params,constrargs = List.chop mib.mind_nparams constrargs in if mip.mind_nrealargs > mib.mind_nparams then @@ -144,7 +143,7 @@ let get_non_sym_eq_data env (ind,u) = error "Inductive equalities with local definitions in arity not supported"; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then + if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; let _,constrargs = List.chop mib.mind_nparams constrargs in let constrargs = List.map (Vars.subst_instance_constr u) constrargs in @@ -170,7 +169,7 @@ let build_sym_scheme env ind = let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let cstr n = - mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect n mib.mind_params_ctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = @@ -183,7 +182,7 @@ let build_sym_scheme env ind = my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkApp (mkIndU indu,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), @@ -224,13 +223,13 @@ let build_sym_involutive_scheme env ind = get_sym_eq_data env indu in let eq,eqrefl,ctx = get_coq_eq ctx in let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in - let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in + let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect n paramsctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp (mkIndU indu, Array.append - (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt) + (Context.Rel.to_extended_vect (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = name_context env ((Name varH,None,applied_ind)::realsign) in @@ -244,15 +243,15 @@ let build_sym_involutive_scheme env ind = (mkApp (eq,[| mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs]); mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs; [|mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]])|]]); @@ -335,7 +334,7 @@ let build_l2r_rew_scheme dep env ind kind = let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = mkApp (mkConstructUi(indu,1), - Array.concat [extended_rel_vect n paramsctxt1; + Array.concat [Context.Rel.to_extended_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -343,12 +342,12 @@ let build_l2r_rew_scheme dep env ind kind = let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs) paramsctxt1; rel_vect 0 nrealargs; rel_vect nrealargs nrealargs]) in let applied_ind_G = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs+3) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+3) paramsctxt1; rel_vect (nrealargs+3) nrealargs; rel_vect 0 nrealargs]) in let realsign_P = lift_rel_context nrealargs realsign in @@ -359,10 +358,10 @@ let build_l2r_rew_scheme dep env ind kind = lift_rel_context (nrealargs+3) realsign) in let applied_sym_C n = mkApp(sym, - Array.append (extended_rel_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in + Array.append (Context.Rel.to_extended_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in let applied_sym_G = mkApp(sym, - Array.concat [extended_rel_vect (nrealargs*3+4) paramsctxt1; + Array.concat [Context.Rel.to_extended_vect (nrealargs*3+4) paramsctxt1; rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in @@ -372,7 +371,7 @@ let build_l2r_rew_scheme dep env ind kind = let ci = make_case_info (Global.env()) ind RegularStyle in let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in let applied_PC = - mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign) + mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 1 nrealargs) @@ -382,11 +381,11 @@ let build_l2r_rew_scheme dep env ind kind = (if dep then [|mkRel 2|] else [||])) in let applied_sym_sym = mkApp (sym,Array.concat - [extended_rel_vect (2*nrealargs+4) paramsctxt1; + [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1; rel_vect 4 nrealargs; rel_vect (nrealargs+4) nrealargs; [|mkApp (sym,Array.concat - [extended_rel_vect (2*nrealargs+4) paramsctxt1; + [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1; rel_vect (nrealargs+4) nrealargs; rel_vect 4 nrealargs; [|mkRel 2|]])|]]) in @@ -409,7 +408,7 @@ let build_l2r_rew_scheme dep env ind kind = mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), applied_PR)), mkApp (sym_involutive, - Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), + Array.append (Context.Rel.to_extended_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), [|main_body|]) else main_body)))))) @@ -448,7 +447,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = get_sym_eq_data env indu in let cstr n p = mkApp (mkConstructUi(indu,1), - Array.concat [extended_rel_vect n paramsctxt1; + Array.concat [Context.Rel.to_extended_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -456,12 +455,12 @@ let build_l2r_forward_rew_scheme dep env ind kind = let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (4*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (4*nrealargs+2) paramsctxt1; rel_vect 0 nrealargs; rel_vect (nrealargs+1) nrealargs]) in let applied_ind_P' = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs+1) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+1) paramsctxt1; rel_vect 0 nrealargs; rel_vect (2*nrealargs+1) nrealargs]) in let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in @@ -539,7 +538,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = get_non_sym_eq_data env indu in let cstr n = - mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -555,8 +554,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in let applied_PG = mkApp (mkVar varP, - if dep then extended_rel_vect 0 realsign_ind - else extended_rel_vect 1 realsign) in + if dep then Context.Rel.to_extended_vect 0 realsign_ind + else Context.Rel.to_extended_vect 1 realsign) in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind @@ -600,12 +599,12 @@ let fix_r2l_forward_rew_scheme (c, ctx') = | hp :: p :: ind :: indargs -> let c' = my_it_mkLambda_or_LetIn indargs - (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p) - (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp) - (mkLambda_or_LetIn (map_rel_declaration (lift 2) ind) + (mkLambda_or_LetIn (Context.Rel.Declaration.map (liftn (-1) 1) p) + (mkLambda_or_LetIn (Context.Rel.Declaration.map (liftn (-1) 2) hp) + (mkLambda_or_LetIn (Context.Rel.Declaration.map (lift 2) ind) (Reductionops.whd_beta Evd.empty (applist (c, - extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) + Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") @@ -744,7 +743,7 @@ let build_congr env (eq,refl,ctx) ind = let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt) then + if Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt) then error "Constructor must have no arguments"; let b = List.nth constrargs (i + mib.mind_nparams - 1) in let varB = fresh env (Id.of_string "B") in @@ -760,8 +759,8 @@ let build_congr env (eq,refl,ctx) ind = (mkNamedLambda varH (applist (mkIndU indu, - extended_rel_list (mip.mind_nrealargs+2) paramsctxt @ - extended_rel_list 0 realsign)) + Context.Rel.to_extended_list (mip.mind_nrealargs+2) paramsctxt @ + Context.Rel.to_extended_list 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) @@ -769,9 +768,9 @@ let build_congr env (eq,refl,ctx) ind = (Anonymous, applist (mkIndU indu, - extended_rel_list (2*mip.mind_nrealdecls+3) + Context.Rel.to_extended_list (2*mip.mind_nrealdecls+3) paramsctxt - @ extended_rel_list 0 realsign), + @ Context.Rel.to_extended_list 0 realsign), mkApp (eq, [|mkVar varB; mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]); diff --git a/tactics/equality.ml b/tactics/equality.ml index 92ebcb2724..7d15e9ee66 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1574,7 +1574,7 @@ let unfold_body x = Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let (_, xval, _) = Context.lookup_named x hyps in + let (_, xval, _) = Context.Named.lookup x hyps in let xval = match xval with | None -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") @@ -1656,7 +1656,7 @@ let subst_one_var dep_proof_ok x = (** [is_eq_x] ensures nf_evar on its side *) let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl varx hyp in - Context.fold_named_context test ~init:() hyps; + Context.Named.fold_outside test ~init:() hyps; errorlabstrm "Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 92682fc7a0..f311e47f63 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -315,7 +315,7 @@ let project_hint pri l2r r = | _ -> assert false in let p = if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let c = Reductionops.whd_beta Evd.empty (mkApp (c,Context.extended_rel_vect 0 sign)) in + let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in let id = diff --git a/tactics/hints.mli b/tactics/hints.mli index 3a0521f665..b48fb776eb 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -10,7 +10,6 @@ open Pp open Util open Names open Term -open Context open Environ open Globnames open Decl_kinds @@ -192,7 +191,7 @@ val make_resolves : If the hyp cannot be used as a Hint, the empty list is returned. *) val make_resolve_hyp : - env -> evar_map -> named_declaration -> hint_entry list + env -> evar_map -> Context.Named.Declaration.t -> hint_entry list (** [make_extern pri pattern tactic_expr] *) diff --git a/tactics/inv.ml b/tactics/inv.ml index ed1a627956..3574990f6c 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Namegen open Environ @@ -97,7 +96,7 @@ let make_inv_predicate env evd indf realargs id status concl = (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) in - let nhyps = rel_context_length hyps in + let nhyps = Context.Rel.length hyps in let env' = push_rel_context hyps env in (* Now the arity is pushed, and we need to construct the pairs * ai,mkRel(n-i+1) *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 75e69bc091..9154c50c80 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -14,7 +14,6 @@ open Term open Vars open Termops open Namegen -open Context open Evd open Printer open Reductionops @@ -157,7 +156,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = fold_named_context (fun env (id,_,_ as d) (revargs,hyps) -> if Id.List.mem id ivars then - ((mkVar id)::revargs,add_named_decl d hyps) + ((mkVar id)::revargs, Context.Named.add d hyps) else (revargs,hyps)) env ~init:([],[]) @@ -206,8 +205,8 @@ let inversion_scheme env sigma t sort dep_option inv_op = fold_named_context (fun env (id,_,_ as d) sign -> if mem_named_context id global_named_context then sign - else add_named_decl d sign) - invEnv ~init:empty_named_context + else Context.Named.add d sign) + invEnv ~init:Context.Named.empty end in let avoid = ref [] in let { sigma=sigma } = Proof.V82.subgoals pf in @@ -218,7 +217,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := h::!avoid; - ownSign := add_named_decl (h,None,ty) !ownSign; + ownSign := Context.Named.add (h,None,ty) !ownSign; applist (mkVar h, inst) | _ -> map_constr fill_holes c in diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli index 40a18ac458..1de47b2bea 100644 --- a/tactics/rewrite.mli +++ b/tactics/rewrite.mli @@ -71,7 +71,7 @@ val cl_rewrite_clause : bool -> Locus.occurrences -> Id.t option -> tactic val is_applied_rewrite_relation : - env -> evar_map -> Context.rel_context -> constr -> types option + env -> evar_map -> Context.Rel.t -> constr -> types option val declare_relation : ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t -> diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli index d8e6dd0ae3..090207bcc3 100644 --- a/tactics/tactic_matching.mli +++ b/tactics/tactic_matching.mli @@ -43,7 +43,7 @@ val match_term : val match_goal: Environ.env -> Evd.evar_map -> - Context.named_context -> + Context.Named.t -> Term.constr -> (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index e181c8e14e..aaef0f072f 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -12,7 +12,6 @@ open Util open Names open Term open Termops -open Context open Declarations open Tacmach open Clenv @@ -154,8 +153,8 @@ type branch_args = { branchnames : Tacexpr.intro_patterns} type branch_assumptions = { - ba : branch_args; (* the branch args *) - assums : named_context} (* the list of assumptions introduced *) + ba : branch_args; (* the branch args *) + assums : Context.Named.t} (* the list of assumptions introduced *) let fix_empty_or_and_pattern nv l = (* 1- The syntax does not distinguish between "[ ]" for one clause with no diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 80e01a8d07..d8aa3161e8 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -9,7 +9,6 @@ open Pp open Names open Term -open Context open Tacmach open Proof_type open Tacexpr @@ -60,29 +59,29 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic val onNthHypId : int -> (Id.t -> tactic) -> tactic val onNthHyp : int -> (constr -> tactic) -> tactic -val onNthDecl : int -> (named_declaration -> tactic) -> tactic +val onNthDecl : int -> (Context.Named.Declaration.t -> tactic) -> tactic val onLastHypId : (Id.t -> tactic) -> tactic val onLastHyp : (constr -> tactic) -> tactic -val onLastDecl : (named_declaration -> tactic) -> tactic +val onLastDecl : (Context.Named.Declaration.t -> tactic) -> tactic val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic val onNLastHyps : int -> (constr list -> tactic) -> tactic -val onNLastDecls : int -> (named_context -> tactic) -> tactic +val onNLastDecls : int -> (Context.Named.t -> tactic) -> tactic val lastHypId : goal sigma -> Id.t val lastHyp : goal sigma -> constr -val lastDecl : goal sigma -> named_declaration +val lastDecl : goal sigma -> Context.Named.Declaration.t val nLastHypsId : int -> goal sigma -> Id.t list val nLastHyps : int -> goal sigma -> constr list -val nLastDecls : int -> goal sigma -> named_context +val nLastDecls : int -> goal sigma -> Context.Named.t -val afterHyp : Id.t -> goal sigma -> named_context +val afterHyp : Id.t -> goal sigma -> Context.Named.t val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> Id.t -> tactic -val onHyps : (goal sigma -> named_context) -> - (named_context -> tactic) -> tactic +val onHyps : (goal sigma -> Context.Named.t) -> + (Context.Named.t -> tactic) -> tactic (** {6 Tacticals applying to goal components } *) @@ -99,18 +98,18 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) type branch_args = { - ity : pinductive; (** the type we were eliminating on *) + ity : pinductive; (** the type we were eliminating on *) largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) pred : constr; (** the predicate we used *) nassums : int; (** the number of assumptions to be introduced *) branchsign : bool list; (** the signature of the branch. - true=recursive argument, false=constant *) + true=recursive argument, false=constant *) branchnames : intro_patterns} type branch_assumptions = { - ba : branch_args; (** the branch args *) - assums : named_context} (** the list of assumptions introduced *) + ba : branch_args; (** the branch args *) + assums : Context.Named.t} (** the list of assumptions introduced *) (** [check_disjunctive_pattern_size loc pats n] returns an appropriate error message if |pats| <> n *) @@ -223,7 +222,7 @@ module New : sig val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> named_context + val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> Context.Named.t val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> @@ -232,11 +231,11 @@ module New : sig val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic val onLastHypId : (identifier -> unit tactic) -> unit tactic val onLastHyp : (constr -> unit tactic) -> unit tactic - val onLastDecl : (named_declaration -> unit tactic) -> unit tactic + val onLastDecl : (Context.Named.Declaration.t -> unit tactic) -> unit tactic - val onHyps : ([ `NF ], named_context) Proofview.Goal.enter -> - (named_context -> unit tactic) -> unit tactic - val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic + val onHyps : ([ `NF ], Context.Named.t) Proofview.Goal.enter -> + (Context.Named.t -> unit tactic) -> unit tactic + val afterHyp : Id.t -> (Context.Named.t -> unit tactic) -> unit tactic val tryAllHyps : (identifier -> unit tactic) -> unit tactic val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2e7adc513a..f2319804ec 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Find_subterm open Namegen @@ -1405,7 +1404,7 @@ let make_projection env sigma params cstr sign elim i n c u = then let t = lift (i+1-n) t in let abselim = beta_applist (elim,params@[t;branch]) in - let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in + let c = beta_applist (abselim, [mkApp (c, Context.Rel.to_extended_vect 0 sign)]) in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None @@ -1413,7 +1412,7 @@ let make_projection env sigma params cstr sign elim i n c u = (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> - let args = extended_rel_vect 0 sign in + let args = Context.Rel.to_extended_vect 0 sign in let proj = if Environ.is_projection proj env then mkProj (Projection.make proj false, mkApp (c, args)) @@ -2528,7 +2527,7 @@ let bring_hyps hyps = let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in - let args = Array.of_list (instance_from_named_context hyps) in + let args = Array.of_list (Context.Named.to_instance hyps) in Proofview.Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in @@ -2589,7 +2588,7 @@ let generalize_dep ?(with_let=false) c gl = d::toquant else toquant in - let to_quantify = Context.fold_named_context seek sign ~init:[] in + let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in @@ -2609,7 +2608,7 @@ let generalize_dep ?(with_let=false) c gl = in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in - let args = instance_from_named_context to_quantify_rev in + let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; apply_type cl'' (if Option.is_empty body then c::args else args); @@ -2687,7 +2686,7 @@ let quantify lconstr = let unfold_body x gl = let hyps = pf_hyps gl in let xval = - match Context.lookup_named x hyps with + match Context.Named.lookup x hyps with (_,Some xval,_) -> xval | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") in @@ -3108,20 +3107,20 @@ type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; - params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) - nparams: int; (* number of parameters *) - predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) - npredicates: int; (* Number of predicates *) - branches: rel_context; (* branchr,...,branch1 *) - nbranches: int; (* Number of branches *) - args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) - nargs: int; (* number of arguments *) - indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) - if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) - are optional and mutually exclusive *) - indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) - farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) + params: Context.Rel.t; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + nparams: int; (* number of parameters *) + predicates: Context.Rel.t; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + npredicates: int; (* Number of predicates *) + branches: Context.Rel.t; (* branchr,...,branch1 *) + nbranches: int; (* Number of branches *) + args: Context.Rel.t; (* (xni, Ti_ni) ... (x1, Ti_1) *) + nargs: int; (* number of arguments *) + indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni) + if HI is in premisses, None otherwise *) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) + are optional and mutually exclusive *) + indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) + farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } let empty_scheme = @@ -3280,7 +3279,7 @@ let hyps_of_vars env sign nogen hyps = if Id.Set.is_empty hyps then [] else let (_,lh) = - Context.fold_named_context_reverse + Context.Named.fold_inside (fun (hs,hl) (x,_,_ as d) -> if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) @@ -3511,7 +3510,7 @@ let occur_rel n c = We also return the conclusion. *) let decompose_paramspred_branch_args elimt = - let rec cut_noccur elimt acc2 : rel_context * rel_context * types = + let rec cut_noccur elimt acc2 : Context.Rel.t * Context.Rel.t * types = match kind_of_term elimt with | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in @@ -3520,7 +3519,7 @@ let decompose_paramspred_branch_args elimt = else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in - let rec cut_occur elimt acc1 : rel_context * rel_context * rel_context * types = + let rec cut_occur elimt acc1 : Context.Rel.t * Context.Rel.t * Context.Rel.t * types = match kind_of_term elimt with | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c ((nme,None,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl @@ -3648,7 +3647,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = let ind_is_ok = List.equal Term.eq_constr (List.lastn scheme.nargs indargs) - (extended_rel_list 0 scheme.args) in + (Context.Rel.to_extended_list 0 scheme.args) in if not (ccl_arg_ok && ind_is_ok) then error_ind_scheme "the conclusion of" in (cond, check_concl) @@ -4563,10 +4562,10 @@ let abstract_subproof id gk tac = List.fold_right (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign && - interpretable_as_section_decl evdref (Context.lookup_named id current_sign) d + interpretable_as_section_decl evdref (Context.Named.lookup id current_sign) d then (s1,push_named_context_val d s2) - else (add_named_decl d s1,s2)) - global_sign (empty_named_context,empty_named_context_val) in + else (Context.Named.add d s1,s2)) + global_sign (Context.Named.empty, empty_named_context_val) in let id = next_global_ident_away id (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in let concl = @@ -4594,7 +4593,7 @@ let abstract_subproof id gk tac = in let const, args = if !shrink_abstract then shrink_entry sign const - else (const, List.rev (instance_from_named_context sign)) + else (const, List.rev (Context.Named.to_instance sign)) in let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index f5695ff06e..873a11bd29 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -9,7 +9,6 @@ open Loc open Names open Term -open Context open Environ open Proof_type open Evd @@ -33,9 +32,9 @@ val is_quantified_hypothesis : Id.t -> goal sigma -> bool val introduction : ?check:bool -> Id.t -> unit Proofview.tactic val refine : constr -> tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic -val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic +val convert_hyp : ?check:bool -> Context.Named.Declaration.t -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic -val convert_hyp_no_check : named_declaration -> unit Proofview.tactic +val convert_hyp_no_check : Context.Named.Declaration.t -> unit Proofview.tactic val thin : Id.t list -> tactic val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> tactic @@ -50,7 +49,7 @@ val convert_leq : constr -> constr -> unit Proofview.tactic val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t -val find_intro_names : rel_context -> goal sigma -> Id.t list +val find_intro_names : Context.Rel.t -> goal sigma -> Id.t list val intro : unit Proofview.tactic val introf : unit Proofview.tactic @@ -180,7 +179,7 @@ val revert : Id.t list -> unit Proofview.tactic (** {6 Resolution tactics. } *) val apply_type : constr -> constr list -> tactic -val bring_hyps : named_context -> unit Proofview.tactic +val bring_hyps : Context.Named.t -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic @@ -239,20 +238,20 @@ type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; - params: rel_context; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) - nparams: int; (** number of parameters *) - predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) - npredicates: int; (** Number of predicates *) - branches: rel_context; (** branchr,...,branch1 *) - nbranches: int; (** Number of branches *) - args: rel_context; (** (xni, Ti_ni) ... (x1, Ti_1) *) - nargs: int; (** number of arguments *) - indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni) - if HI is in premisses, None otherwise *) - concl: types; (** Qi x1...xni HI (f...), HI and (f...) - are optional and mutually exclusive *) - indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) - farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) + params: Context.Rel.t; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + nparams: int; (** number of parameters *) + predicates: Context.Rel.t; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + npredicates: int; (** Number of predicates *) + branches: Context.Rel.t; (** branchr,...,branch1 *) + nbranches: int; (** Number of branches *) + args: Context.Rel.t; (** (xni, Ti_ni) ... (x1, Ti_1) *) + nargs: int; (** number of arguments *) + indarg: Context.Rel.Declaration.t option; (** Some (H,I prm1..prmp x1...xni) + if HI is in premisses, None otherwise *) + concl: types; (** Qi x1...xni HI (f...), HI and (f...) + are optional and mutually exclusive *) + indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) + farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) } val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index a71588fe05..4704854384 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -141,7 +141,7 @@ let label_of = function | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn) | VarRef id -> Label.of_id id -let push (r : Context.rel_declaration) (ctx : Context.rel_context) = r :: ctx +let push (r : Context.Rel.Declaration.t) (ctx : Context.Rel.t) = r :: ctx let rec traverse current ctx accu t = match kind_of_term t with | Var id -> diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli index 9c9f81bd2f..61beb26c8e 100644 --- a/toplevel/assumptions.mli +++ b/toplevel/assumptions.mli @@ -22,7 +22,7 @@ open Printer val traverse : Label.t -> constr -> (Refset_env.t * Refset_env.t Refmap_env.t * - (label * Context.rel_context * types) list Refmap_env.t) + (label * Context.Rel.t * types) list Refmap_env.t) (** Collects all the assumptions (optionally including opaque definitions) on which a term relies (together with their type). The above warning of diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 98686fb1b7..56106928e5 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -15,7 +15,6 @@ open Util open Pp open Term open Vars -open Context open Termops open Declarations open Names @@ -103,7 +102,7 @@ let mkFullInd (ind,u) n = context_chop (nparams-nparrec) mib.mind_params_ctxt in if nparrec > 0 then mkApp (mkIndU (ind,u), - Array.of_list(extended_rel_list (nparrec+n) lnamesparrec)) + Array.of_list(Context.Rel.to_extended_list (nparrec+n) lnamesparrec)) else mkIndU (ind,u) let check_bool_is_defined () = @@ -138,7 +137,7 @@ let build_beq_scheme mode kn = | Name s -> Id.of_string ("eq_"^(Id.to_string s)) | Anonymous -> Id.of_string "eq_A" in - let ext_rel_list = extended_rel_list 0 lnamesparrec in + let ext_rel_list = Context.Rel.to_extended_list 0 lnamesparrec in let lift_cnt = ref 0 in let eqs_typ = List.map (fun aa -> let a = lift !lift_cnt aa in @@ -234,7 +233,7 @@ let build_beq_scheme mode kn = Cn => match Y with ... end |] part *) let ci = make_case_info env (fst ind) MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, - extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in + Context.Rel.to_extended_list (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in let ar = Array.make n (Lazy.force ff) in diff --git a/toplevel/class.ml b/toplevel/class.ml index 22baa5e61c..28a39b5706 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -12,7 +12,6 @@ open Pp open Names open Term open Vars -open Context open Termops open Entries open Environ @@ -198,13 +197,13 @@ let build_id_coercion idf_opt source poly = let val_f = it_mkLambda_or_LetIn (mkLambda (Name Namegen.default_dependent_ident, - applistc vs (extended_rel_list 0 lams), + applistc vs (Context.Rel.to_extended_list 0 lams), mkRel 1)) lams in let typ_f = it_mkProd_wo_LetIn - (mkProd (Anonymous, applistc vs (extended_rel_list 0 lams), lift 1 t)) + (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list 0 lams), lift 1 t)) lams in (* juste pour verification *) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 9cdb460644..ab18350c5c 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -351,7 +351,7 @@ let context poly l = let evars = ref (Evd.from_env env) in let _, ((env', fullctx), impls) = interp_context_evars env evars l in let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in - let fullctx = Context.map_rel_context subst fullctx in + let fullctx = Context.Rel.map subst fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in let () = List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx in let ctx = diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 2b7e9e4fe2..80ed246294 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Context open Environ open Constrexpr open Typeclasses @@ -15,9 +14,9 @@ open Libnames (** Errors *) -val mismatched_params : env -> constr_expr list -> rel_context -> 'a +val mismatched_params : env -> constr_expr list -> Context.Rel.t -> 'a -val mismatched_props : env -> constr_expr list -> rel_context -> 'a +val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a (** Instance declaration *) diff --git a/toplevel/command.ml b/toplevel/command.ml index 91cfddb547..500769aca3 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -12,7 +12,6 @@ open Util open Flags open Term open Vars -open Context open Termops open Entries open Environ @@ -87,7 +86,7 @@ let interp_definition pl bl p red_option c ctypopt = match ctypopt with None -> let subst = evd_comb0 Evd.nf_univ_variables evdref in - let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in let env_bl = push_rel_context ctx env in let c, imps2 = interp_constr_evars_impls ~impls env_bl evdref c in let nf,subst = Evarutil.e_nf_evars_and_universes evdref in @@ -100,7 +99,7 @@ let interp_definition pl bl p red_option c ctypopt = | Some ctyp -> let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in let subst = evd_comb0 Evd.nf_univ_variables evdref in - let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in let env_bl = push_rel_context ctx env in let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in let nf, subst = Evarutil.e_nf_evars_and_universes evdref in @@ -125,7 +124,7 @@ let interp_definition pl bl p red_option c ctypopt = definition_entry ~types:typ ~poly:p ~univs:uctx body in - red_constant_entry (rel_context_length ctx) ce !evdref red_option, !evdref, pl, imps + red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, pl, imps let check_definition (ce, evd, _, imps) = check_evars_are_solved (Global.env ()) evd (Evd.empty,evd); @@ -566,7 +565,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = (* Compute interpretation metadatas *) let indimpls = List.map (fun (_, _, impls) -> userimpls @ - lift_implicits (rel_context_nhyps ctx_params) impls) arities in + lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in @@ -592,11 +591,11 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let nf x = nf' (nf x) in let arities = List.map nf' arities in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in - let ctx_params = map_rel_context nf ctx_params in + let ctx_params = Context.Rel.map nf ctx_params in let evd = !evdref in let pl, uctx = Evd.universe_context ?names:pl evd in List.iter (check_evars env_params Evd.empty evd) arities; - iter_rel_context (check_evars env0 Evd.empty evd) ctx_params; + Context.Rel.iter (check_evars env0 Evd.empty evd) ctx_params; List.iter (fun (_,ctyps,_) -> List.iter (check_evars env_ar_params Evd.empty evd) ctyps) constructors; @@ -610,7 +609,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = mind_entry_lc = ctypes }) indl arities aritypoly constructors in let impls = - let len = rel_context_nhyps ctx_params in + let len = Context.Rel.nhyps ctx_params in List.map2 (fun indimpls (_,_,cimpls) -> indimpls, List.map (fun impls -> userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index b6da21e5ae..9416b7e7ad 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -9,7 +9,6 @@ open Names open Errors open Util -open Context open Term open Vars open Entries @@ -37,8 +36,8 @@ let detype_param = function let abstract_inductive hyps nparams inds = let ntyp = List.length inds in - let nhyp = named_context_length hyps in - let args = instance_from_named_context (List.rev hyps) in + let nhyp = Context.Named.length hyps in + let args = Context.Named.to_instance (List.rev hyps) in let args = Array.of_list args in let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in let inds' = @@ -100,7 +99,7 @@ let process_inductive (sechyps,abs_ctx) modlist mib = Array.to_list mip.mind_consnames, Array.to_list lc)) mib.mind_packets in - let sechyps' = map_named_context (expmod_constr modlist) sechyps in + let sechyps' = Context.Named.map (expmod_constr modlist) sechyps in let (params',inds') = abstract_inductive sechyps' nparams inds in let abs_ctx = Univ.instantiate_univ_context abs_ctx in let univs = Univ.UContext.union abs_ctx univs in diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index 386e4e3ef8..2984a0be82 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -6,10 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Declarations open Entries open Opaqueproof val process_inductive : - named_context Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry + Context.Named.t Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index cac81a9395..e27e414377 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -13,7 +13,6 @@ open Declare *) open Term -open Context open Vars open Names open Evd @@ -44,7 +43,7 @@ let check_evars env evm = type oblinfo = { ev_name: int * Id.t; - ev_hyps: named_context; + ev_hyps: Context.Named.t; ev_status: Evar_kinds.obligation_definition_status; ev_chop: int option; ev_src: Evar_kinds.t Loc.located; @@ -191,7 +190,7 @@ open Environ let eterm_obligations env name evm fs ?status t ty = (* 'Serialize' the evars *) let nc = Environ.named_context env in - let nc_len = Context.named_context_length nc in + let nc_len = Context.Named.length nc in let evm = Evarutil.nf_evar_map_undefined evm in let evl = Evarutil.non_instantiated evm in let evl = Evar.Map.bindings evl in diff --git a/toplevel/record.ml b/toplevel/record.ml index 3a75004b08..12699b02b4 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -13,7 +13,6 @@ open Names open Globnames open Nameops open Term -open Context open Vars open Environ open Declarations @@ -148,8 +147,8 @@ let typecheck_params_and_fields def id pl t ps nots fs = else arity, evars in let evars, nf = Evarutil.nf_evars_and_universes evars in - let newps = map_rel_context nf newps in - let newfs = map_rel_context nf newfs in + let newps = Context.Rel.map nf newps in + let newfs = Context.Rel.map nf newfs in let ce t = Evarutil.check_evars env0 Evd.empty evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); @@ -244,8 +243,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let ctx = Univ.instantiate_univ_context mib.mind_universes in let indu = indsp, u in let r = mkIndU (indsp,u) in - let rp = applist (r, Context.extended_rel_list 0 paramdecls) in - let paramargs = Context.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) + let rp = applist (r, Context.Rel.to_extended_list 0 paramdecls) in + let paramargs = Context.Rel.to_extended_list 1 paramdecls in (*def in [[params;x:rp]]*) let x = Name binder_name in let fields = instantiate_possibly_recursive_type indu paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in @@ -353,7 +352,7 @@ open Typeclasses let declare_structure finite poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in - let args = Context.extended_rel_list nfields params in + let args = Context.Rel.to_extended_list nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in let binder_name = diff --git a/toplevel/record.mli b/toplevel/record.mli index eccb5d29d6..f68adcec8e 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -8,7 +8,6 @@ open Names open Term -open Context open Vernacexpr open Constrexpr open Impargs @@ -22,15 +21,15 @@ val primitive_flag : bool ref val declare_projections : inductive -> ?kind:Decl_kinds.definition_object_kind -> Id.t -> - coercion_flag list -> manual_explicitation list list -> rel_context -> + coercion_flag list -> manual_explicitation list list -> Context.Rel.t -> (Name.t * bool) list * constant option list val declare_structure : Decl_kinds.recursivity_kind -> bool (** polymorphic?*) -> Univ.universe_context -> Id.t -> Id.t -> - manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *) + manual_explicitation list -> Context.Rel.t -> (** params *) constr -> (** arity *) bool (** template arity ? *) -> - Impargs.manual_explicitation list list -> rel_context -> (** fields *) + Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> bool -> (** coercion? *) bool list -> (** field coercions *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 28b5bace13..2dacc04f09 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1580,7 +1580,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in - let (id,bdyopt,typ) = Context.lookup_named id hyps in + let (id,bdyopt,typ) = Context.Named.lookup id hyps in let natureofid = match bdyopt with | None -> "Hypothesis" | Some bdy ->"Constant (let in)" in -- cgit v1.2.3 From a1aff01d16bad2f44392fd5cb804092e12e558ed Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 16:19:51 +0100 Subject: CLEANUP: removing unused field I have removed the second field of the "Constrexpr.CRecord" variant because once it was set to "None" it never changed to anything else. It was just carried and copied around. --- interp/constrexpr_ops.ml | 5 ++--- interp/constrextern.ml | 2 +- interp/constrintern.ml | 2 +- interp/topconstr.ml | 4 ++-- intf/constrexpr.mli | 2 +- parsing/g_constr.ml4 | 5 +---- plugins/funind/indfun.ml | 6 ++---- printing/ppconstr.ml | 12 ++---------- stm/texmacspp.ml | 2 +- tactics/rewrite.ml | 4 ++-- toplevel/classes.ml | 2 +- 11 files changed, 16 insertions(+), 30 deletions(-) diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 161fd1eb1d..a97e8e6db7 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -125,11 +125,10 @@ let rec constr_expr_eq e1 e2 = Option.equal Int.equal proj1 proj2 && constr_expr_eq e1 e2 && List.equal args_eq al1 al2 - | CRecord (_, e1, l1), CRecord (_, e2, l2) -> + | CRecord (_, l1), CRecord (_, l2) -> let field_eq (r1, e1) (r2, e2) = eq_reference r1 r2 && constr_expr_eq e1 e2 in - Option.equal constr_expr_eq e1 e2 && List.equal field_eq l1 l2 | CCases(_,_,r1,a1,brl1), CCases(_,_,r2,a2,brl2) -> (** Don't care about the case_style *) @@ -238,7 +237,7 @@ let constr_loc = function | CLetIn (loc,_,_,_) -> loc | CAppExpl (loc,_,_) -> loc | CApp (loc,_,_) -> loc - | CRecord (loc,_,_) -> loc + | CRecord (loc,_) -> loc | CCases (loc,_,_,_,_) -> loc | CLetTuple (loc,_,_,_,_) -> loc | CIf (loc,_,_,_,_) -> loc diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 5c9e80df3d..af2206d968 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -680,7 +680,7 @@ let rec extern inctx scopes vars r = | head :: tail -> ip q locs' tail ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) in - CRecord (loc, None, List.rev (ip projs locals args [])) + CRecord (loc, List.rev (ip projs locals args [])) with | Not_found | No_match | Exit -> extern_app loc inctx diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 68bc0b1092..c0203b0666 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1479,7 +1479,7 @@ let internalize globalenv env allow_patvar lvar c = apply_impargs c env impargs args_scopes (merge_impargs l args) loc - | CRecord (loc, _, fs) -> + | CRecord (loc, fs) -> let cargs = sort_fields true loc fs (fun k l -> CHole (loc, Some (Evar_kinds.QuestionMark (Evar_kinds.Define true)), Misctypes.IntroAnonymous, None) :: l) diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 15ac46e29e..837630183e 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -116,7 +116,7 @@ let fold_constr_expr_with_binders g f n acc = function | CDelimiters (loc,_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> acc - | CRecord (loc,_,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l + | CRecord (loc,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l | CCases (loc,sty,rtnpo,al,bl) -> let ids = ids_of_cases_tomatch al in let acc = Option.fold_left (f (List.fold_right g ids n)) acc rtnpo in @@ -218,7 +218,7 @@ let map_constr_expr_with_binders g f e = function | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ as x -> x - | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l) + | CRecord (loc,l) -> CRecord (loc,List.map (fun (id, c) -> (id, f e c)) l) | CCases (loc,sty,rtnpo,a,bl) -> (* TODO: apply g on the binding variables in pat... *) let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 8eff327dcd..eaaf2dbb9f 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -75,7 +75,7 @@ type constr_expr = | CAppExpl of Loc.t * (proj_flag * reference * instance_expr option) * constr_expr list | CApp of Loc.t * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list - | CRecord of Loc.t * constr_expr option * (reference * constr_expr) list + | CRecord of Loc.t * (reference * constr_expr) list | CCases of Loc.t * case_style * constr_expr option * case_expr list * branch_expr list | CLetTuple of Loc.t * Name.t located list * (Name.t located option * constr_expr option) * diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 2dec3b222a..440b368b95 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -224,10 +224,7 @@ GEXTEND Gram ] ] ; record_declaration: - [ [ fs = record_fields -> CRecord (!@loc, None, fs) -(* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) -(* CRecord (!@loc, Some c, fs) *) - ] ] + [ [ fs = record_fields -> CRecord (!@loc, fs) ] ] ; record_fields: diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 7815a8f818..d1e1098259 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -752,10 +752,8 @@ let rec add_args id new_args b = | CCast(loc,b1,b2) -> CCast(loc,add_args id new_args b1, Miscops.map_cast_type (add_args id new_args) b2) - | CRecord (loc, w, pars) -> - CRecord (loc, - (match w with Some w -> Some (add_args id new_args w) | _ -> None), - List.map (fun (e,o) -> e, add_args id new_args o) pars) + | CRecord (loc, pars) -> + CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars) | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") | CPrim _ -> b diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index c07057a096..3343997823 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -593,17 +593,9 @@ end) = struct return (p, lproj) | CApp (_,(None,a),l) -> return (pr_app (pr mt) a l, lapp) - | CRecord (_,w,l) -> - let beg = - match w with - | None -> - spc () - | Some t -> - spc () ++ pr spc ltop t ++ spc () - ++ keyword "with" ++ spc () - in + | CRecord (_,l) -> return ( - hv 0 (str"{|" ++ beg ++ + hv 0 (str"{|" ++ spc () ++ prlist_with_sep pr_semicolon (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l ++ str" |}"), diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index b18e35a472..70eccc2403 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -457,7 +457,7 @@ and pp_expr ?(attr=[]) e = (return @ [Element ("scrutinees", [], List.map pp_case_expr cel)] @ [pp_branch_expr_list bel])) - | CRecord (_, _, _) -> assert false + | CRecord (_, _) -> assert false | CLetIn (loc, (varloc, var), value, body) -> xmlApply loc (xmlOperator "let" loc :: diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 2dfebc9a3c..eddefb2799 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1710,7 +1710,7 @@ let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = new_instance (Flags.is_universe_polymorphism ()) - binders instance (Some (true, CRecord (Loc.ghost,None,fields))) + binders instance (Some (true, CRecord (Loc.ghost,fields))) ~global ~generalize:false None let declare_instance_refl global binders a aeq n lemma = @@ -1925,7 +1925,7 @@ let add_morphism glob binders m s n = in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in ignore(new_instance ~global:glob poly binders instance - (Some (true, CRecord (Loc.ghost,None,[]))) + (Some (true, CRecord (Loc.ghost,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) (** Bind to "rewrite" too *) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index ab18350c5c..86b4712326 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -195,7 +195,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro else ( let props = match props with - | Some (true, CRecord (loc, _, fs)) -> + | Some (true, CRecord (loc, fs)) -> if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; Some (Inl fs) -- cgit v1.2.3 From b193c6791c16817047b34f0929b1a9817ec62ee1 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 17:57:30 +0100 Subject: COMMENTS: added to the "Constrexpr.CCases" variant. --- intf/constrexpr.mli | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index eaaf2dbb9f..34dc1c6691 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -76,8 +76,14 @@ type constr_expr = | CApp of Loc.t * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list | CRecord of Loc.t * (reference * constr_expr) list - | CCases of Loc.t * case_style * constr_expr option * - case_expr list * branch_expr list + + (* representation of the "let" and "match" constructs *) + | CCases of Loc.t (* position of the "match" keyword *) + * case_style (* determines whether this value represents "let" or "match" construct *) + * constr_expr option (* return-clause *) + * case_expr list + * branch_expr list (* branches *) + | CLetTuple of Loc.t * Name.t located list * (Name.t located option * constr_expr option) * constr_expr * constr_expr | CIf of Loc.t * constr_expr * (Name.t located option * constr_expr option) @@ -92,8 +98,9 @@ type constr_expr = | CPrim of Loc.t * prim_token | CDelimiters of Loc.t * string * constr_expr -and case_expr = - constr_expr * Name.t located option * cases_pattern_expr option +and case_expr = constr_expr (* expression that is being matched *) + * Name.t located option (* as-clause *) + * cases_pattern_expr option (* in-clause *) and branch_expr = Loc.t * cases_pattern_expr list located list * constr_expr -- cgit v1.2.3 From 51b2581d027528c8e4a347f157baf51a71b9d613 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 16 Dec 2015 16:39:57 +0100 Subject: CLEANUP: removing unnecessary wrapper --- intf/vernacexpr.mli | 6 ++---- stm/stm.mli | 5 +++-- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 3bb86fcb20..f763ba6cf8 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -286,8 +286,8 @@ type module_binder = bool option * lident list * module_ast_inl type vernac_expr = (* Control *) | VernacLoad of verbose_flag * string - | VernacTime of located_vernac_expr - | VernacRedirect of string * located_vernac_expr + | VernacTime of vernac_expr located + | VernacRedirect of string * vernac_expr located | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr | VernacError of exn (* always fails *) @@ -456,8 +456,6 @@ and tacdef_body = | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) -and located_vernac_expr = Loc.t * vernac_expr - (* A vernac classifier has to tell if a command: vernac_when: has to be executed now (alters the parser) or later vernac_type: if it is starts, ends, continues a proof or diff --git a/stm/stm.mli b/stm/stm.mli index 0c05c93d4d..2c9b983ec1 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -9,6 +9,7 @@ open Vernacexpr open Names open Feedback +open Loc (** state-transaction-machine interface *) @@ -19,7 +20,7 @@ open Feedback The sentence [s] is parsed in the state [ontop]. If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) -val add : ontop:Stateid.t -> ?newtip:Stateid.t -> ?check:(located_vernac_expr -> unit) -> +val add : ontop:Stateid.t -> ?newtip:Stateid.t -> ?check:(vernac_expr located -> unit) -> bool -> edit_id -> string -> Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] @@ -123,7 +124,7 @@ val state_of_id : Stateid.t -> [ `Valid of state option | `Expired ] (* Adds a new line to the document. It replaces the core of Vernac.interp. [finish] is called as the last bit of this function is the system is running interactively (-emacs or coqtop). *) -val interp : bool -> located_vernac_expr -> unit +val interp : bool -> vernac_expr located -> unit (* Queries for backward compatibility *) val current_proof_depth : unit -> int -- cgit v1.2.3 From 4dbf44a47949adce5e538a7aacc670ec64c28d3f Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 12 Jan 2016 10:39:49 +0100 Subject: restore documentation of admit --- doc/refman/RefMan-tac.tex | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index d90a027295..11d62b60a3 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -1468,6 +1468,24 @@ a hypothesis or in the body or the type of a local definition. \end{Variants} +\subsection{\tt admit} +\tacindex{admit} +\tacindex{give\_up} +\label{admit} + +The {\tt admit} tactic allows temporarily skipping a subgoal so as to +progress further in the rest of the proof. A proof containing +admitted goals cannot be closed with {\tt Qed} but only with +{\tt Admitted}. + +\begin{Variants} + + \item {\tt give\_up} + + Synonym of {\tt admit}. + +\end{Variants} + \subsection{\tt absurd \term} \tacindex{absurd} \label{absurd} -- cgit v1.2.3 From 682ddc2d278b345c4c72da6c8a8d17cc82a076ec Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 10:46:43 +0100 Subject: Documenting option 'Set Bracketing Last Introduction Pattern'. --- doc/refman/RefMan-tac.tex | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 11d62b60a3..ce934871f3 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -864,16 +864,17 @@ introduction pattern~$p$: expects the product to be over an inductive type whose number of constructors is $n$ (or more generally over a type of conclusion an inductive type built from $n$ constructors, - e.g. {\tt C -> A\textbackslash/B if $n=2$}): it destructs the introduced + e.g. {\tt C -> A\textbackslash/B} with $n=2$ since {\tt + A\textbackslash/B} has 2 constructors): it destructs the introduced hypothesis as {\tt destruct} (see Section~\ref{destruct}) would and applies on each generated subgoal the corresponding tactic; \texttt{intros}~$p_{i1}$ {\ldots} $p_{im_i}$; if the disjunctive - pattern is part of a sequence of patterns and is not the last - pattern of the sequence, then {\Coq} completes the pattern so that all - the argument of the constructors of the inductive type are - introduced (for instance, the list of patterns {\tt [$\;$|$\;$] H} - applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same as - the list of patterns {\tt [$\,$|$\,$?$\,$] H}); + pattern is part of a sequence of patterns, then {\Coq} completes the + pattern so that all the arguments of the constructors of the + inductive type are introduced (for instance, the list of patterns + {\tt [$\;$|$\;$] H} applied on goal {\tt forall x:nat, x=0 -> 0=x} + behaves the same as the list of patterns {\tt [$\,$|$\,$?$\,$] H}, + up to one exception explained in the Remark below); \item introduction over a conjunction of patterns {\tt ($p_1$, \ldots, $p_n$)} expects the goal to be a product over an inductive type $I$ with a single constructor that itself has at least $n$ arguments: it @@ -887,10 +888,10 @@ introduction pattern~$p$: {\tt ($p_1$,(\ldots,(\dots,$p_n$)\ldots))}; it expects the hypothesis to be a sequence of right-associative binary inductive constructors such as {\tt conj} or {\tt ex\_intro}; for instance, an - hypothesis with type {\tt A\verb|/\|exists x, B\verb|/\|C\verb|/\|D} can be + hypothesis with type {\tt A\verb|/\|(exists x, B\verb|/\|C\verb|/\|D)} can be introduced via pattern {\tt (a \& x \& b \& c \& d)}; \item if the product is over an equality type, then a pattern of the - form {\tt [=$p_{1}$ \dots\ $p_n$]} applies either {\tt injection} + form {\tt [= $p_{1}$ \dots\ $p_n$]} applies either {\tt injection} (see Section~\ref{injection}) or {\tt discriminate} (see Section~\ref{discriminate}) instead of {\tt destruct}; if {\tt injection} is applicable, the patterns $p_1$, \ldots, $p_n$ are @@ -950,6 +951,7 @@ Abort. \Rem {\tt intros $p_1~\ldots~p_n$} is not fully equivalent to \texttt{intros $p_1$;\ldots; intros $p_n$} for the following reasons: +\label{bracketing-last} \begin{itemize} \item A wildcard pattern never succeeds when applied isolated on a dependent product, while it succeeds as part of a list of @@ -971,6 +973,13 @@ Show 2. \end{itemize} +This later behavior can be avoided by setting the following option: + +\begin{quote} +\optindex{Bracketing Last Introduction Pattern} +{\tt Set Bracketing Last Introduction Pattern} +\end{quote} + \subsection{\tt clear \ident} \tacindex{clear} \label{clear} -- cgit v1.2.3 From f5de32ad1600cd18a6f1f286729c979e868ad088 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 11:32:54 +0100 Subject: Documenting options "Intuition Negation Unfolding", "Intuition Iff Unfolding". --- doc/refman/RefMan-tac.tex | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index ce934871f3..b07cfb7d59 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -4233,6 +4233,38 @@ incompatibilities. Is equivalent to {\tt intuition auto with *}. \end{Variants} +\optindex{Intuition Negation Unfolding} +\optindex{Intuition Iff Unfolding} + +Some aspects of the tactic {\tt intuition} can be +controlled using options. To avoid that inner negations which do not +need to be unfolded are unfolded, use: + +\begin{quote} +{\tt Unset Intuition Negation Unfolding} +\end{quote} + +To do that all negations of the goal are unfolded even inner ones +(this is the default), use: + +\begin{quote} +{\tt Set Intuition Negation Unfolding} +\end{quote} + +To avoid that inner occurrence of {\tt iff} which do not need to be +unfolded are unfolded (this is the default), use: + +\begin{quote} +{\tt Unset Intuition Iff Unfolding} +\end{quote} + +To do that all negations of the goal are unfolded even inner ones +(this is the default), use: + +\begin{quote} +{\tt Set Intuition Iff Unfolding} +\end{quote} + % En attente d'un moyen de valoriser les fichiers de demos %\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_tauto.v} -- cgit v1.2.3 From e21e8c2804d047d4b80613e31bec0bc7320b7e8b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 11:48:45 +0100 Subject: Documenting dtauto and dintuition. --- doc/refman/RefMan-tac.tex | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index b07cfb7d59..b3a730e675 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -4149,6 +4149,7 @@ The tactic {\tt exists (n // m)} did not fail. The hole was solved by \subsection{\tt tauto} \tacindex{tauto} +\tacindex{dtauto} \label{tauto} This tactic implements a decision procedure for intuitionistic propositional @@ -4197,8 +4198,21 @@ Abort. because \verb=(forall x:nat, ~ A -> P x)= cannot be treated as atomic and an instantiation of \verb=x= is necessary. +\begin{Variants} + +\item {\tt dtauto} + + While {\tt tauto} recognizes inductively defined connectives + isomorphic to the standard connective {\tt and}, {\tt prod}, {\tt + or}, {\tt sum}, {\tt False}, {\tt Empty\_set}, {\tt unit}, {\tt + True}, {\tt dtauto} recognizes also all inductive types with + one constructors and no indices, i.e. record-style connectives. + +\end{Variants} + \subsection{\tt intuition \tac} \tacindex{intuition} +\tacindex{dintuition} \label{intuition} The tactic \texttt{intuition} takes advantage of the search-tree built @@ -4231,6 +4245,15 @@ incompatibilities. \item {\tt intuition} Is equivalent to {\tt intuition auto with *}. + +\item {\tt dintuition} + + While {\tt intuition} recognizes inductively defined connectives + isomorphic to the standard connective {\tt and}, {\tt prod}, {\tt + or}, {\tt sum}, {\tt False}, {\tt Empty\_set}, {\tt unit}, {\tt + True}, {\tt dintuition} recognizes also all inductive types with + one constructors and no indices, i.e. record-style connectives. + \end{Variants} \optindex{Intuition Negation Unfolding} -- cgit v1.2.3 From 94b3068c688b289ec26005d13251fc1c3dae6998 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 12:14:41 +0100 Subject: Referring to coq.inria.fr/stdlib for more on libraries and ltac-level tactics. --- doc/refman/RefMan-lib.tex | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/doc/refman/RefMan-lib.tex b/doc/refman/RefMan-lib.tex index 7227f4b7b6..4ebb484e7c 100644 --- a/doc/refman/RefMan-lib.tex +++ b/doc/refman/RefMan-lib.tex @@ -17,10 +17,11 @@ The \Coq\ library is structured into two parts: In addition, user-provided libraries or developments are provided by \Coq\ users' community. These libraries and developments are available -for download at \texttt{http://coq.inria.fr} (see +for download at \url{http://coq.inria.fr} (see Section~\ref{Contributions}). -The chapter briefly reviews the \Coq\ libraries. +The chapter briefly reviews the \Coq\ libraries whose contents can +also be browsed at \url{http://coq.inria.fr/stdlib}. \section[The basic library]{The basic library\label{Prelude}} @@ -799,7 +800,9 @@ At the end, it defines data-types at the {\Type} level. \subsection{Tactics} A few tactics defined at the user level are provided in the initial -state\footnote{This is in module {\tt Tactics.v}}. +state\footnote{This is in module {\tt Tactics.v}}. They are listed at +\url{http://coq.inria.fr/stdlib} (paragraph {\tt Init}, link {\tt + Tactics}). \section{The standard library} @@ -842,7 +845,7 @@ Chapter~\ref{Other-commands}). The different modules of the \Coq\ standard library are described in the additional document \verb!Library.dvi!. They are also accessible on the WWW through the \Coq\ homepage -\footnote{\texttt{http://coq.inria.fr}}. +\footnote{\url{http://coq.inria.fr}}. \subsection[Notations for integer arithmetics]{Notations for integer arithmetics\index{Arithmetical notations}} @@ -1035,7 +1038,7 @@ intros; split_Rmult. \end{itemize} -All this tactics has been written with the tactic language Ltac +These tactics has been written with the tactic language Ltac described in Chapter~\ref{TacticLanguage}. \begin{coq_eval} -- cgit v1.2.3 From 4841b790bbe517deefac11e8df1a7a1494d56bec Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 12 Jan 2016 17:02:09 +0100 Subject: Fix essential bug in new Keyed Unification mode reported by R. Krebbers. [rewrite] was calling find_suterm using the wrong unification flags, not allowing full delta in unification of terms with the right keys as desired. --- pretyping/unification.ml | 2 ++ pretyping/unification.mli | 2 ++ tactics/equality.ml | 40 +++++++++++++++++++++++++++++++++++++++- 3 files changed, 43 insertions(+), 1 deletion(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 9758aa43c4..510d5761b7 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -37,6 +37,8 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> keyed_unification:=a); } +let is_keyed_unification () = !keyed_unification + let debug_unification = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 119b1a7590..9246c10f90 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -42,6 +42,8 @@ val default_no_delta_unify_flags : unit -> unify_flags val elim_flags : unit -> unify_flags val elim_no_delta_flags : unit -> unify_flags +val is_keyed_unification : unit -> bool + (** The "unique" unification fonction *) val w_unify : env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map diff --git a/tactics/equality.ml b/tactics/equality.ml index fe0ca61c66..ccb0425f4a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -205,9 +205,47 @@ let rewrite_conv_closed_unif_flags = { resolve_evars = false } +let rewrite_keyed_core_unif_flags = { + modulo_conv_on_closed_terms = Some full_transparent_state; + (* We have this flag for historical reasons, it has e.g. the consequence *) + (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) + + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) + (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) + + modulo_delta = full_transparent_state; + modulo_delta_types = full_transparent_state; + check_applied_meta_types = true; + use_pattern_unification = true; + (* To rewrite "?n x y" in "y+x=0" when ?n is *) + (* a preexisting evar of the goal*) + + use_meta_bound_pattern_unification = true; + + frozen_evars = Evar.Set.empty; + (* This is set dynamically *) + + restrict_conv_on_strict_subterms = false; + modulo_betaiota = true; + (* Different from conv_closed *) + modulo_eta = true; +} + +let rewrite_keyed_unif_flags = { + core_unify_flags = rewrite_keyed_core_unif_flags; + merge_unify_flags = rewrite_keyed_core_unif_flags; + subterm_unify_flags = rewrite_keyed_core_unif_flags; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + let rewrite_elim with_evars frzevars cls c e = Proofview.Goal.enter begin fun gl -> - let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in + let flags = if Unification.is_keyed_unification () + then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in + let flags = make_flags frzevars (Proofview.Goal.sigma gl) flags c in general_elim_clause with_evars flags cls c e end -- cgit v1.2.3 From eb40037b4c341746933c713e8950f3a60d550f4a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 12 Jan 2016 17:32:04 +0100 Subject: Extend Keyed Unification tests with the one from R. Krebbers. --- test-suite/success/keyedrewrite.v | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index bbe9d4bfff..d1a93581ca 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -22,3 +22,34 @@ Qed. Print Equivalent Keys. End foo. + +Require Import Arith List Omega. + +Definition G {A} (f : A -> A -> A) (x : A) := f x x. + +Lemma list_foo A (l : list A) : G (@app A) (l ++ nil) = G (@app A) l. +Proof. unfold G; rewrite app_nil_r; reflexivity. Qed. + +(* Bundled version of a magma *) +Structure magma := Magma { b_car :> Type; op : b_car -> b_car -> b_car }. +Arguments op {_} _ _. + +(* Instance for lists *) +Canonical Structure list_magma A := Magma (list A) (@app A). + +(* Basically like list_foo, but now uses the op projection instead of app for +the argument of G *) +Lemma test1 A (l : list A) : G op (l ++ nil) = G op l. + +(* Ensure that conversion of terms with evars is allowed once a keyed candidate unifier is found *) +rewrite -> list_foo. +reflexivity. +Qed. + +(* Basically like list_foo, but now uses the op projection for everything *) +Lemma test2 A (l : list A) : G op (op l nil) = G op l. +Proof. +rewrite ->list_foo. +reflexivity. +Qed. + -- cgit v1.2.3 From fc642ca962dd5228a5a714b8e41506dcbc3b6520 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 12 Jan 2016 19:27:02 +0100 Subject: Extend last commit: keyed unification uses full conversions on the applied constant and arguments _separately_. --- pretyping/unification.ml | 9 +++++++-- test-suite/success/keyedrewrite.v | 6 ++++++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 510d5761b7..48638474a8 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1649,8 +1649,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let cl = strip_outer_cast cl in (try if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then - (try w_typed_unify env evd CONV flags op cl,cl - with ex when Pretype_errors.unsatisfiable_exception ex -> + (try + if !keyed_unification then + let f1, l1 = decompose_app_vect op in + let f2, l2 = decompose_app_vect cl in + w_typed_unify_array env evd flags f1 l1 f2 l2,cl + else w_typed_unify env evd CONV flags op cl,cl + with ex when Pretype_errors.unsatisfiable_exception ex -> bestexn := Some ex; error "Unsat") else error "Bound 1" with ex when precatchable_exception ex -> diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index d1a93581ca..5b0502cf1a 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -53,3 +53,9 @@ rewrite ->list_foo. reflexivity. Qed. + Require Import Bool. + Set Keyed Unification. + + Lemma test b : b && true = b. + Fail rewrite andb_true_l. + Admitted. \ No newline at end of file -- cgit v1.2.3 From 74d89e0be05e5cb4c9faf154478bc0c907bec2bb Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 15 Dec 2015 20:14:07 +0100 Subject: Reporting about the new tactical unshelve. --- CHANGES | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/CHANGES b/CHANGES index b30bcc662d..531d5049fd 100644 --- a/CHANGES +++ b/CHANGES @@ -22,9 +22,11 @@ Tactics introducing along pattern p changed to p%c1..%cn. The feature and syntax are in experimental stage. - "Proof using" does not clear unused section variables. -- "refine" has been changed back to the 8.4 behavior of shelving subgoals - that occur in other subgoals. The "refine" tactic of 8.5beta2 has been +- Tactic "refine" has been changed back to the 8.4 behavior of shelving subgoals + that occur in other subgoals. The "refine" tactic of 8.5beta3 has been renamed "simple refine"; it does not shelve any subgoal. +- New tactical "unshelve tac" which grab existential variables put on + the tactic shelve by the execution of "tac". Changes from V8.5beta2 to V8.5beta3 =================================== @@ -495,11 +497,9 @@ Interfaces documentation of OCaml's Str module for the supported syntax. - Many CoqIDE windows, including the query one, are now detachable to improve usability on multi screen work stations. - - Coqtop/coqc outputs highlighted syntax. Colors can be configured thanks to the COQ_COLORS environment variable, and their current state can be displayed with the -list-tags command line option. - - Third party user interfaces can install their main loop in $COQLIB/toploop and call coqtop with the -toploop flag to select it. -- cgit v1.2.3 From be4bfc78c493464cb0af40d7fae08ba86295a6f9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 20:49:34 +0100 Subject: Fixing #4256 and #4484 (changes in evar-evar resolution made that new evars were created making in turn that evars formerly recognized as pending were not anymore in the list of pending evars). This also fixes the reopening of #3848. See comments on #4484 for details. --- pretyping/pretyping.ml | 30 ++++++++++++++++++------------ test-suite/bugs/closed/3848.v | 22 ++++++++++++++++++++++ test-suite/bugs/closed/4256.v | 43 +++++++++++++++++++++++++++++++++++++++++++ test-suite/bugs/closed/4484.v | 10 ++++++++++ test-suite/bugs/opened/3848.v | 22 ---------------------- 5 files changed, 93 insertions(+), 34 deletions(-) create mode 100644 test-suite/bugs/closed/3848.v create mode 100644 test-suite/bugs/closed/4256.v create mode 100644 test-suite/bugs/closed/4484.v delete mode 100644 test-suite/bugs/opened/3848.v diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index faba5c7563..521fa2247b 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -183,22 +183,26 @@ type inference_flags = { expand_evars : bool } +let frozen_holes (sigma, sigma') = + let fold evk _ accu = Evar.Set.add evk accu in + Evd.fold_undefined fold sigma Evar.Set.empty + let pending_holes (sigma, sigma') = let fold evk _ accu = if not (Evd.mem sigma evk) then Evar.Set.add evk accu else accu in Evd.fold_undefined fold sigma' Evar.Set.empty -let apply_typeclasses env evdref pending fail_evar = - let filter_pending evk = Evar.Set.mem evk pending in +let apply_typeclasses env evdref frozen fail_evar = + let filter_frozen evk = Evar.Set.mem evk frozen in evdref := Typeclasses.resolve_typeclasses ~filter:(if Flags.is_program_mode () - then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && filter_pending evk) - else (fun evk evi -> Typeclasses.no_goals evk evi && filter_pending evk)) + then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) + else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk))) ~split:true ~fail:fail_evar env !evdref; if Flags.is_program_mode () then (* Try optionally solving the obligations *) evdref := Typeclasses.resolve_typeclasses - ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && filter_pending evk) ~split:true ~fail:false env !evdref + ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env !evdref let apply_inference_hook hook evdref pending = evdref := Evar.Set.fold (fun evk sigma -> @@ -219,9 +223,9 @@ let apply_heuristics env evdref fail_evar = with e when Errors.noncritical e -> let e = Errors.push e in if fail_evar then iraise e -let check_typeclasses_instances_are_solved env current_sigma pending = +let check_typeclasses_instances_are_solved env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses env (ref current_sigma) pending true + apply_typeclasses env (ref current_sigma) frozen true let check_extra_evars_are_solved env current_sigma pending = Evar.Set.iter @@ -233,26 +237,28 @@ let check_extra_evars_are_solved env current_sigma pending = | _ -> error_unsolvable_implicit loc env current_sigma evk None) pending -let check_evars_are_solved env current_sigma pending = - check_typeclasses_instances_are_solved env current_sigma pending; +let check_evars_are_solved env current_sigma frozen pending = + check_typeclasses_instances_are_solved env current_sigma frozen; check_problems_are_solved env current_sigma; check_extra_evars_are_solved env current_sigma pending (* Try typeclasses, hooks, unification heuristics ... *) let solve_remaining_evars flags env current_sigma pending = + let frozen = frozen_holes pending in let pending = pending_holes pending in let evdref = ref current_sigma in - if flags.use_typeclasses then apply_typeclasses env evdref pending false; + if flags.use_typeclasses then apply_typeclasses env evdref frozen false; if Option.has_some flags.use_hook then apply_inference_hook (Option.get flags.use_hook env) evdref pending; if flags.use_unif_heuristics then apply_heuristics env evdref false; - if flags.fail_evar then check_evars_are_solved env !evdref pending; + if flags.fail_evar then check_evars_are_solved env !evdref frozen pending; !evdref let check_evars_are_solved env current_sigma pending = + let frozen = frozen_holes pending in let pending = pending_holes pending in - check_evars_are_solved env current_sigma pending + check_evars_are_solved env current_sigma frozen pending let process_inference_flags flags env initial_sigma (sigma,c) = let sigma = solve_remaining_evars flags env sigma (initial_sigma, sigma) in diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v new file mode 100644 index 0000000000..a03e8ffdab --- /dev/null +++ b/test-suite/bugs/closed/3848.v @@ -0,0 +1,22 @@ +Require Import TestSuite.admit. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Arguments eisretr {A B} f {_} _. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Generalizable Variables A B f g e n. +Definition functor_forall `{P : A -> Type} `{Q : B -> Type} + (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) +: (forall a:A, P a) -> (forall b:B, Q b). + admit. +Defined. + +Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} + `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} +: (forall b : B, Q b) -> forall a : A, P a. +Proof. + refine (functor_forall + (f^-1) + (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). +Fail Defined. (* Error: Attempt to save an incomplete proof *) diff --git a/test-suite/bugs/closed/4256.v b/test-suite/bugs/closed/4256.v new file mode 100644 index 0000000000..3cdc4ada02 --- /dev/null +++ b/test-suite/bugs/closed/4256.v @@ -0,0 +1,43 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Global Set Universe Polymorphism. +Monomorphic Universe i. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. +Notation "-1" := (trunc_S minus_two) (at level 0). + +Class IsPointed (A : Type) := point : A. +Arguments point A {_}. + +Record pType := + { pointed_type : Type ; + ispointed_type : IsPointed pointed_type }. +Coercion pointed_type : pType >-> Sortclass. +Existing Instance ispointed_type. + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + + + +Record ooGroup := + { classifying_space : pType@{i} }. + +Definition group_loops (X : pType) +: ooGroup. +Proof. + (** This works: *) + pose (x0 := point X). + pose (H := existT (fun x:X => Trunc -1 (x = point X)) x0 (tr idpath)). + clear H x0. + (** But this doesn't: *) + pose (existT (fun x:X => Trunc -1 (x = point X)) (point X) (tr idpath)). diff --git a/test-suite/bugs/closed/4484.v b/test-suite/bugs/closed/4484.v new file mode 100644 index 0000000000..f988539d62 --- /dev/null +++ b/test-suite/bugs/closed/4484.v @@ -0,0 +1,10 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Class A := {}. +Axiom foo : forall {ac : A}, bool. +Lemma bar (ac : A) : True. +Check (match foo as k return foo = k -> True with + | true => _ + | false => _ + end eq_refl). diff --git a/test-suite/bugs/opened/3848.v b/test-suite/bugs/opened/3848.v deleted file mode 100644 index a03e8ffdab..0000000000 --- a/test-suite/bugs/opened/3848.v +++ /dev/null @@ -1,22 +0,0 @@ -Require Import TestSuite.admit. -Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. -Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). -Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. -Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. -Arguments eisretr {A B} f {_} _. -Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). -Generalizable Variables A B f g e n. -Definition functor_forall `{P : A -> Type} `{Q : B -> Type} - (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) -: (forall a:A, P a) -> (forall b:B, Q b). - admit. -Defined. - -Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} - `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} -: (forall b : B, Q b) -> forall a : A, P a. -Proof. - refine (functor_forall - (f^-1) - (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). -Fail Defined. (* Error: Attempt to save an incomplete proof *) -- cgit v1.2.3 From 9f8ae1aa2678944888d80ce0867bfb2bba0c8c71 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 22:12:40 +0100 Subject: Fixing #4467 (missing shadowing of variables in cases pattern). This fixes a TODO in map_constr_expr_with_binders, a bug in is_constructor, as well as a bug and TODOS in ids_of_cases_indtype. --- interp/topconstr.ml | 40 +++++++++++++++++----------------------- test-suite/bugs/closed/4467.v | 15 +++++++++++++++ 2 files changed, 32 insertions(+), 23 deletions(-) create mode 100644 test-suite/bugs/closed/4467.v diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 1231f11555..560cd0277b 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -38,27 +38,9 @@ let error_invalid_pattern_notation loc = (**********************************************************************) (* Functions on constr_expr *) -let ids_of_cases_indtype = - let rec vars_of ids = function - (* We deal only with the regular cases *) - | (CPatCstr (_,_,l1,l2)|CPatNotation (_,_,(l1,[]),l2)) -> - List.fold_left vars_of (List.fold_left vars_of [] l2) l1 - (* assume the ntn is applicative and does not instantiate the head !! *) - | CPatDelimiters(_,_,c) -> vars_of ids c - | CPatAtom (_, Some (Libnames.Ident (_, x))) -> x::ids - | _ -> ids in - vars_of [] - -let ids_of_cases_tomatch tms = - List.fold_right - (fun (_,(ona,indnal)) l -> - Option.fold_right (fun t -> (@) (ids_of_cases_indtype t)) - indnal (Option.fold_right (Loc.down_located name_cons) ona l)) - tms [] - let is_constructor id = try ignore (Nametab.locate_extended (qualid_of_ident id)); true - with Not_found -> true + with Not_found -> false let rec cases_pattern_fold_names f a = function | CPatRecord (_, l) -> @@ -82,6 +64,17 @@ let ids_of_pattern_list = (List.fold_left (cases_pattern_fold_names Id.Set.add))) Id.Set.empty +let ids_of_cases_indtype p = + Id.Set.elements (cases_pattern_fold_names Id.Set.add Id.Set.empty p) + +let ids_of_cases_tomatch tms = + List.fold_right + (fun (_,(ona,indnal)) l -> + Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) + indnal + (Option.fold_right (Loc.down_located (name_fold Id.Set.add)) ona l)) + tms Id.Set.empty + let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> let nal = snd (List.split nal) in @@ -119,7 +112,7 @@ let fold_constr_expr_with_binders g f n acc = function | CRecord (loc,_,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l | CCases (loc,sty,rtnpo,al,bl) -> let ids = ids_of_cases_tomatch al in - let acc = Option.fold_left (f (List.fold_right g ids n)) acc rtnpo in + let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in let acc = List.fold_left (f n) acc (List.map fst al) in List.fold_right (fun (loc,patl,rhs) acc -> let ids = ids_of_pattern_list patl in @@ -220,10 +213,11 @@ let map_constr_expr_with_binders g f e = function | CPrim _ | CRef _ as x -> x | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l) | CCases (loc,sty,rtnpo,a,bl) -> - (* TODO: apply g on the binding variables in pat... *) - let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in + let bl = List.map (fun (loc,patl,rhs) -> + let ids = ids_of_pattern_list patl in + (loc,patl,f (Id.Set.fold g ids e) rhs)) bl in let ids = ids_of_cases_tomatch a in - let po = Option.map (f (List.fold_right g ids e)) rtnpo in + let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl) | CLetTuple (loc,nal,(ona,po),b,c) -> let e' = List.fold_right (Loc.down_located (name_fold g)) nal e in diff --git a/test-suite/bugs/closed/4467.v b/test-suite/bugs/closed/4467.v new file mode 100644 index 0000000000..6f8631d458 --- /dev/null +++ b/test-suite/bugs/closed/4467.v @@ -0,0 +1,15 @@ +(* Fixing missing test for variable shadowing *) + +Definition test (x y:bool*bool) := + match x with + | (e as e1, (true) as e2) + | ((true) as e1, e as e2) => + let '(e, b) := y in + e + | _ => true + end. + +Goal test (true,false) (true,true) = true. +(* used to evaluate to "false = true" in 8.4 *) +reflexivity. +Qed. -- cgit v1.2.3 From 2d568a895d5c8a246f497c94c79811d3aad4269f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 13 Jan 2016 00:20:46 +0100 Subject: Fixing #4467 (continued). Function is_constructor was not properly fixed. Additionally, this fixes a problem with the 8.5 interpretation of in-pattern (see Cases.v). --- dev/printers.mllib | 6 +++--- interp/interp.mllib | 2 +- interp/topconstr.ml | 4 +++- test-suite/success/Cases.v | 7 +++++++ 4 files changed, 14 insertions(+), 5 deletions(-) diff --git a/dev/printers.mllib b/dev/printers.mllib index eeca6809ae..ab7e9fc346 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -160,14 +160,14 @@ Constrarg Constrexpr_ops Genintern Notation_ops -Topconstr Notation Dumpglob +Syntax_def +Smartlocate +Topconstr Reserve Impargs -Syntax_def Implicit_quantifiers -Smartlocate Constrintern Modintern Constrextern diff --git a/interp/interp.mllib b/interp/interp.mllib index c9a0315267..96b52959a0 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -3,12 +3,12 @@ Constrarg Genintern Constrexpr_ops Notation_ops -Topconstr Ppextend Notation Dumpglob Syntax_def Smartlocate +Topconstr Reserve Impargs Implicit_quantifiers diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 560cd0277b..2cb2449b7d 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -39,7 +39,9 @@ let error_invalid_pattern_notation loc = (* Functions on constr_expr *) let is_constructor id = - try ignore (Nametab.locate_extended (qualid_of_ident id)); true + try Globnames.isConstructRef + (Smartlocate.global_of_extended_global + (Nametab.locate_extended (qualid_of_ident id))) with Not_found -> false let rec cases_pattern_fold_names f a = function diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index e42663505d..49c465b6c6 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1861,3 +1861,10 @@ Type (fun n => match n with Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := match p with eq_refl => u end. + +(* Check in-pattern clauses with constant constructors, which were + previously interpreted as variables (before 8.5) *) + +Check match eq_refl 0 in _=O return O=O with eq_refl => eq_refl end. + +Check match niln in listn O return O=O with niln => eq_refl end. -- cgit v1.2.3 From 245affffb174fb26fc9a847abe44e01b107980a8 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 13 Jan 2016 00:48:37 +0100 Subject: Fixing success of test for #3848 after move to directory "closed". --- test-suite/bugs/closed/3848.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v index a03e8ffdab..c0ef02f1e8 100644 --- a/test-suite/bugs/closed/3848.v +++ b/test-suite/bugs/closed/3848.v @@ -19,4 +19,4 @@ Proof. refine (functor_forall (f^-1) (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). -Fail Defined. (* Error: Attempt to save an incomplete proof *) +Defined. (* was: Error: Attempt to save an incomplete proof *) -- cgit v1.2.3 From 4b4a4b6b41e6b303d556638ed2a79b1493b1ecf4 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 13 Jan 2016 17:38:27 +0100 Subject: MMaps: remove it from final 8.5 release, since this new library isn't mature enough In particular, its interface might still change (in interaction with interested colleagues). So let's not give it too much visibility yet. Instead, I'll turn it as an opam packages for now. --- Makefile.build | 1 - Makefile.common | 3 +- doc/stdlib/index-list.html.template | 7 - theories/MMaps/MMapAVL.v | 2158 ----------------------------- theories/MMaps/MMapFacts.v | 2434 --------------------------------- theories/MMaps/MMapInterface.v | 292 ---- theories/MMaps/MMapList.v | 1144 ---------------- theories/MMaps/MMapPositive.v | 698 ---------- theories/MMaps/MMapWeakList.v | 687 ---------- theories/MMaps/MMaps.v | 16 - theories/MMaps/vo.itarget | 7 - theories/Structures/EqualitiesFacts.v | 2 +- theories/Structures/OrdersEx.v | 2 +- theories/Structures/OrdersLists.v | 2 +- theories/theories.itarget | 1 - 15 files changed, 4 insertions(+), 7450 deletions(-) delete mode 100644 theories/MMaps/MMapAVL.v delete mode 100644 theories/MMaps/MMapFacts.v delete mode 100644 theories/MMaps/MMapInterface.v delete mode 100644 theories/MMaps/MMapList.v delete mode 100644 theories/MMaps/MMapPositive.v delete mode 100644 theories/MMaps/MMapWeakList.v delete mode 100644 theories/MMaps/MMaps.v delete mode 100644 theories/MMaps/vo.itarget diff --git a/Makefile.build b/Makefile.build index d9090197a2..032f465082 100644 --- a/Makefile.build +++ b/Makefile.build @@ -555,7 +555,6 @@ program: $(PROGRAMVO) structures: $(STRUCTURESVO) vectors: $(VECTORSVO) msets: $(MSETSVO) -mmaps: $(MMAPSVO) compat: $(COMPATVO) noreal: unicode logic arith bool zarith qarith lists sets fsets \ diff --git a/Makefile.common b/Makefile.common index 92a48cd6cc..1a903539c2 100644 --- a/Makefile.common +++ b/Makefile.common @@ -293,7 +293,6 @@ STRINGSVO:=$(call cat_vo_itarget, theories/Strings) SETSVO:=$(call cat_vo_itarget, theories/Sets) FSETSVO:=$(call cat_vo_itarget, theories/FSets) MSETSVO:=$(call cat_vo_itarget, theories/MSets) -MMAPSVO:=$(call cat_vo_itarget, theories/MMaps) RELATIONSVO:=$(call cat_vo_itarget, theories/Relations) WELLFOUNDEDVO:=$(call cat_vo_itarget, theories/Wellfounded) REALSVO:=$(call cat_vo_itarget, theories/Reals) @@ -310,7 +309,7 @@ THEORIESVO:=\ $(RELATIONSVO) $(WELLFOUNDEDVO) $(SETOIDSVO) \ $(LISTSVO) $(STRINGSVO) \ $(PARITHVO) $(NARITHVO) $(ZARITHVO) \ - $(SETSVO) $(FSETSVO) $(MSETSVO) $(MMAPSVO) \ + $(SETSVO) $(FSETSVO) $(MSETSVO) \ $(REALSVO) $(SORTINGVO) $(QARITHVO) \ $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) \ $(COMPATVO) diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 292b2b36cc..d6b1af797f 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -476,13 +476,6 @@ through the Require Import command.

theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v) - theories/MMaps/MMapAVL.v - theories/MMaps/MMapFacts.v - theories/MMaps/MMapInterface.v - theories/MMaps/MMapList.v - theories/MMaps/MMapPositive.v - theories/MMaps/MMapWeakList.v - (theories/MMaps/MMaps.v)
FSets: diff --git a/theories/MMaps/MMapAVL.v b/theories/MMaps/MMapAVL.v deleted file mode 100644 index d840f1f32c..0000000000 --- a/theories/MMaps/MMapAVL.v +++ /dev/null @@ -1,2158 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* key -> elt -> tree -> int -> tree. - -Notation t := tree. - -(** * Basic functions on trees: height and cardinal *) - -Definition height (m : t) : int := - match m with - | Leaf => 0 - | Node _ _ _ _ h => h - end. - -Fixpoint cardinal (m : t) : nat := - match m with - | Leaf => 0%nat - | Node l _ _ r _ => S (cardinal l + cardinal r) - end. - -(** * Empty Map *) - -Definition empty := Leaf. - -(** * Emptyness test *) - -Definition is_empty m := match m with Leaf => true | _ => false end. - -(** * Membership *) - -(** The [mem] function is deciding membership. It exploits the [Bst] property - to achieve logarithmic complexity. *) - -Fixpoint mem x m : bool := - match m with - | Leaf => false - | Node l y _ r _ => - match X.compare x y with - | Eq => true - | Lt => mem x l - | Gt => mem x r - end - end. - -Fixpoint find x m : option elt := - match m with - | Leaf => None - | Node l y d r _ => - match X.compare x y with - | Eq => Some d - | Lt => find x l - | Gt => find x r - end - end. - -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x e r := - Node l x e r (max (height l) (height r) + 1). - -(** [bal l x e r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition assert_false := create. - -Fixpoint bal l x d r := - let hl := height l in - let hr := height r in - if (hr+2) assert_false l x d r - | Node ll lx ld lr _ => - if (height lr) <=? (height ll) then - create ll lx ld (create lr x d r) - else - match lr with - | Leaf => assert_false l x d r - | Node lrl lrx lrd lrr _ => - create (create ll lx ld lrl) lrx lrd (create lrr x d r) - end - end - else - if (hl+2) assert_false l x d r - | Node rl rx rd rr _ => - if (height rl) <=? (height rr) then - create (create l x d rl) rx rd rr - else - match rl with - | Leaf => assert_false l x d r - | Node rll rlx rld rlr _ => - create (create l x d rll) rlx rld (create rlr rx rd rr) - end - end - else - create l x d r. - -(** * Insertion *) - -Fixpoint add x d m := - match m with - | Leaf => Node Leaf x d Leaf 1 - | Node l y d' r h => - match X.compare x y with - | Eq => Node l y d r h - | Lt => bal (add x d l) y d' r - | Gt => bal l y d' (add x d r) - end - end. - -(** * Extraction of minimum binding - - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x e r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Fixpoint remove_min l x d r : t*(key*elt) := - match l with - | Leaf => (r,(x,d)) - | Node ll lx ld lr lh => - let (l',m) := remove_min ll lx ld lr in - (bal l' x d r, m) - end. - -(** * Merging two trees - - [merge0 t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Definition merge0 s1 s2 := - match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 d2 r2 h2 => - let '(s2',(x,d)) := remove_min l2 x2 d2 r2 in - bal s1 x d s2' - end. - -(** * Deletion *) - -Fixpoint remove x m := match m with - | Leaf => Leaf - | Node l y d r h => - match X.compare x y with - | Eq => merge0 l r - | Lt => bal (remove x l) y d r - | Gt => bal l y d (remove x r) - end - end. - -(** * join - - Same as [bal] but does not assume anything regarding heights of [l] - and [r]. -*) - -Fixpoint join l : key -> elt -> t -> t := - match l with - | Leaf => add - | Node ll lx ld lr lh => fun x d => - fix join_aux (r:t) : t := match r with - | Leaf => add x d l - | Node rl rx rd rr rh => - if rh+2 x] - - [o] is the result of [find x m]. -*) - -Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. -Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). - -Fixpoint split x m : triple := match m with - | Leaf => 〚 Leaf, None, Leaf 〛 - | Node l y d r h => - match X.compare x y with - | Lt => let (ll,o,rl) := split x l in 〚 ll, o, join rl y d r 〛 - | Eq => 〚 l, Some d, r 〛 - | Gt => let (rl,o,rr) := split x r in 〚 join l y d rl, o, rr 〛 - end - end. - -(** * Concatenation - - Same as [merge] but does not assume anything about heights. -*) - -Definition concat m1 m2 := - match m1, m2 with - | Leaf, _ => m2 - | _ , Leaf => m1 - | _, Node l2 x2 d2 r2 _ => - let (m2',xd) := remove_min l2 x2 d2 r2 in - join m1 xd#1 xd#2 m2' - end. - -(** * Bindings *) - -(** [bindings_aux acc t] catenates the bindings of [t] in infix - order to the list [acc] *) - -Fixpoint bindings_aux (acc : list (key*elt)) m : list (key*elt) := - match m with - | Leaf => acc - | Node l x d r _ => bindings_aux ((x,d) :: bindings_aux acc r) l - end. - -(** then [bindings] is an instantiation with an empty [acc] *) - -Definition bindings := bindings_aux nil. - -(** * Fold *) - -Fixpoint fold {A} (f : key -> elt -> A -> A) (m : t) : A -> A := - fun a => match m with - | Leaf => a - | Node l x d r _ => fold f r (f x d (fold f l a)) - end. - -(** * Comparison *) - -Variable cmp : elt->elt->bool. - -(** ** Enumeration of the elements of a tree *) - -Inductive enumeration := - | End : enumeration - | More : key -> elt -> t -> enumeration -> enumeration. - -(** [cons m e] adds the elements of tree [m] on the head of - enumeration [e]. *) - -Fixpoint cons m e : enumeration := - match m with - | Leaf => e - | Node l x d r h => cons l (More x d r e) - end. - -(** One step of comparison of elements *) - -Definition equal_more x1 d1 (cont:enumeration->bool) e2 := - match e2 with - | End => false - | More x2 d2 r2 e2 => - match X.compare x1 x2 with - | Eq => cmp d1 d2 &&& cont (cons r2 e2) - | _ => false - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := - match m1 with - | Leaf => cont e2 - | Node l1 x1 d1 r1 _ => - equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition equal_end e2 := match e2 with End => true | _ => false end. - -(** The complete comparison *) - -Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). - -End Elt. -Notation t := tree. -Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). -Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). -Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). -Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). - - -(** * Map *) - -Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (map f l) x (f d) (map f r) h - end. - -(* * Mapi *) - -Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h - end. - -(** * Map with removal *) - -Fixpoint mapo (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) - : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => - match f x d with - | Some d' => join (mapo f l) x d' (mapo f r) - | None => concat (mapo f l) (mapo f r) - end - end. - -(** * Generalized merge - - Suggestion by B. Gregoire: a [merge] function with specialized - arguments that allows bypassing some tree traversal. Instead of one - [f0] of type [key -> option elt -> option elt' -> option elt''], - we ask here for: - - [f] which is a specialisation of [f0] when first option isn't [None] - - [mapl] treats a [tree elt] with [f0] when second option is [None] - - [mapr] treats a [tree elt'] with [f0] when first option is [None] - - The idea is that [mapl] and [mapr] can be instantaneous (e.g. - the identity or some constant function). -*) - -Section GMerge. -Variable elt elt' elt'' : Type. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. - -Fixpoint gmerge m1 m2 := - match m1, m2 with - | Leaf _, _ => mapr m2 - | _, Leaf _ => mapl m1 - | Node l1 x1 d1 r1 h1, _ => - let (l2',o2,r2') := split x1 m2 in - match f x1 d1 o2 with - | Some e => join (gmerge l1 l2') x1 e (gmerge r1 r2') - | None => concat (gmerge l1 l2') (gmerge r1 r2') - end - end. - -End GMerge. - -(** * Merge - - The [merge] function of the Map interface can be implemented - via [gmerge] and [mapo]. -*) - -Section Merge. -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition merge : t elt -> t elt' -> t elt'' := - gmerge - (fun k d o => f k (Some d) o) - (mapo (fun k d => f k (Some d) None)) - (mapo (fun k d' => f k None (Some d'))). - -End Merge. - - - -(** * Invariants *) - -Section Invariants. -Variable elt : Type. - -(** ** Occurrence in a tree *) - -Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := - | MapsRoot : forall l r h y, - X.eq x y -> MapsTo x e (Node l y e r h) - | MapsLeft : forall l r h y e', - MapsTo x e l -> MapsTo x e (Node l y e' r h) - | MapsRight : forall l r h y e', - MapsTo x e r -> MapsTo x e (Node l y e' r h). - -Inductive In (x : key) : t elt -> Prop := - | InRoot : forall l r h y e, - X.eq x y -> In x (Node l y e r h) - | InLeft : forall l r h y e', - In x l -> In x (Node l y e' r h) - | InRight : forall l r h y e', - In x r -> In x (Node l y e' r h). - -Definition In0 k m := exists e:elt, MapsTo k e m. - -(** ** Binary search trees *) - -(** [Above x m] : [x] is strictly greater than any key in [m]. - [Below x m] : [x] is strictly smaller than any key in [m]. *) - -Inductive Above (x:key) : t elt -> Prop := - | AbLeaf : Above x (Leaf _) - | AbNode l r h y e : Above x l -> X.lt y x -> Above x r -> - Above x (Node l y e r h). - -Inductive Below (x:key) : t elt -> Prop := - | BeLeaf : Below x (Leaf _) - | BeNode l r h y e : Below x l -> X.lt x y -> Below x r -> - Below x (Node l y e r h). - -Definition Apart (m1 m2 : t elt) : Prop := - forall x1 x2, In x1 m1 -> In x2 m2 -> X.lt x1 x2. - -(** Alternative statements, equivalent with [LtTree] and [GtTree] *) - -Definition lt_tree x m := forall y, In y m -> X.lt y x. -Definition gt_tree x m := forall y, In y m -> X.lt x y. - -(** [Bst t] : [t] is a binary search tree *) - -Inductive Bst : t elt -> Prop := - | BSLeaf : Bst (Leaf _) - | BSNode : forall x e l r h, Bst l -> Bst r -> - Above x l -> Below x r -> Bst (Node l x e r h). - -End Invariants. - - -(** * Correctness proofs, isolated in a sub-module *) - -Module Proofs. - Module MX := OrderedTypeFacts X. - Module PX := KeyOrderedType X. - Module L := MMapList.Raw X. - -Local Infix "∈" := In (at level 70). -Local Infix "==" := X.eq (at level 70). -Local Infix "<" := X.lt (at level 70). -Local Infix "<<" := Below (at level 70). -Local Infix ">>" := Above (at level 70). -Local Infix "<<<" := Apart (at level 70). - -Scheme tree_ind := Induction for tree Sort Prop. -Scheme Bst_ind := Induction for Bst Sort Prop. -Scheme MapsTo_ind := Induction for MapsTo Sort Prop. -Scheme In_ind := Induction for In Sort Prop. -Scheme Above_ind := Induction for Above Sort Prop. -Scheme Below_ind := Induction for Below Sort Prop. - -Functional Scheme mem_ind := Induction for mem Sort Prop. -Functional Scheme find_ind := Induction for find Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. -Functional Scheme add_ind := Induction for add Sort Prop. -Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge0_ind := Induction for merge0 Sort Prop. -Functional Scheme remove_ind := Induction for remove Sort Prop. -Functional Scheme concat_ind := Induction for concat Sort Prop. -Functional Scheme split_ind := Induction for split Sort Prop. -Functional Scheme mapo_ind := Induction for mapo Sort Prop. -Functional Scheme gmerge_ind := Induction for gmerge Sort Prop. - -(** * Automation and dedicated tactics. *) - -Local Hint Constructors tree MapsTo In Bst Above Below. -Local Hint Unfold lt_tree gt_tree Apart. -Local Hint Immediate MX.eq_sym. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans. - -Tactic Notation "factornode" ident(s) := - try clear s; - match goal with - | |- context [Node ?l ?x ?e ?r ?h] => - set (s:=Node l x e r h) in *; clearbody s; clear l x e r h - | _ : context [Node ?l ?x ?e ?r ?h] |- _ => - set (s:=Node l x e r h) in *; clearbody s; clear l x e r h - end. - -(** A tactic for cleaning hypothesis after use of functional induction. *) - -Ltac cleanf := - match goal with - | H : X.compare _ _ = Eq |- _ => - rewrite ?H; apply MX.compare_eq in H; cleanf - | H : X.compare _ _ = Lt |- _ => - rewrite ?H; apply MX.compare_lt_iff in H; cleanf - | H : X.compare _ _ = Gt |- _ => - rewrite ?H; apply MX.compare_gt_iff in H; cleanf - | _ => idtac - end. - - -(** A tactic to repeat [inversion_clear] on all hyps of the - form [(f (Node ...))] *) - -Ltac inv f := - match goal with - | H:f (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac inv_all f := - match goal with - | H: f _ |- _ => inversion_clear H; inv f - | H: f _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ _ |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac intuition_in := repeat (intuition; inv In; inv MapsTo). - -(* Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) - -Ltac join_tac l x d r := - revert x d r; - induction l as [| ll _ lx ld lr Hlr lh]; - [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (rh+2 - replace (bal u v w z) - with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] - end - | destruct (lh+2 - replace (bal u v w z) - with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] - end - | ] ] ] ]; intros. - -Ltac cleansplit := - simpl; cleanf; inv Bst; - match goal with - | E:split _ _ = 〚 ?l, ?o, ?r 〛 |- _ => - change l with (〚l,o,r〛#l); rewrite <- ?E; - change o with (〚l,o,r〛#o); rewrite <- ?E; - change r with (〚l,o,r〛#r); rewrite <- ?E - | _ => idtac - end. - -(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *) - -(** Facts about [MapsTo] and [In]. *) - -Lemma MapsTo_In {elt} k (e:elt) m : MapsTo k e m -> k ∈ m. -Proof. - induction 1; auto. -Qed. -Local Hint Resolve MapsTo_In. - -Lemma In_MapsTo {elt} k m : k ∈ m -> exists (e:elt), MapsTo k e m. -Proof. - induction 1; try destruct IHIn as (e,He); exists e; auto. -Qed. - -Lemma In_alt {elt} k (m:t elt) : In0 k m <-> k ∈ m. -Proof. - split. - intros (e,H); eauto. - unfold In0; apply In_MapsTo; auto. -Qed. - -Lemma MapsTo_1 {elt} m x y (e:elt) : - x == y -> MapsTo x e m -> MapsTo y e m. -Proof. - induction m; simpl; intuition_in; eauto. -Qed. -Hint Immediate MapsTo_1. - -Instance MapsTo_compat {elt} : - Proper (X.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt). -Proof. - intros x x' Hx e e' He m m' Hm. subst. - split; now apply MapsTo_1. -Qed. - -Instance In_compat {elt} : - Proper (X.eq==>Logic.eq==>iff) (@In elt). -Proof. - intros x x' H m m' <-. - induction m; simpl; intuition_in; eauto. -Qed. - -Lemma In_node_iff {elt} l x (e:elt) r h y : - y ∈ (Node l x e r h) <-> y ∈ l \/ y == x \/ y ∈ r. -Proof. - intuition_in. -Qed. - -(** Results about [Above] and [Below] *) - -Lemma above {elt} (m:t elt) x : - x >> m <-> forall y, y ∈ m -> y < x. -Proof. - split. - - induction 1; intuition_in; MX.order. - - induction m; constructor; auto. -Qed. - -Lemma below {elt} (m:t elt) x : - x << m <-> forall y, y ∈ m -> x < y. -Proof. - split. - - induction 1; intuition_in; MX.order. - - induction m; constructor; auto. -Qed. - -Lemma AboveLt {elt} (m:t elt) x y : x >> m -> y ∈ m -> y < x. -Proof. - rewrite above; intuition. -Qed. - -Lemma BelowGt {elt} (m:t elt) x y : x << m -> y ∈ m -> x < y. -Proof. - rewrite below; intuition. -Qed. - -Lemma Above_not_In {elt} (m:t elt) x : x >> m -> ~ x ∈ m. -Proof. - induction 1; intuition_in; MX.order. -Qed. - -Lemma Below_not_In {elt} (m:t elt) x : x << m -> ~ x ∈ m. -Proof. - induction 1; intuition_in; MX.order. -Qed. - -Lemma Above_trans {elt} (m:t elt) x y : x < y -> x >> m -> y >> m. -Proof. - induction 2; constructor; trivial; MX.order. -Qed. - -Lemma Below_trans {elt} (m:t elt) x y : y < x -> x << m -> y << m. -Proof. - induction 2; constructor; trivial; MX.order. -Qed. - -Local Hint Resolve - AboveLt Above_not_In Above_trans - BelowGt Below_not_In Below_trans. - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: _ >> ?m, V: _ ∈ ?m |- _ => - generalize (AboveLt U V); clear U; order - | U: _ << ?m, V: _ ∈ ?m |- _ => - generalize (BelowGt U V); clear U; order - | U: _ >> ?m, V: MapsTo _ _ ?m |- _ => - generalize (AboveLt U (MapsTo_In V)); clear U; order - | U: _ << ?m, V: MapsTo _ _ ?m |- _ => - generalize (BelowGt U (MapsTo_In V)); clear U; order - | _ => MX.order -end. - -Lemma between {elt} (m m':t elt) x : - x >> m -> x << m' -> m <<< m'. -Proof. - intros H H' y y' Hy Hy'. order. -Qed. - -Section Elt. -Variable elt:Type. -Implicit Types m r : t elt. - -(** * Membership *) - -Lemma find_1 m x e : Bst m -> MapsTo x e m -> find x m = Some e. -Proof. - functional induction (find x m); cleanf; - intros; inv Bst; intuition_in; order. -Qed. - -Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. -Proof. - functional induction (find x m); cleanf; subst; intros; auto. - - discriminate. - - injection H as ->. auto. -Qed. - -Lemma find_spec m x e : Bst m -> - (find x m = Some e <-> MapsTo x e m). -Proof. - split; auto using find_1, find_2. -Qed. - -Lemma find_in m x : find x m <> None -> x ∈ m. -Proof. - destruct (find x m) eqn:F; intros H. - - apply MapsTo_In with e. now apply find_2. - - now elim H. -Qed. - -Lemma in_find m x : Bst m -> x ∈ m -> find x m <> None. -Proof. - intros H H'. - destruct (In_MapsTo H') as (d,Hd). - now rewrite (find_1 H Hd). -Qed. - -Lemma find_in_iff m x : Bst m -> - (find x m <> None <-> x ∈ m). -Proof. - split; auto using find_in, in_find. -Qed. - -Lemma not_find_iff m x : Bst m -> - (find x m = None <-> ~ x ∈ m). -Proof. - intros H. rewrite <- find_in_iff; trivial. - destruct (find x m); split; try easy. now destruct 1. -Qed. - -Lemma eq_option_alt (o o':option elt) : - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- now subst. -- destruct o, o'; rewrite ?H; auto. symmetry; now apply H. -Qed. - -Lemma find_mapsto_equiv : forall m m' x, Bst m -> Bst m' -> - (find x m = find x m' <-> - (forall d, MapsTo x d m <-> MapsTo x d m')). -Proof. - intros m m' x Hm Hm'. rewrite eq_option_alt. - split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec. -Qed. - -Lemma find_in_equiv : forall m m' x, Bst m -> Bst m' -> - find x m = find x m' -> - (x ∈ m <-> x ∈ m'). -Proof. - split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; - apply in_find; auto. -Qed. - -Lemma find_compat m x x' : Bst m -> X.eq x x' -> find x m = find x' m. -Proof. - intros B E. - destruct (find x' m) eqn:H. - - apply find_1; trivial. rewrite E. now apply find_2. - - rewrite not_find_iff in *; trivial. now rewrite E. -Qed. - -Lemma mem_spec m x : Bst m -> mem x m = true <-> x ∈ m. -Proof. - functional induction (mem x m); auto; intros; cleanf; - inv Bst; intuition_in; try discriminate; order. -Qed. - -(** * Empty map *) - -Lemma empty_bst : Bst (empty elt). -Proof. - constructor. -Qed. - -Lemma empty_spec x : find x (empty elt) = None. -Proof. - reflexivity. -Qed. - -(** * Emptyness test *) - -Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m as [|r x e l h]; simpl; split; try easy. - intros H. specialize (H x). now rewrite MX.compare_refl in H. -Qed. - -(** * Helper functions *) - -Lemma create_bst l x e r : - Bst l -> Bst r -> x >> l -> x << r -> Bst (create l x e r). -Proof. - unfold create; auto. -Qed. -Hint Resolve create_bst. - -Lemma create_in l x e r y : - y ∈ (create l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. -Qed. - -Lemma bal_bst l x e r : Bst l -> Bst r -> - x >> l -> x << r -> Bst (bal l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; - inv Bst; inv Above; inv Below; - repeat apply create_bst; auto; unfold create; constructor; eauto. -Qed. -Hint Resolve bal_bst. - -Lemma bal_in l x e r y : - y ∈ (bal l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - functional induction (bal l x e r); intros; cleanf; - rewrite !create_in; intuition_in. -Qed. - -Lemma bal_mapsto l x e r y e' : - MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; - unfold assert_false, create; intuition_in. -Qed. - -Lemma bal_find l x e r y : - Bst l -> Bst r -> x >> l -> x << r -> - find y (bal l x e r) = find y (create l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; trivial; - inv Bst; inv Above; inv Below; - simpl; repeat case X.compare_spec; intuition; order. -Qed. - -(** * Insertion *) - -Lemma add_in m x y e : - y ∈ (add x e m) <-> y == x \/ y ∈ m. -Proof. - functional induction (add x e m); auto; intros; cleanf; - rewrite ?bal_in; intuition_in. setoid_replace y with x; auto. -Qed. - -Lemma add_lt m x e y : y >> m -> x < y -> y >> add x e m. -Proof. - intros. apply above. intros z. rewrite add_in. destruct 1; order. -Qed. - -Lemma add_gt m x e y : y << m -> y < x -> y << add x e m. -Proof. - intros. apply below. intros z. rewrite add_in. destruct 1; order. -Qed. - -Lemma add_bst m x e : Bst m -> Bst (add x e m). -Proof. - functional induction (add x e m); intros; cleanf; - inv Bst; try apply bal_bst; auto using add_lt, add_gt. -Qed. -Hint Resolve add_lt add_gt add_bst. - -Lemma add_spec1 m x e : Bst m -> find x (add x e m) = Some e. -Proof. - functional induction (add x e m); simpl; intros; cleanf; trivial. - - now rewrite MX.compare_refl. - - inv Bst. rewrite bal_find; auto. - simpl. case X.compare_spec; try order; auto. - - inv Bst. rewrite bal_find; auto. - simpl. case X.compare_spec; try order; auto. -Qed. - -Lemma add_spec2 m x y e : Bst m -> ~ x == y -> - find y (add x e m) = find y m. -Proof. - functional induction (add x e m); simpl; intros; cleanf; trivial. - - case X.compare_spec; trivial; order. - - case X.compare_spec; trivial; order. - - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. - - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. -Qed. - -Lemma add_find m x y e : Bst m -> - find y (add x e m) = - match X.compare y x with Eq => Some e | _ => find y m end. -Proof. - intros. - case X.compare_spec; intros. - - apply find_spec; auto. rewrite H0. apply find_spec; auto. - now apply add_spec1. - - apply add_spec2; trivial; order. - - apply add_spec2; trivial; order. -Qed. - -(** * Extraction of minimum binding *) - -Definition RemoveMin m res := - match m with - | Leaf _ => False - | Node l x e r h => remove_min l x e r = res - end. - -Lemma RemoveMin_step l x e r h m' p : - RemoveMin (Node l x e r h) (m',p) -> - (l = Leaf _ /\ m' = r /\ p = (x,e) \/ - exists m0, RemoveMin l (m0,p) /\ m' = bal m0 x e r). -Proof. - simpl. destruct l as [|ll lx le lr lh]; simpl. - - intros [= -> ->]. now left. - - destruct (remove_min ll lx le lr) as (l',p'). - intros [= <- <-]. right. now exists l'. -Qed. - -Lemma remove_min_mapsto m m' p : RemoveMin m (m',p) -> - forall y e, - MapsTo y e m <-> (y == p#1 /\ e = p#2) \/ MapsTo y e m'. -Proof. - revert m'. - induction m as [|l IH x d r _ h]; [destruct 1|]. - intros m' R. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]; intros y e; simpl. - - intuition_in. subst. now constructor. - - rewrite bal_mapsto. unfold create. specialize (IH _ R y e). - intuition_in. -Qed. - -Lemma remove_min_in m m' p : RemoveMin m (m',p) -> - forall y, y ∈ m <-> y == p#1 \/ y ∈ m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R y. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]. - + intuition_in. - + rewrite bal_in, In_node_iff, (IH _ R); intuition. -Qed. - -Lemma remove_min_lt m m' p : RemoveMin m (m',p) -> - forall y, y >> m -> y >> m'. -Proof. - intros R y L. apply above. intros z Hz. - apply (AboveLt L). - apply (remove_min_in R). now right. -Qed. - -Lemma remove_min_gt m m' p : RemoveMin m (m',p) -> - Bst m -> p#1 << m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R H. inv Bst. apply RemoveMin_step in R. - destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. - assert (p#1 << m0) by now apply IH. - assert (In p#1 l) by (apply (remove_min_in R); now left). - apply below. intros z. rewrite bal_in. - intuition_in; order. -Qed. - -Lemma remove_min_bst m m' p : RemoveMin m (m',p) -> - Bst m -> Bst m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R H. inv Bst. apply RemoveMin_step in R. - destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. - apply bal_bst; eauto using remove_min_lt. -Qed. - -Lemma remove_min_find m m' p : RemoveMin m (m',p) -> - Bst m -> - forall y, - find y m = - match X.compare y p#1 with - | Eq => Some p#2 - | Lt => None - | Gt => find y m' - end. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R B y. inv Bst. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]; auto. - assert (Bst m0) by now apply (remove_min_bst R). - assert (p#1 << m0) by now apply (remove_min_gt R). - assert (x >> m0) by now apply (remove_min_lt R). - assert (In p#1 l) by (apply (remove_min_in R); now left). - simpl in *. - rewrite (IH _ R), bal_find by trivial. clear IH. simpl. - do 2 case X.compare_spec; trivial; try order. -Qed. - -(** * Merging two trees *) - -Ltac factor_remove_min m R := match goal with - | h:int, H:remove_min ?l ?x ?e ?r = ?p |- _ => - assert (R:RemoveMin (Node l x e r h) p) by exact H; - set (m:=Node l x e r h) in *; clearbody m; clear H l x e r -end. - -Lemma merge0_in m1 m2 y : - y ∈ (merge0 m1 m2) <-> y ∈ m1 \/ y ∈ m2. -Proof. - functional induction (merge0 m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min l R. rewrite bal_in, (remove_min_in R). - simpl; intuition. -Qed. - -Lemma merge0_mapsto m1 m2 y e : - MapsTo y e (merge0 m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2. -Proof. - functional induction (merge0 m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min l R. rewrite bal_mapsto, (remove_min_mapsto R). - simpl. unfold create; intuition_in. subst. now constructor. -Qed. - -Lemma merge0_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> - Bst (merge0 m1 m2). -Proof. - functional induction (merge0 m1 m2); intros B1 B2 B12; trivial. - factornode m1. factor_remove_min l R. - apply bal_bst; auto. - - eapply remove_min_bst; eauto. - - apply above. intros z Hz. apply B12; trivial. - rewrite (remove_min_in R). now left. - - now apply (remove_min_gt R). -Qed. -Hint Resolve merge0_bst. - -(** * Deletion *) - -Lemma remove_in m x y : Bst m -> - (y ∈ remove x m <-> ~ y == x /\ y ∈ m). -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst; - rewrite ?merge0_in, ?bal_in, ?IHt; intuition_in; order. -Qed. - -Lemma remove_lt m x y : Bst m -> y >> m -> y >> remove x m. -Proof. - intros. apply above. intro. rewrite remove_in by trivial. - destruct 1; order. -Qed. - -Lemma remove_gt m x y : Bst m -> y << m -> y << remove x m. -Proof. - intros. apply below. intro. rewrite remove_in by trivial. - destruct 1; order. -Qed. - -Lemma remove_bst m x : Bst m -> Bst (remove x m). -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst. - - trivial. - - apply merge0_bst; eauto. - - apply bal_bst; auto using remove_lt. - - apply bal_bst; auto using remove_gt. -Qed. -Hint Resolve remove_bst remove_gt remove_lt. - -Lemma remove_spec1 m x : Bst m -> find x (remove x m) = None. -Proof. - intros. apply not_find_iff; auto. rewrite remove_in; intuition. -Qed. - -Lemma remove_spec2 m x y : Bst m -> ~ x == y -> - find y (remove x m) = find y m. -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst. - - trivial. - - case X.compare_spec; intros; try order; - rewrite find_mapsto_equiv; auto. - + intros. rewrite merge0_mapsto; intuition; order. - + apply merge0_bst; auto. red; intros; transitivity y0; order. - + intros. rewrite merge0_mapsto; intuition; order. - + apply merge0_bst; auto. now apply between with y0. - - rewrite bal_find by auto. simpl. case X.compare_spec; auto. - - rewrite bal_find by auto. simpl. case X.compare_spec; auto. -Qed. - -(** * join *) - -Lemma join_in l x d r y : - y ∈ (join l x d r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - join_tac l x d r. - - simpl join. rewrite add_in. intuition_in. - - rewrite add_in. intuition_in. - - rewrite bal_in, Hlr. clear Hlr Hrl. intuition_in. - - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. - - apply create_in. -Qed. - -Lemma join_bst l x d r : - Bst (create l x d r) -> Bst (join l x d r). -Proof. - join_tac l x d r; unfold create in *; - inv Bst; inv Above; inv Below; auto. - - simpl. auto. - - apply bal_bst; auto. - apply below. intro. rewrite join_in. intuition_in; order. - - apply bal_bst; auto. - apply above. intro. rewrite join_in. intuition_in; order. -Qed. -Hint Resolve join_bst. - -Lemma join_find l x d r y : - Bst (create l x d r) -> - find y (join l x d r) = find y (create l x d r). -Proof. - unfold create at 1. - join_tac l x d r; trivial. - - simpl in *. inv Bst. - rewrite add_find; trivial. - case X.compare_spec; intros; trivial. - apply not_find_iff; auto. intro. order. - - clear Hlr. factornode l. simpl. inv Bst. - rewrite add_find by auto. - case X.compare_spec; intros; trivial. - apply not_find_iff; auto. intro. order. - - clear Hrl LT. factornode r. inv Bst; inv Above; inv Below. - rewrite bal_find; auto; simpl. - + rewrite Hlr; auto; simpl. - repeat (case X.compare_spec; trivial; try order). - + apply below. intro. rewrite join_in. intuition_in; order. - - clear Hlr LT LT'. factornode l. inv Bst; inv Above; inv Below. - rewrite bal_find; auto; simpl. - + rewrite Hrl; auto; simpl. - repeat (case X.compare_spec; trivial; try order). - + apply above. intro. rewrite join_in. intuition_in; order. -Qed. - -(** * split *) - -Lemma split_in_l0 m x y : y ∈ (split x m)#l -> y ∈ m. -Proof. - functional induction (split x m); cleansplit; - rewrite ?join_in; intuition. -Qed. - -Lemma split_in_r0 m x y : y ∈ (split x m)#r -> y ∈ m. -Proof. - functional induction (split x m); cleansplit; - rewrite ?join_in; intuition. -Qed. - -Lemma split_in_l m x y : Bst m -> - (y ∈ (split x m)#l <-> y ∈ m /\ y < x). -Proof. - functional induction (split x m); intros; cleansplit; - rewrite ?join_in, ?IHt; intuition_in; order. -Qed. - -Lemma split_in_r m x y : Bst m -> - (y ∈ (split x m)#r <-> y ∈ m /\ x < y). -Proof. - functional induction (split x m); intros; cleansplit; - rewrite ?join_in, ?IHt; intuition_in; order. -Qed. - -Lemma split_in_o m x : (split x m)#o = find x m. -Proof. - functional induction (split x m); intros; cleansplit; auto. -Qed. - -Lemma split_lt_l m x : Bst m -> x >> (split x m)#l. -Proof. - intro. apply above. intro. rewrite split_in_l; intuition; order. -Qed. - -Lemma split_lt_r m x y : y >> m -> y >> (split x m)#r. -Proof. - intro. apply above. intros z Hz. apply split_in_r0 in Hz. order. -Qed. - -Lemma split_gt_r m x : Bst m -> x << (split x m)#r. -Proof. - intro. apply below. intro. rewrite split_in_r; intuition; order. -Qed. - -Lemma split_gt_l m x y : y << m -> y << (split x m)#l. -Proof. - intro. apply below. intros z Hz. apply split_in_l0 in Hz. order. -Qed. -Hint Resolve split_lt_l split_lt_r split_gt_l split_gt_r. - -Lemma split_bst_l m x : Bst m -> Bst (split x m)#l. -Proof. - functional induction (split x m); intros; cleansplit; intuition; - auto using join_bst. -Qed. - -Lemma split_bst_r m x : Bst m -> Bst (split x m)#r. -Proof. - functional induction (split x m); intros; cleansplit; intuition; - auto using join_bst. -Qed. -Hint Resolve split_bst_l split_bst_r. - -Lemma split_find m x y : Bst m -> - find y m = match X.compare y x with - | Eq => (split x m)#o - | Lt => find y (split x m)#l - | Gt => find y (split x m)#r - end. -Proof. - functional induction (split x m); intros; cleansplit. - - now case X.compare. - - repeat case X.compare_spec; trivial; order. - - simpl in *. rewrite join_find, IHt; auto. - simpl. repeat case X.compare_spec; trivial; order. - - rewrite join_find, IHt; auto. - simpl; repeat case X.compare_spec; trivial; order. -Qed. - -(** * Concatenation *) - -Lemma concat_in m1 m2 y : - y ∈ (concat m1 m2) <-> y ∈ m1 \/ y ∈ m2. -Proof. - functional induction (concat m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min m2 R. - rewrite join_in, (remove_min_in R); simpl; intuition. -Qed. - -Lemma concat_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> - Bst (concat m1 m2). -Proof. - functional induction (concat m1 m2); intros B1 B2 LT; auto; - try factornode m1. - factor_remove_min m2 R. - apply join_bst, create_bst; auto. - - now apply (remove_min_bst R). - - apply above. intros y Hy. apply LT; trivial. - rewrite (remove_min_in R); now left. - - now apply (remove_min_gt R). -Qed. -Hint Resolve concat_bst. - -Definition oelse {A} (o1 o2:option A) := - match o1 with - | Some x => Some x - | None => o2 - end. - -Lemma concat_find m1 m2 y : Bst m1 -> Bst m2 -> m1 <<< m2 -> - find y (concat m1 m2) = oelse (find y m2) (find y m1). -Proof. - functional induction (concat m1 m2); intros B1 B2 B; auto; try factornode m1. - - destruct (find y m2); auto. - - factor_remove_min m2 R. - assert (xd#1 >> m1). - { apply above. intros z Hz. apply B; trivial. - rewrite (remove_min_in R). now left. } - rewrite join_find; simpl; auto. - + rewrite (remove_min_find R B2 y). - case X.compare_spec; intros; auto. - destruct (find y m2'); trivial. - simpl. symmetry. apply not_find_iff; eauto. - + apply create_bst; auto. - * now apply (remove_min_bst R). - * now apply (remove_min_gt R). -Qed. - - -(** * Elements *) - -Notation eqk := (PX.eqk (elt:= elt)). -Notation eqke := (PX.eqke (elt:= elt)). -Notation ltk := (PX.ltk (elt:= elt)). - -Lemma bindings_aux_mapsto : forall (s:t elt) acc x e, - InA eqke (x,e) (bindings_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. -Proof. - induction s as [ | l Hl x e r Hr h ]; simpl; auto. - intuition. - inversion H0. - intros. - rewrite Hl. - destruct (Hr acc x0 e0); clear Hl Hr. - intuition; inversion_clear H3; intuition. - compute in H0. destruct H0; simpl in *; subst; intuition. -Qed. - -Lemma bindings_mapsto : forall (s:t elt) x e, - InA eqke (x,e) (bindings s) <-> MapsTo x e s. -Proof. - intros; generalize (bindings_aux_mapsto s nil x e); intuition. - inversion_clear H0. -Qed. - -Lemma bindings_in : forall (s:t elt) x, L.PX.In x (bindings s) <-> x ∈ s. -Proof. - intros. - unfold L.PX.In. - rewrite <- In_alt; unfold In0. - split; intros (y,H); exists y. - - now rewrite <- bindings_mapsto. - - unfold L.PX.MapsTo; now rewrite bindings_mapsto. -Qed. - -Lemma bindings_aux_sort : forall (s:t elt) acc, - Bst s -> sort ltk acc -> - (forall x e y, InA eqke (x,e) acc -> y ∈ s -> y < x) -> - sort ltk (bindings_aux acc s). -Proof. - induction s as [ | l Hl y e r Hr h]; simpl; intuition. - inv Bst. - apply Hl; auto. - - constructor. - + apply Hr; eauto. - + clear Hl Hr. - apply InA_InfA with (eqA:=eqke); auto with *. - intros (y',e') Hy'. - apply bindings_aux_mapsto in Hy'. compute. intuition; eauto. - - clear Hl Hr. intros x e' y' Hx Hy'. - inversion_clear Hx. - + compute in H. destruct H; simpl in *. order. - + apply bindings_aux_mapsto in H. intuition eauto. -Qed. - -Lemma bindings_sort : forall s : t elt, Bst s -> sort ltk (bindings s). -Proof. - intros; unfold bindings; apply bindings_aux_sort; auto. - intros; inversion H0. -Qed. -Hint Resolve bindings_sort. - -Lemma bindings_nodup : forall s : t elt, Bst s -> NoDupA eqk (bindings s). -Proof. - intros; apply PX.Sort_NoDupA; auto. -Qed. - -Lemma bindings_aux_cardinal m acc : - (length acc + cardinal m)%nat = length (bindings_aux acc m). -Proof. - revert acc. induction m; simpl; intuition. - rewrite <- IHm1; simpl. - rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc. - f_equal. f_equal. apply Nat.add_comm. -Qed. - -Lemma bindings_cardinal m : cardinal m = length (bindings m). -Proof. - exact (bindings_aux_cardinal m nil). -Qed. - -Lemma bindings_app : - forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold bindings; simpl. - rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto. -Qed. - -Lemma bindings_node : - forall (t1 t2:t elt) x e z l, - bindings t1 ++ (x,e) :: bindings t2 ++ l = - bindings (Node t1 x e t2 z) ++ l. -Proof. - unfold bindings; simpl; intros. - rewrite !bindings_app, !app_nil_r, !app_ass; auto. -Qed. - -(** * Fold *) - -Definition fold' {A} (f : key -> elt -> A -> A)(s : t elt) := - L.fold f (bindings s). - -Lemma fold_equiv_aux {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) acc : - L.fold f (bindings_aux acc s) a = L.fold f acc (fold f s a). -Proof. - revert a acc. - induction s; simpl; trivial. - intros. rewrite IHs1. simpl. apply IHs2. -Qed. - -Lemma fold_equiv {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) : - fold f s a = fold' f s a. -Proof. - unfold fold', bindings. now rewrite fold_equiv_aux. -Qed. - -Lemma fold_spec (s:t elt)(Hs:Bst s){A}(i:A)(f : key -> elt -> A -> A) : - fold f s i = fold_left (fun a p => f p#1 p#2 a) (bindings s) i. -Proof. - rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec. -Qed. - -(** * Comparison *) - -(** [flatten_e e] returns the list of bindings of the enumeration [e] - i.e. the list of bindings actually compared *) - -Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with - | End _ => nil - | More x e t r => (x,e) :: bindings t ++ flatten_e r - end. - -Lemma flatten_e_bindings : - forall (l:t elt) r x d z e, - bindings l ++ flatten_e (More x d r e) = - bindings (Node l x d r z) ++ flatten_e e. -Proof. - intros; apply bindings_node. -Qed. - -Lemma cons_1 : forall (s:t elt) e, - flatten_e (cons s e) = bindings s ++ flatten_e e. -Proof. - induction s; auto; intros. - simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; auto. -Qed. - -(** Proof of correction for the comparison *) - -Variable cmp : elt->elt->bool. - -Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. - -Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> cmp d1 d2 = true -> - IfEq b l1 l2 -> - IfEq b ((x1,d1)::l1) ((x2,d2)::l2). -Proof. - unfold IfEq; destruct b; simpl; intros; case X.compare_spec; simpl; - try rewrite H0; auto; order. -Qed. - -Lemma equal_end_IfEq : forall e2, - IfEq (equal_end e2) nil (flatten_e e2). -Proof. - destruct e2; red; auto. -Qed. - -Lemma equal_more_IfEq : - forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, - IfEq (cont (cons r2 e2)) l (bindings r2 ++ flatten_e e2) -> - IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) - (flatten_e (More x2 d2 r2 e2)). -Proof. - unfold IfEq; simpl; intros; destruct X.compare; simpl; auto. - rewrite <-andb_lazy_alt; f_equal; auto. -Qed. - -Lemma equal_cont_IfEq : forall m1 cont e2 l, - (forall e, IfEq (cont e) l (flatten_e e)) -> - IfEq (equal_cont cmp m1 cont e2) (bindings m1 ++ l) (flatten_e e2). -Proof. - induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto. - rewrite <- bindings_node; simpl. - apply Hl1; auto. - clear e2; intros [|x2 d2 r2 e2]. - simpl; red; auto. - apply equal_more_IfEq. - rewrite <- cons_1; auto. -Qed. - -Lemma equal_IfEq : forall (m1 m2:t elt), - IfEq (equal cmp m1 m2) (bindings m1) (bindings m2). -Proof. - intros; unfold equal. - rewrite <- (app_nil_r (bindings m1)). - replace (bindings m2) with (flatten_e (cons m2 (End _))) - by (rewrite cons_1; simpl; rewrite app_nil_r; auto). - apply equal_cont_IfEq. - intros. - apply equal_end_IfEq; auto. -Qed. - -Definition Equivb m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma Equivb_bindings : forall s s', - Equivb s s' <-> L.Equivb cmp (bindings s) (bindings s'). -Proof. -unfold Equivb, L.Equivb; split; split; intros. -do 2 rewrite bindings_in; firstorder. -destruct H. -apply (H2 k); rewrite <- bindings_mapsto; auto. -do 2 rewrite <- bindings_in; firstorder. -destruct H. -apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_mapsto; auto. -Qed. - -Lemma equal_Equivb : forall (s s': t elt), Bst s -> Bst s' -> - (equal cmp s s' = true <-> Equivb s s'). -Proof. - intros s s' B B'. - rewrite Equivb_bindings, <- equal_IfEq. - split; [apply L.equal_2|apply L.equal_1]; auto. -Qed. - -End Elt. - -Section Map. -Variable elt elt' : Type. -Variable f : elt -> elt'. - -Lemma map_spec m x : - find x (map f m) = option_map f (find x m). -Proof. -induction m; simpl; trivial. case X.compare_spec; auto. -Qed. - -Lemma map_in m x : x ∈ (map f m) <-> x ∈ m. -Proof. -induction m; simpl; intuition_in. -Qed. - -Lemma map_bst m : Bst m -> Bst (map f m). -Proof. -induction m; simpl; auto. intros; inv Bst; constructor; auto. -- apply above. intro. rewrite map_in. intros. order. -- apply below. intro. rewrite map_in. intros. order. -Qed. - -End Map. -Section Mapi. -Variable elt elt' : Type. -Variable f : key -> elt -> elt'. - -Lemma mapi_spec m x : - exists y:key, - X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m; simpl. - - now exists x. - - case X.compare_spec; simpl; auto. intros. now exists k. -Qed. - -Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m. -Proof. -induction m; simpl; intuition_in. -Qed. - -Lemma mapi_bst m : Bst m -> Bst (mapi f m). -Proof. -induction m; simpl; auto. intros; inv Bst; constructor; auto. -- apply above. intro. rewrite mapi_in. intros. order. -- apply below. intro. rewrite mapi_in. intros. order. -Qed. - -End Mapi. - -Section Mapo. -Variable elt elt' : Type. -Variable f : key -> elt -> option elt'. - -Lemma mapo_in m x : - x ∈ (mapo f m) -> - exists y d, X.eq y x /\ MapsTo x d m /\ f y d <> None. -Proof. -functional induction (mapo f m); simpl; auto; intro H. -- inv In. -- rewrite join_in in H; destruct H as [H|[H|H]]. - + exists x0, d. do 2 (split; auto). congruence. - + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. - + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. -- rewrite concat_in in H; destruct H as [H|H]. - + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. - + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. -Qed. - -Lemma mapo_lt m x : x >> m -> x >> mapo f m. -Proof. - intros H. apply above. intros y Hy. - destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. -Qed. - -Lemma mapo_gt m x : x << m -> x << mapo f m. -Proof. - intros H. apply below. intros y Hy. - destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. -Qed. -Hint Resolve mapo_lt mapo_gt. - -Lemma mapo_bst m : Bst m -> Bst (mapo f m). -Proof. -functional induction (mapo f m); simpl; auto; intro H; inv Bst. -- apply join_bst, create_bst; auto. -- apply concat_bst; auto. apply between with x; auto. -Qed. -Hint Resolve mapo_bst. - -Ltac nonify e := - replace e with (@None elt) by - (symmetry; rewrite not_find_iff; auto; intro; order). - -Definition obind {A B} (o:option A) (f:A->option B) := - match o with Some a => f a | None => None end. - -Lemma mapo_find m x : - Bst m -> - exists y, X.eq y x /\ - find x (mapo f m) = obind (find x m) (f y). -Proof. -functional induction (mapo f m); simpl; auto; intros B; - inv Bst. -- now exists x. -- rewrite join_find; auto. - + simpl. case X.compare_spec; simpl; intros. - * now exists x0. - * destruct IHt as (y' & ? & ?); auto. - exists y'; split; trivial. - * destruct IHt0 as (y' & ? & ?); auto. - exists y'; split; trivial. - + constructor; auto using mapo_lt, mapo_gt. -- rewrite concat_find; auto. - + destruct IHt0 as (y' & ? & ->); auto. - destruct IHt as (y'' & ? & ->); auto. - case X.compare_spec; simpl; intros. - * nonify (find x r). nonify (find x l). simpl. now exists x0. - * nonify (find x r). now exists y''. - * nonify (find x l). exists y'. split; trivial. - destruct (find x r); simpl; trivial. - now destruct (f y' e). - + apply between with x0; auto. -Qed. - -End Mapo. - -Section Gmerge. -Variable elt elt' elt'' : Type. -Variable f0 : key -> option elt -> option elt' -> option elt''. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. -Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. -Hypothesis mapl_bst : forall m, Bst m -> Bst (mapl m). -Hypothesis mapr_bst : forall m', Bst m' -> Bst (mapr m'). -Hypothesis mapl_f0 : forall x m, Bst m -> - exists y, X.eq y x /\ - find x (mapl m) = obind (find x m) (fun d => f0 y (Some d) None). -Hypothesis mapr_f0 : forall x m, Bst m -> - exists y, X.eq y x /\ - find x (mapr m) = obind (find x m) (fun d => f0 y None (Some d)). - -Notation gmerge := (gmerge f mapl mapr). - -Lemma gmerge_in m m' y : Bst m -> Bst m' -> - y ∈ (gmerge m m') -> y ∈ m \/ y ∈ m'. -Proof. - functional induction (gmerge m m'); intros B1 B2 H; - try factornode m2; inv Bst. - - right. apply find_in. - generalize (in_find (mapr_bst B2) H). - destruct (@mapr_f0 y m2) as (y' & ? & ->); trivial. - intros A B. rewrite B in A. now elim A. - - left. apply find_in. - generalize (in_find (mapl_bst B1) H). - destruct (@mapl_f0 y m2) as (y' & ? & ->); trivial. - intros A B. rewrite B in A. now elim A. - - rewrite join_in in *. revert IHt1 IHt0 H. cleansplit. - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite split_in_r, split_in_l; intuition_in. - - rewrite concat_in in *. revert IHt1 IHt0 H; cleansplit. - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite split_in_r, split_in_l; intuition_in. -Qed. - -Lemma gmerge_lt m m' x : Bst m -> Bst m' -> - x >> m -> x >> m' -> x >> gmerge m m'. -Proof. - intros. apply above. intros y Hy. - apply gmerge_in in Hy; intuition_in; order. -Qed. - -Lemma gmerge_gt m m' x : Bst m -> Bst m' -> - x << m -> x << m' -> x << gmerge m m'. -Proof. - intros. apply below. intros y Hy. - apply gmerge_in in Hy; intuition_in; order. -Qed. -Hint Resolve gmerge_lt gmerge_gt. -Hint Resolve split_bst_l split_bst_r split_lt_l split_gt_r. - -Lemma gmerge_bst m m' : Bst m -> Bst m' -> Bst (gmerge m m'). -Proof. - functional induction (gmerge m m'); intros B1 B2; auto; - factornode m2; inv Bst; - (apply join_bst, create_bst || apply concat_bst); - revert IHt1 IHt0; cleansplit; intuition. - apply between with x1; auto. -Qed. -Hint Resolve gmerge_bst. - -Lemma oelse_none_r {A} (o:option A) : oelse o None = o. -Proof. now destruct o. Qed. - -Ltac nonify e := - let E := fresh "E" in - assert (E : e = None); - [ rewrite not_find_iff; auto; intro U; - try apply gmerge_in in U; intuition_in; order - | rewrite E; clear E ]. - -Lemma gmerge_find m m' x : Bst m -> Bst m' -> - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (gmerge m m') = f0 y (find x m) (find x m'). -Proof. - functional induction (gmerge m m'); intros B1 B2 H; - try factornode m2; inv Bst. - - destruct H; [ intuition_in | ]. - destruct (@mapr_f0 x m2) as (y,(Hy,E)); trivial. - exists y; split; trivial. - rewrite E. simpl. apply in_find in H; trivial. - destruct (find x m2); simpl; intuition. - - destruct H; [ | intuition_in ]. - destruct (@mapl_f0 x m2) as (y,(Hy,E)); trivial. - exists y; split; trivial. - rewrite E. simpl. apply in_find in H; trivial. - destruct (find x m2); simpl; intuition. - - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite (split_find x1 x B2). - rewrite e1 in *; simpl in *. intros. - rewrite join_find by (cleansplit; constructor; auto). - simpl. case X.compare_spec; intros. - + exists x1. split; auto. now rewrite <- e3, f0_f. - + apply IHt1; auto. clear IHt1 IHt0. - cleansplit; rewrite split_in_l; trivial. - intuition_in; order. - + apply IHt0; auto. clear IHt1 IHt0. - cleansplit; rewrite split_in_r; trivial. - intuition_in; order. - - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite (split_find x1 x B2). - pose proof (split_lt_l x1 B2). - pose proof (split_gt_r x1 B2). - rewrite e1 in *; simpl in *. intros. - rewrite concat_find by (try apply between with x1; auto). - case X.compare_spec; intros. - + clear IHt0 IHt1. - exists x1. split; auto. rewrite <- f0_f, e2. - nonify (find x (gmerge r1 r2')). - nonify (find x (gmerge l1 l2')). trivial. - + nonify (find x (gmerge r1 r2')). - simpl. apply IHt1; auto. clear IHt1 IHt0. - intuition_in; try order. - right. cleansplit. now apply split_in_l. - + nonify (find x (gmerge l1 l2')). simpl. - rewrite oelse_none_r. - apply IHt0; auto. clear IHt1 IHt0. - intuition_in; try order. - right. cleansplit. now apply split_in_r. -Qed. - -End Gmerge. - -Section Merge. -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Lemma merge_bst m m' : Bst m -> Bst m' -> Bst (merge f m m'). -Proof. -unfold merge; intros. -apply gmerge_bst with f; - auto using mapo_bst, mapo_find. -Qed. - -Lemma merge_spec1 m m' x : Bst m -> Bst m' -> - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). -Proof. - unfold merge; intros. - edestruct (gmerge_find (f0:=f)) as (y,(Hy,E)); - eauto using mapo_bst. - - reflexivity. - - intros. now apply mapo_find. - - intros. now apply mapo_find. -Qed. - -Lemma merge_spec2 m m' x : Bst m -> Bst m' -> - In x (merge f m m') -> In x m \/ In x m'. -Proof. -unfold merge; intros. -eapply gmerge_in with (f0:=f); try eassumption; - auto using mapo_bst, mapo_find. -Qed. - -End Merge. -End Proofs. -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of balanced binary search trees. *) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Raw := Raw I X. - Import Raw.Proofs. - - Record tree (elt:Type) := - Mk {this :> Raw.tree elt; is_bst : Raw.Bst this}. - - Definition t := tree. - Definition key := E.t. - - Section Elt. - Variable elt elt' elt'': Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Mk (empty_bst elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Mk (remove_bst x m.(is_bst)). - Definition mem x m : bool := Raw.mem x m.(this). - Definition find x m : option elt := Raw.find x m.(this). - Definition map f m : t elt' := Mk (map_bst f m.(is_bst)). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (mapi_bst f m.(is_bst)). - Definition merge f m (m':t elt') : t elt'' := - Mk (merge_bst f m.(is_bst) m'.(is_bst)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := Raw.cardinal m.(this). - Definition fold {A} (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - - Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). - Definition In x m : Prop := Raw.In0 x m.(this). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros k k' Hk e e' He m m' Hm. unfold MapsTo; simpl. - now rewrite Hk, He, Hm. - Qed. - - Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. - Proof. apply find_spec. apply is_bst. Qed. - - Lemma mem_spec m x : mem x m = true <-> In x m. - Proof. - unfold In, mem; rewrite In_alt. apply mem_spec. apply is_bst. - Qed. - - Lemma empty_spec x : find x empty = None. - Proof. apply empty_spec. Qed. - - Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. - Proof. apply is_empty_spec. Qed. - - Lemma add_spec1 m x e : find x (add x e m) = Some e. - Proof. apply add_spec1. apply is_bst. Qed. - Lemma add_spec2 m x y e : ~ E.eq x y -> find y (add x e m) = find y m. - Proof. apply add_spec2. apply is_bst. Qed. - - Lemma remove_spec1 m x : find x (remove x m) = None. - Proof. apply remove_spec1. apply is_bst. Qed. - Lemma remove_spec2 m x y : ~E.eq x y -> find y (remove x m) = find y m. - Proof. apply remove_spec2. apply is_bst. Qed. - - Lemma bindings_spec1 m x e : - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. apply bindings_mapsto. Qed. - - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. apply bindings_sort. apply is_bst. Qed. - - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. apply bindings_nodup. apply is_bst. Qed. - - Lemma fold_spec m {A} (i : A) (f : key -> elt -> A -> A) : - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. apply fold_spec. apply is_bst. Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. apply bindings_cardinal. Qed. - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp := Equiv (Cmp cmp). - - Lemma Equivb_Equivb cmp m m' : - Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. - unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. - generalize (H0 k); do 2 rewrite In_alt; intuition. - generalize (H0 k); do 2 rewrite In_alt; intuition. - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - Qed. - - Lemma equal_spec m m' cmp : - equal cmp m m' = true <-> Equivb cmp m m'. - Proof. rewrite Equivb_Equivb. apply equal_Equivb; apply is_bst. Qed. - - End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m x : - find x (map f m) = option_map f (find x m). - Proof. apply map_spec. Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m x : - exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. apply mapi_spec. Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' x : - In x m \/ In x m' -> - exists y:key, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - Proof. - unfold In. rewrite !In_alt. apply merge_spec1; apply is_bst. - Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key -> option elt->option elt'->option elt'') m m' x : - In x (merge f m m') -> In x m \/ In x m'. - Proof. - unfold In. rewrite !In_alt. apply merge_spec2; apply is_bst. - Qed. - -End IntMake. - - -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D - with Module MapS.E := X. - - Module Data := D. - Module Import MapS := IntMake(I)(X). - Module LO := MMapList.Make_ord(X)(D). - Module R := Raw. - Module P := Raw.Proofs. - - Definition t := MapS.t D.t. - - Definition cmp e e' := - match D.compare e e' with Eq => true | _ => false end. - - (** One step of comparison of bindings *) - - Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := - match e2 with - | R.End _ => Gt - | R.More x2 d2 r2 e2 => - match X.compare x1 x2 with - | Eq => match D.compare d1 d2 with - | Eq => cont (R.cons r2 e2) - | Lt => Lt - | Gt => Gt - end - | Lt => Lt - | Gt => Gt - end - end. - - (** Comparison of left tree, middle element, then right tree *) - - Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := - match s1 with - | R.Leaf _ => cont e2 - | R.Node l1 x1 d1 r1 _ => - compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 - end. - - (** Initial continuation *) - - Definition compare_end (e2:R.enumeration D.t) := - match e2 with R.End _ => Eq | _ => Lt end. - - (** The complete comparison *) - - Definition compare m1 m2 := - compare_cont m1.(this) compare_end (R.cons m2 .(this) (Raw.End _)). - - (** Correctness of this comparison *) - - Definition Cmp c := - match c with - | Eq => LO.eq_list - | Lt => LO.lt_list - | Gt => (fun l1 l2 => LO.lt_list l2 l1) - end. - - Lemma cons_Cmp c x1 x2 d1 d2 l1 l2 : - X.eq x1 x2 -> D.eq d1 d2 -> - Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). - Proof. - destruct c; simpl; intros; case X.compare_spec; auto; try P.MX.order. - intros. right. split; auto. now symmetry. - Qed. - Hint Resolve cons_Cmp. - - Lemma compare_end_Cmp e2 : - Cmp (compare_end e2) nil (P.flatten_e e2). - Proof. - destruct e2; simpl; auto. - Qed. - - Lemma compare_more_Cmp x1 d1 cont x2 d2 r2 e2 l : - Cmp (cont (R.cons r2 e2)) l (R.bindings r2 ++ P.flatten_e e2) -> - Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) - (P.flatten_e (R.More x2 d2 r2 e2)). - Proof. - simpl; case X.compare_spec; simpl; - try case D.compare_spec; simpl; auto; - case X.compare_spec; try P.MX.order; auto. - Qed. - - Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (P.flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (R.bindings s1 ++ l) (P.flatten_e e2). - Proof. - induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1] using P.tree_ind; - intros; auto. - rewrite <- P.bindings_node; simpl. - apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]. - simpl; auto. - apply compare_more_Cmp. - rewrite <- P.cons_1; auto. - Qed. - - Lemma compare_Cmp m1 m2 : - Cmp (compare m1 m2) (bindings m1) (bindings m2). - Proof. - destruct m1 as (s1,H1), m2 as (s2,H2). - unfold compare, bindings; simpl. - rewrite <- (app_nil_r (R.bindings s1)). - replace (R.bindings s2) with (P.flatten_e (R.cons s2 (R.End _))) by - (rewrite P.cons_1; simpl; rewrite app_nil_r; auto). - auto using compare_cont_Cmp, compare_end_Cmp. - Qed. - - Definition eq (m1 m2 : t) := LO.eq_list (bindings m1) (bindings m2). - Definition lt (m1 m2 : t) := LO.lt_list (bindings m1) (bindings m2). - - Lemma compare_spec m1 m2 : CompSpec eq lt m1 m2 (compare m1 m2). - Proof. - assert (H := compare_Cmp m1 m2). - unfold Cmp in H. - destruct (compare m1 m2); auto. - Qed. - - (* Proofs about [eq] and [lt] *) - - Definition sbindings (m1 : t) := - LO.MapS.Mk (P.bindings_sort m1.(is_bst)). - - Definition seq (m1 m2 : t) := LO.eq (sbindings m1) (sbindings m2). - Definition slt (m1 m2 : t) := LO.lt (sbindings m1) (sbindings m2). - - Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. - Proof. - unfold eq, seq, sbindings, bindings, LO.eq; intuition. - Qed. - - Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. - Proof. - unfold lt, slt, sbindings, bindings, LO.lt; intuition. - Qed. - - Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. - Proof. - rewrite eq_seq; unfold seq. - rewrite Equivb_Equivb. - rewrite P.Equivb_bindings. apply LO.eq_spec. - Qed. - - Instance eq_equiv : Equivalence eq. - Proof. - constructor; red; [intros x|intros x y| intros x y z]; - rewrite !eq_seq; apply LO.eq_equiv. - Qed. - - Instance lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros m1 m2 H1 m1' m2' H2. rewrite !lt_slt. rewrite eq_seq in *. - now apply LO.lt_compat. - Qed. - - Instance lt_strorder : StrictOrder lt. - Proof. - constructor; red; [intros x; red|intros x y z]; - rewrite !lt_slt; apply LO.lt_strorder. - Qed. - -End IntMake_ord. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). - -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D - with Module MapS.E := X - :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/MMaps/MMapFacts.v b/theories/MMaps/MMapFacts.v deleted file mode 100644 index 8b356d7501..0000000000 --- a/theories/MMaps/MMapFacts.v +++ /dev/null @@ -1,2434 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (b=true <-> b'=true). -Proof. - destruct b, b'; intuition. -Qed. - -Lemma eq_option_alt {elt}(o o':option elt) : - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- now subst. -- destruct o, o'; rewrite ?H; auto. - symmetry; now apply H. -Qed. - -Lemma option_map_some {A B}(f:A->B) o : - option_map f o <> None <-> o <> None. -Proof. - destruct o; simpl. now split. split; now destruct 1. -Qed. - -(** * Properties about weak maps *) - -Module WProperties_fun (E:DecidableType)(Import M:WSfun E). - -Definition Empty {elt}(m : t elt) := forall x e, ~MapsTo x e m. - -(** A few things about E.eq *) - -Lemma eq_refl x : E.eq x x. Proof. apply E.eq_equiv. Qed. -Lemma eq_sym x y : E.eq x y -> E.eq y x. Proof. apply E.eq_equiv. Qed. -Lemma eq_trans x y z : E.eq x y -> E.eq y z -> E.eq x z. -Proof. apply E.eq_equiv. Qed. -Hint Immediate eq_refl eq_sym : map. -Hint Resolve eq_trans eq_equivalence E.eq_equiv : map. - -Definition eqb x y := if E.eq_dec x y then true else false. - -Lemma eqb_eq x y : eqb x y = true <-> E.eq x y. -Proof. - unfold eqb; case E.eq_dec; now intuition. -Qed. - -Lemma eqb_sym x y : eqb x y = eqb y x. -Proof. - apply eq_bool_alt. rewrite !eqb_eq. split; apply E.eq_equiv. -Qed. - -(** Initial results about MapsTo and In *) - -Lemma mapsto_fun {elt} m x (e e':elt) : - MapsTo x e m -> MapsTo x e' m -> e=e'. -Proof. -rewrite <- !find_spec. congruence. -Qed. - -Lemma in_find {elt} (m : t elt) x : In x m <-> find x m <> None. -Proof. - unfold In. split. - - intros (e,H). rewrite <-find_spec in H. congruence. - - destruct (find x m) as [e|] eqn:H. - + exists e. now apply find_spec. - + now destruct 1. -Qed. - -Lemma not_in_find {elt} (m : t elt) x : ~In x m <-> find x m = None. -Proof. - rewrite in_find. split; auto. - intros; destruct (find x m); trivial. now destruct H. -Qed. - -Notation in_find_iff := in_find (only parsing). -Notation not_find_in_iff := not_in_find (only parsing). - -(** * [Equal] is a setoid equality. *) - -Infix "==" := Equal (at level 30). - -Lemma Equal_refl {elt} (m : t elt) : m == m. -Proof. red; reflexivity. Qed. - -Lemma Equal_sym {elt} (m m' : t elt) : m == m' -> m' == m. -Proof. unfold Equal; auto. Qed. - -Lemma Equal_trans {elt} (m m' m'' : t elt) : - m == m' -> m' == m'' -> m == m''. -Proof. unfold Equal; congruence. Qed. - -Instance Equal_equiv {elt} : Equivalence (@Equal elt). -Proof. -constructor; [exact Equal_refl | exact Equal_sym | exact Equal_trans]. -Qed. - -Arguments Equal {elt} m m'. - -Instance MapsTo_m {elt} : - Proper (E.eq==>Logic.eq==>Equal==>iff) (@MapsTo elt). -Proof. -intros k k' Hk e e' <- m m' Hm. rewrite <- Hk. -now rewrite <- !find_spec, Hm. -Qed. - -Instance In_m {elt} : - Proper (E.eq==>Equal==>iff) (@In elt). -Proof. -intros k k' Hk m m' Hm. unfold In. -split; intros (e,H); exists e; revert H; - now rewrite Hk, <- !find_spec, Hm. -Qed. - -Instance find_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@find elt). -Proof. -intros k k' Hk m m' <-. -rewrite eq_option_alt. intros. now rewrite !find_spec, Hk. -Qed. - -Instance mem_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@mem elt). -Proof. -intros k k' Hk m m' Hm. now rewrite eq_bool_alt, !mem_spec, Hk, Hm. -Qed. - -Instance Empty_m {elt} : Proper (Equal==>iff) (@Empty elt). -Proof. -intros m m' Hm. unfold Empty. now setoid_rewrite Hm. -Qed. - -Instance is_empty_m {elt} : Proper (Equal ==> Logic.eq) (@is_empty elt). -Proof. -intros m m' Hm. rewrite eq_bool_alt, !is_empty_spec. - now setoid_rewrite Hm. -Qed. - -Instance add_m {elt} : Proper (E.eq==>Logic.eq==>Equal==>Equal) (@add elt). -Proof. -intros k k' Hk e e' <- m m' Hm y. -destruct (E.eq_dec k y) as [H|H]. -- rewrite <-H, add_spec1. now rewrite Hk, add_spec1. -- rewrite !add_spec2; trivial. now rewrite <- Hk. -Qed. - -Instance remove_m {elt} : Proper (E.eq==>Equal==>Equal) (@remove elt). -Proof. -intros k k' Hk m m' Hm y. -destruct (E.eq_dec k y) as [H|H]. -- rewrite <-H, remove_spec1. now rewrite Hk, remove_spec1. -- rewrite !remove_spec2; trivial. now rewrite <- Hk. -Qed. - -Instance map_m {elt elt'} : - Proper ((Logic.eq==>Logic.eq)==>Equal==>Equal) (@map elt elt'). -Proof. -intros f f' Hf m m' Hm y. rewrite !map_spec, Hm. -destruct (find y m'); simpl; trivial. f_equal. now apply Hf. -Qed. - -Instance mapi_m {elt elt'} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@mapi elt elt'). -Proof. -intros f f' Hf m m' Hm y. -destruct (mapi_spec f m y) as (x,(Hx,->)). -destruct (mapi_spec f' m' y) as (x',(Hx',->)). -rewrite <- Hm. destruct (find y m); trivial. simpl. -f_equal. apply Hf; trivial. now rewrite Hx, Hx'. -Qed. - -Instance merge_m {elt elt' elt''} : - Proper ((E.eq==>Logic.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal==>Equal) - (@merge elt elt' elt''). -Proof. -intros f f' Hf m1 m1' Hm1 m2 m2' Hm2 y. -destruct (find y m1) as [e1|] eqn:H1. -- apply find_spec in H1. - assert (H : In y m1 \/ In y m2) by (left; now exists e1). - destruct (merge_spec1 f H) as (y1,(Hy1,->)). - rewrite Hm1,Hm2 in H. - destruct (merge_spec1 f' H) as (y2,(Hy2,->)). - rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. -- destruct (find y m2) as [e2|] eqn:H2. - + apply find_spec in H2. - assert (H : In y m1 \/ In y m2) by (right; now exists e2). - destruct (merge_spec1 f H) as (y1,(Hy1,->)). - rewrite Hm1,Hm2 in H. - destruct (merge_spec1 f' H) as (y2,(Hy2,->)). - rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. - + apply not_in_find in H1. apply not_in_find in H2. - assert (H : ~In y (merge f m1 m2)). - { intro H. apply merge_spec2 in H. intuition. } - apply not_in_find in H. rewrite H. - symmetry. apply not_in_find. intro H'. - apply merge_spec2 in H'. rewrite <- Hm1, <- Hm2 in H'. - intuition. -Qed. - -(* Later: compatibility for cardinal, fold, ... *) - -(** ** Earlier specifications (cf. FMaps) *) - -Section OldSpecs. -Variable elt: Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma MapsTo_1 m x y e : E.eq x y -> MapsTo x e m -> MapsTo y e m. -Proof. - now intros ->. -Qed. - -Lemma find_1 m x e : MapsTo x e m -> find x m = Some e. -Proof. apply find_spec. Qed. - -Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. -Proof. apply find_spec. Qed. - -Lemma mem_1 m x : In x m -> mem x m = true. -Proof. apply mem_spec. Qed. - -Lemma mem_2 m x : mem x m = true -> In x m. -Proof. apply mem_spec. Qed. - -Lemma empty_1 : Empty (@empty elt). -Proof. - intros x e. now rewrite <- find_spec, empty_spec. -Qed. - -Lemma is_empty_1 m : Empty m -> is_empty m = true. -Proof. - unfold Empty; rewrite is_empty_spec. setoid_rewrite <- find_spec. - intros H x. specialize (H x). - destruct (find x m) as [e|]; trivial. - now destruct (H e). -Qed. - -Lemma is_empty_2 m : is_empty m = true -> Empty m. -Proof. - rewrite is_empty_spec. intros H x e. now rewrite <- find_spec, H. -Qed. - -Lemma add_1 m x y e : E.eq x y -> MapsTo y e (add x e m). -Proof. - intros <-. rewrite <-find_spec. apply add_spec1. -Qed. - -Lemma add_2 m x y e e' : - ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). -Proof. - intro. now rewrite <- !find_spec, add_spec2. -Qed. - -Lemma add_3 m x y e e' : - ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. - intro. rewrite <- !find_spec, add_spec2; trivial. -Qed. - -Lemma remove_1 m x y : E.eq x y -> ~ In y (remove x m). -Proof. - intros <-. apply not_in_find. apply remove_spec1. -Qed. - -Lemma remove_2 m x y e : - ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). -Proof. - intro. now rewrite <- !find_spec, remove_spec2. -Qed. - -Lemma remove_3bis m x y e : - find y (remove x m) = Some e -> find y m = Some e. -Proof. - destruct (E.eq_dec x y) as [<-|H]. - - now rewrite remove_spec1. - - now rewrite remove_spec2. -Qed. - -Lemma remove_3 m x y e : MapsTo y e (remove x m) -> MapsTo y e m. -Proof. - rewrite <-!find_spec. apply remove_3bis. -Qed. - -Lemma bindings_1 m x e : - MapsTo x e m -> InA eq_key_elt (x,e) (bindings m). -Proof. apply bindings_spec1. Qed. - -Lemma bindings_2 m x e : - InA eq_key_elt (x,e) (bindings m) -> MapsTo x e m. -Proof. apply bindings_spec1. Qed. - -Lemma bindings_3w m : NoDupA eq_key (bindings m). -Proof. apply bindings_spec2w. Qed. - -Lemma cardinal_1 m : cardinal m = length (bindings m). -Proof. apply cardinal_spec. Qed. - -Lemma fold_1 m (A : Type) (i : A) (f : key -> elt -> A -> A) : - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. apply fold_spec. Qed. - -Lemma equal_1 m m' cmp : Equivb cmp m m' -> equal cmp m m' = true. -Proof. apply equal_spec. Qed. - -Lemma equal_2 m m' cmp : equal cmp m m' = true -> Equivb cmp m m'. -Proof. apply equal_spec. Qed. - -End OldSpecs. - -Lemma map_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:elt->elt') : - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. - rewrite <- !find_spec, map_spec. now intros ->. -Qed. - -Lemma map_2 {elt elt'}(m: t elt)(x:key)(f:elt->elt') : - In x (map f m) -> In x m. -Proof. - rewrite !in_find, map_spec. apply option_map_some. -Qed. - -Lemma mapi_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:key->elt->elt') : - MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. - destruct (mapi_spec f m x) as (y,(Hy,Eq)). - intro H. exists y; split; trivial. - rewrite <-find_spec in *. now rewrite Eq, H. -Qed. - -Lemma mapi_2 {elt elt'}(m: t elt)(x:key)(f:key->elt->elt') : - In x (mapi f m) -> In x m. -Proof. - destruct (mapi_spec f m x) as (y,(Hy,Eq)). - rewrite !in_find. intro H; contradict H. now rewrite Eq, H. -Qed. - -(** The ancestor [map2] of the current [merge] was dealing with functions - on datas only, not on keys. *) - -Definition map2 {elt elt' elt''} (f:option elt->option elt'->option elt'') - := merge (fun _ => f). - -Lemma map2_1 {elt elt' elt''}(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt'') : - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). -Proof. - intros. unfold map2. - now destruct (merge_spec1 (fun _ => f) H) as (y,(_,->)). -Qed. - -Lemma map2_2 {elt elt' elt''}(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt'') : - In x (map2 f m m') -> In x m \/ In x m'. -Proof. apply merge_spec2. Qed. - -Hint Immediate MapsTo_1 mem_2 is_empty_2 - map_2 mapi_2 add_3 remove_3 find_2 : map. -Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 - remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map. - -(** ** Specifications written using equivalences *) - -Section IffSpec. -Variable elt: Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma in_iff m x y : E.eq x y -> (In x m <-> In y m). -Proof. now intros ->. Qed. - -Lemma mapsto_iff m x y e : E.eq x y -> (MapsTo x e m <-> MapsTo y e m). -Proof. now intros ->. Qed. - -Lemma mem_in_iff m x : In x m <-> mem x m = true. -Proof. symmetry. apply mem_spec. Qed. - -Lemma not_mem_in_iff m x : ~In x m <-> mem x m = false. -Proof. -rewrite mem_in_iff; destruct (mem x m); intuition. -Qed. - -Lemma mem_find m x : mem x m = true <-> find x m <> None. -Proof. - rewrite <- mem_in_iff. apply in_find. -Qed. - -Lemma not_mem_find m x : mem x m = false <-> find x m = None. -Proof. - rewrite <- not_mem_in_iff. apply not_in_find. -Qed. - -Lemma In_dec m x : { In x m } + { ~ In x m }. -Proof. - generalize (mem_in_iff m x). - destruct (mem x m); [left|right]; intuition. -Qed. - -Lemma find_mapsto_iff m x e : MapsTo x e m <-> find x m = Some e. -Proof. symmetry. apply find_spec. Qed. - -Lemma equal_iff m m' cmp : Equivb cmp m m' <-> equal cmp m m' = true. -Proof. symmetry. apply equal_spec. Qed. - -Lemma empty_mapsto_iff x e : MapsTo x e empty <-> False. -Proof. -rewrite <- find_spec, empty_spec. now split. -Qed. - -Lemma not_in_empty x : ~In x (@empty elt). -Proof. -intros (e,H). revert H. apply empty_mapsto_iff. -Qed. - -Lemma empty_in_iff x : In x (@empty elt) <-> False. -Proof. -split; [ apply not_in_empty | destruct 1 ]. -Qed. - -Lemma is_empty_iff m : Empty m <-> is_empty m = true. -Proof. split; [apply is_empty_1 | apply is_empty_2 ]. Qed. - -Lemma add_mapsto_iff m x y e e' : - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ - (~E.eq x y /\ MapsTo y e' m). -Proof. -split. -- intros H. destruct (E.eq_dec x y); [left|right]; split; trivial. - + symmetry. apply (mapsto_fun H); auto with map. - + now apply add_3 with x e. -- destruct 1 as [(H,H')|(H,H')]; subst; auto with map. -Qed. - -Lemma add_mapsto_new m x y e e' : ~In x m -> - MapsTo y e' (add x e m) <-> (E.eq x y /\ e=e') \/ MapsTo y e' m. -Proof. - intros. - rewrite add_mapsto_iff. intuition. - right; split; trivial. contradict H. exists e'. now rewrite H. -Qed. - -Lemma in_add m x y e : In y m -> In y (add x e m). -Proof. - destruct (E.eq_dec x y) as [<-|H']. - - now rewrite !in_find, add_spec1. - - now rewrite !in_find, add_spec2. -Qed. - -Lemma add_in_iff m x y e : In y (add x e m) <-> E.eq x y \/ In y m. -Proof. -split. -- intros H. destruct (E.eq_dec x y); [now left|right]. - rewrite in_find, add_spec2 in H; trivial. now apply in_find. -- intros [<-|H]. - + exists e. now apply add_1. - + now apply in_add. -Qed. - -Lemma add_neq_mapsto_iff m x y e e' : - ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma add_neq_in_iff m x y e : - ~ E.eq x y -> (In y (add x e m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- now apply add_3 with x e. -- now apply add_2. -Qed. - -Lemma remove_mapsto_iff m x y e : - MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. -split; [split|destruct 1]. -- intro E. revert H. now rewrite <-E, <- find_spec, remove_spec1. -- now apply remove_3 with x. -- now apply remove_2. -Qed. - -Lemma remove_in_iff m x y : In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. -unfold In; split; [ intros (e,H) | intros (E,(e,H)) ]. -- apply remove_mapsto_iff in H. destruct H; split; trivial. - now exists e. -- exists e. now apply remove_2. -Qed. - -Lemma remove_neq_mapsto_iff : forall m x y e, - ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma remove_neq_in_iff : forall m x y, - ~ E.eq x y -> (In y (remove x m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- now apply remove_3 with x. -- now apply remove_2. -Qed. - -Lemma bindings_mapsto_iff m x e : - MapsTo x e m <-> InA eq_key_elt (x,e) (bindings m). -Proof. symmetry. apply bindings_spec1. Qed. - -Lemma bindings_in_iff m x : - In x m <-> exists e, InA eq_key_elt (x,e) (bindings m). -Proof. -unfold In; split; intros (e,H); exists e; now apply bindings_spec1. -Qed. - -End IffSpec. - -Lemma map_mapsto_iff {elt elt'} m x b (f : elt -> elt') : - MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. -Proof. -rewrite <-find_spec, map_spec. setoid_rewrite <- find_spec. -destruct (find x m); simpl; split. -- injection 1. now exists e. -- intros (a,(->,H)). now injection H as ->. -- discriminate. -- intros (a,(_,H)); discriminate. -Qed. - -Lemma map_in_iff {elt elt'} m x (f : elt -> elt') : - In x (map f m) <-> In x m. -Proof. -rewrite !in_find, map_spec. apply option_map_some. -Qed. - -Lemma mapi_in_iff {elt elt'} m x (f:key->elt->elt') : - In x (mapi f m) <-> In x m. -Proof. -rewrite !in_find. destruct (mapi_spec f m x) as (y,(_,->)). -apply option_map_some. -Qed. - -(** Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) - -Lemma mapi_inv {elt elt'} m x b (f : key -> elt -> elt') : - MapsTo x b (mapi f m) -> - exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. -Proof. -rewrite <- find_spec. setoid_rewrite <- find_spec. -destruct (mapi_spec f m x) as (y,(E,->)). -destruct (find x m); simpl. -- injection 1 as <-. now exists e, y. -- discriminate. -Qed. - -Lemma mapi_spec' {elt elt'} (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - forall m x, - find x (mapi f m) = option_map (f x) (find x m). -Proof. - intros. destruct (mapi_spec f m x) as (y,(Hy,->)). - destruct (find x m); simpl; trivial. - now rewrite Hy. -Qed. - -Lemma mapi_1bis {elt elt'} m x e (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - MapsTo x e m -> MapsTo x (f x e) (mapi f m). -Proof. -intros. destruct (mapi_1 f H0) as (y,(->,H2)). trivial. -Qed. - -Lemma mapi_mapsto_iff {elt elt'} m x b (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). -Proof. -rewrite <-find_spec. setoid_rewrite <-find_spec. -intros Pr. rewrite mapi_spec' by trivial. -destruct (find x m); simpl; split. -- injection 1 as <-. now exists e. -- intros (a,(->,H)). now injection H as <-. -- discriminate. -- intros (a,(_,H)). discriminate. -Qed. - -(** Things are even worse for [merge] : we don't try to state any - equivalence, see instead boolean results below. *) - -(** Useful tactic for simplifying expressions like - [In y (add x e (remove z m))] *) - -Ltac map_iff := - repeat (progress ( - rewrite add_mapsto_iff || rewrite add_in_iff || - rewrite remove_mapsto_iff || rewrite remove_in_iff || - rewrite empty_mapsto_iff || rewrite empty_in_iff || - rewrite map_mapsto_iff || rewrite map_in_iff || - rewrite mapi_in_iff)). - -(** ** Specifications written using boolean predicates *) - -Section BoolSpec. - -Lemma mem_find_b {elt}(m:t elt)(x:key) : - mem x m = if find x m then true else false. -Proof. -apply eq_bool_alt. rewrite mem_find. destruct (find x m). -- now split. -- split; (discriminate || now destruct 1). -Qed. - -Variable elt elt' elt'' : Type. -Implicit Types m : t elt. -Implicit Types x y z : key. -Implicit Types e : elt. - -Lemma mem_b m x y : E.eq x y -> mem x m = mem y m. -Proof. now intros ->. Qed. - -Lemma find_o m x y : E.eq x y -> find x m = find y m. -Proof. now intros ->. Qed. - -Lemma empty_o x : find x (@empty elt) = None. -Proof. apply empty_spec. Qed. - -Lemma empty_a x : mem x (@empty elt) = false. -Proof. apply not_mem_find. apply empty_spec. Qed. - -Lemma add_eq_o m x y e : - E.eq x y -> find y (add x e m) = Some e. -Proof. - intros <-. apply add_spec1. -Qed. - -Lemma add_neq_o m x y e : - ~ E.eq x y -> find y (add x e m) = find y m. -Proof. apply add_spec2. Qed. -Hint Resolve add_neq_o : map. - -Lemma add_o m x y e : - find y (add x e m) = if E.eq_dec x y then Some e else find y m. -Proof. -destruct (E.eq_dec x y); auto with map. -Qed. - -Lemma add_eq_b m x y e : - E.eq x y -> mem y (add x e m) = true. -Proof. -intros <-. apply mem_spec, add_in_iff. now left. -Qed. - -Lemma add_neq_b m x y e : - ~E.eq x y -> mem y (add x e m) = mem y m. -Proof. -intros. now rewrite !mem_find_b, add_neq_o. -Qed. - -Lemma add_b m x y e : - mem y (add x e m) = eqb x y || mem y m. -Proof. -rewrite !mem_find_b, add_o. unfold eqb. -now destruct (E.eq_dec x y). -Qed. - -Lemma remove_eq_o m x y : - E.eq x y -> find y (remove x m) = None. -Proof. intros ->. apply remove_spec1. Qed. - -Lemma remove_neq_o m x y : - ~ E.eq x y -> find y (remove x m) = find y m. -Proof. apply remove_spec2. Qed. - -Hint Resolve remove_eq_o remove_neq_o : map. - -Lemma remove_o m x y : - find y (remove x m) = if E.eq_dec x y then None else find y m. -Proof. -destruct (E.eq_dec x y); auto with map. -Qed. - -Lemma remove_eq_b m x y : - E.eq x y -> mem y (remove x m) = false. -Proof. -intros <-. now rewrite mem_find_b, remove_eq_o. -Qed. - -Lemma remove_neq_b m x y : - ~ E.eq x y -> mem y (remove x m) = mem y m. -Proof. -intros. now rewrite !mem_find_b, remove_neq_o. -Qed. - -Lemma remove_b m x y : - mem y (remove x m) = negb (eqb x y) && mem y m. -Proof. -rewrite !mem_find_b, remove_o; unfold eqb. -now destruct (E.eq_dec x y). -Qed. - -Lemma map_o m x (f:elt->elt') : - find x (map f m) = option_map f (find x m). -Proof. apply map_spec. Qed. - -Lemma map_b m x (f:elt->elt') : - mem x (map f m) = mem x m. -Proof. -rewrite !mem_find_b, map_o. now destruct (find x m). -Qed. - -Lemma mapi_b m x (f:key->elt->elt') : - mem x (mapi f m) = mem x m. -Proof. -apply eq_bool_alt; rewrite !mem_spec. apply mapi_in_iff. -Qed. - -Lemma mapi_o m x (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - find x (mapi f m) = option_map (f x) (find x m). -Proof. intros; now apply mapi_spec'. Qed. - -Lemma merge_spec1' (f:key->option elt->option elt'->option elt'') : - Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> - forall (m:t elt)(m':t elt') x, - In x m \/ In x m' -> - find x (merge f m m') = f x (find x m) (find x m'). -Proof. - intros Hf m m' x H. - now destruct (merge_spec1 f H) as (y,(->,->)). -Qed. - -Lemma merge_spec1_none (f:key->option elt->option elt'->option elt'') : - (forall x, f x None None = None) -> - forall (m: t elt)(m': t elt') x, - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). -Proof. -intros Hf m m' x. -destruct (find x m) as [e|] eqn:Hm. -- assert (H : In x m \/ In x m') by (left; exists e; now apply find_spec). - destruct (merge_spec1 f H) as (y,(Hy,->)). - exists y; split; trivial. now rewrite Hm. -- destruct (find x m') as [e|] eqn:Hm'. - + assert (H : In x m \/ In x m') by (right; exists e; now apply find_spec). - destruct (merge_spec1 f H) as (y,(Hy,->)). - exists y; split; trivial. now rewrite Hm, Hm'. - + exists x. split. reflexivity. rewrite Hf. - apply not_in_find. intro H. - apply merge_spec2 in H. apply not_in_find in Hm. apply not_in_find in Hm'. - intuition. -Qed. - -Lemma merge_spec1'_none (f:key->option elt->option elt'->option elt'') : - Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> - (forall x, f x None None = None) -> - forall (m: t elt)(m': t elt') x, - find x (merge f m m') = f x (find x m) (find x m'). -Proof. - intros Hf Hf' m m' x. - now destruct (merge_spec1_none Hf' m m' x) as (y,(->,->)). -Qed. - -Lemma bindings_o : forall m x, - find x m = findA (eqb x) (bindings m). -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, bindings_mapsto_iff. -unfold eqb. -rewrite <- findA_NoDupA; dintuition; try apply bindings_3w; eauto. -Qed. - -Lemma bindings_b : forall m x, - mem x m = existsb (fun p => eqb x (fst p)) (bindings m). -Proof. -intros. -apply eq_bool_alt. -rewrite mem_spec, bindings_in_iff, existsb_exists. -split. -- intros (e,H). - rewrite InA_alt in H. - destruct H as ((k,e'),((H1,H2),H')); simpl in *; subst e'. - exists (k, e); split; trivial. simpl. now apply eqb_eq. -- intros ((k,e),(H,H')); simpl in *. apply eqb_eq in H'. - exists e. rewrite InA_alt. exists (k,e). now repeat split. -Qed. - -End BoolSpec. - -Section Equalities. -Variable elt:Type. - -(** A few basic equalities *) - -Lemma eq_empty (m: t elt) : m == empty <-> is_empty m = true. -Proof. - unfold Equal. rewrite is_empty_spec. now setoid_rewrite empty_spec. -Qed. - -Lemma add_id (m: t elt) x e : add x e m == m <-> find x m = Some e. -Proof. - split. - - intros H. rewrite <- (H x). apply add_spec1. - - intros H y. rewrite !add_o. now destruct E.eq_dec as [<-|E]. -Qed. - -Lemma add_add_1 (m: t elt) x e : - add x e (add x e m) == add x e m. -Proof. - intros y. rewrite !add_o. destruct E.eq_dec; auto. -Qed. - -Lemma add_add_2 (m: t elt) x x' e e' : - ~E.eq x x' -> add x e (add x' e' m) == add x' e' (add x e m). -Proof. - intros H y. rewrite !add_o. - do 2 destruct E.eq_dec; auto. - elim H. now transitivity y. -Qed. - -Lemma remove_id (m: t elt) x : remove x m == m <-> ~In x m. -Proof. - rewrite not_in_find. split. - - intros H. rewrite <- (H x). apply remove_spec1. - - intros H y. rewrite !remove_o. now destruct E.eq_dec as [<-|E]. -Qed. - -Lemma remove_remove_1 (m: t elt) x : - remove x (remove x m) == remove x m. -Proof. - intros y. rewrite !remove_o. destruct E.eq_dec; auto. -Qed. - -Lemma remove_remove_2 (m: t elt) x x' : - remove x (remove x' m) == remove x' (remove x m). -Proof. - intros y. rewrite !remove_o. do 2 destruct E.eq_dec; auto. -Qed. - -Lemma remove_add_1 (m: t elt) x e : - remove x (add x e m) == remove x m. -Proof. - intro y. rewrite !remove_o, !add_o. now destruct E.eq_dec. -Qed. - -Lemma remove_add_2 (m: t elt) x x' e : - ~E.eq x x' -> remove x' (add x e m) == add x e (remove x' m). -Proof. - intros H y. rewrite !remove_o, !add_o. - do 2 destruct E.eq_dec; auto. - - elim H; now transitivity y. - - symmetry. now apply remove_eq_o. - - symmetry. now apply remove_neq_o. -Qed. - -Lemma add_remove_1 (m: t elt) x e : - add x e (remove x m) == add x e m. -Proof. - intro y. rewrite !add_o, !remove_o. now destruct E.eq_dec. -Qed. - -(** Another characterisation of [Equal] *) - -Lemma Equal_mapsto_iff : forall m1 m2 : t elt, - m1 == m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). -Proof. -intros m1 m2. split; [intros Heq k e|intros Hiff]. -rewrite 2 find_mapsto_iff, Heq. split; auto. -intro k. rewrite eq_option_alt. intro e. -rewrite <- 2 find_mapsto_iff; auto. -Qed. - -(** * Relations between [Equal], [Equiv] and [Equivb]. *) - -(** First, [Equal] is [Equiv] with Leibniz on elements. *) - -Lemma Equal_Equiv : forall (m m' : t elt), - m == m' <-> Equiv Logic.eq m m'. -Proof. -intros. rewrite Equal_mapsto_iff. split; intros. -- split. - + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. - + intros; apply mapsto_fun with m k; auto; rewrite H; auto. -- split; intros H'. - + destruct H. - assert (Hin : In k m') by (rewrite <- H; exists e; auto). - destruct Hin as (e',He'). - rewrite (H0 k e e'); auto. - + destruct H. - assert (Hin : In k m) by (rewrite H; exists e; auto). - destruct Hin as (e',He'). - rewrite <- (H0 k e' e); auto. -Qed. - -(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] - are related. *) - -Section Cmp. -Variable eq_elt : elt->elt->Prop. -Variable cmp : elt->elt->bool. - -Definition compat_cmp := - forall e e', cmp e e' = true <-> eq_elt e e'. - -Lemma Equiv_Equivb : compat_cmp -> - forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. -Proof. - unfold Equivb, Equiv, Cmp; intuition. - red in H; rewrite H; eauto. - red in H; rewrite <-H; eauto. -Qed. -End Cmp. - -(** Composition of the two last results: relation between [Equal] - and [Equivb]. *) - -Lemma Equal_Equivb : forall cmp, - (forall e e', cmp e e' = true <-> e = e') -> - forall (m m':t elt), m == m' <-> Equivb cmp m m'. -Proof. - intros; rewrite Equal_Equiv. - apply Equiv_Equivb; auto. -Qed. - -Lemma Equal_Equivb_eqdec : - forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), - let cmp := fun e e' => if eq_elt_dec e e' then true else false in - forall (m m':t elt), m == m' <-> Equivb cmp m m'. -Proof. -intros; apply Equal_Equivb. -unfold cmp; clear cmp; intros. -destruct eq_elt_dec; now intuition. -Qed. - -End Equalities. - -(** * Results about [fold], [bindings], induction principles... *) - -Section Elt. - Variable elt:Type. - - Definition Add x (e:elt) m m' := m' == (add x e m). - - Notation eqke := (@eq_key_elt elt). - Notation eqk := (@eq_key elt). - - Instance eqk_equiv : Equivalence eqk. - Proof. unfold eq_key. destruct E.eq_equiv. constructor; eauto. Qed. - - Instance eqke_equiv : Equivalence eqke. - Proof. - unfold eq_key_elt; split; repeat red; intuition; simpl in *; - etransitivity; eauto. - Qed. - - (** Complements about InA, NoDupA and findA *) - - Lemma InA_eqke_eqk k k' e e' l : - E.eq k k' -> InA eqke (k,e) l -> InA eqk (k',e') l. - Proof. - intros Hk. rewrite 2 InA_alt. - intros ((k'',e'') & (Hk'',He'') & H); simpl in *; subst e''. - exists (k'',e); split; auto. red; simpl. now transitivity k. - Qed. - - Lemma NoDupA_incl {A} (R R':relation A) : - (forall x y, R x y -> R' x y) -> - forall l, NoDupA R' l -> NoDupA R l. - Proof. - intros Incl. - induction 1 as [ | a l E _ IH ]; constructor; auto. - contradict E. revert E. rewrite 2 InA_alt. firstorder. - Qed. - - Lemma NoDupA_eqk_eqke l : NoDupA eqk l -> NoDupA eqke l. - Proof. - apply NoDupA_incl. now destruct 1. - Qed. - - Lemma findA_rev l k : NoDupA eqk l -> - findA (eqb k) l = findA (eqb k) (rev l). - Proof. - intros H. apply eq_option_alt. intros e. unfold eqb. - rewrite <- !findA_NoDupA, InA_rev; eauto with map. reflexivity. - change (NoDupA eqk (rev l)). apply NoDupA_rev; auto using eqk_equiv. - Qed. - - (** * Bindings *) - - Lemma bindings_Empty (m:t elt) : Empty m <-> bindings m = nil. - Proof. - unfold Empty. split; intros H. - - assert (H' : forall a, ~ List.In a (bindings m)). - { intros (k,e) H'. apply (H k e). - rewrite bindings_mapsto_iff, InA_alt. - exists (k,e); repeat split; auto with map. } - destruct (bindings m) as [|p l]; trivial. - destruct (H' p); simpl; auto. - - intros x e. rewrite bindings_mapsto_iff, InA_alt. - rewrite H. now intros (y,(E,H')). - Qed. - - Lemma bindings_empty : bindings (@empty elt) = nil. - Proof. - rewrite <-bindings_Empty; apply empty_1. - Qed. - - (** * Conversions between maps and association lists. *) - - Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := - fun p => f (fst p) (snd p). - - Definition of_list := - List.fold_right (uncurry (@add _)) (@empty elt). - - Definition to_list := bindings. - - Lemma of_list_1 : forall l k e, - NoDupA eqk l -> - (MapsTo k e (of_list l) <-> InA eqke (k,e) l). - Proof. - induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. - - rewrite empty_mapsto_iff, InA_nil; intuition. - - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k e Hnodup'); clear Hnodup'. - rewrite add_mapsto_iff, InA_cons, <- IH. - unfold eq_key_elt at 1; simpl. - split; destruct 1 as [H|H]; try (intuition;fail). - destruct (E.eq_dec k k'); [left|right]; split; auto with map. - contradict Hnotin. - apply InA_eqke_eqk with k e; intuition. - Qed. - - Lemma of_list_1b : forall l k, - NoDupA eqk l -> - find k (of_list l) = findA (eqb k) l. - Proof. - induction l as [|(k',e') l IH]; simpl; intros k Hnodup. - apply empty_o. - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k Hnodup'); clear Hnodup'. - rewrite add_o, IH, eqb_sym. unfold eqb; now destruct E.eq_dec. - Qed. - - Lemma of_list_2 : forall l, NoDupA eqk l -> - equivlistA eqke l (to_list (of_list l)). - Proof. - intros l Hnodup (k,e). - rewrite <- bindings_mapsto_iff, of_list_1; intuition. - Qed. - - Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. - Proof. - intros s k. - rewrite of_list_1b, bindings_o; auto. - apply bindings_3w. - Qed. - - (** * Fold *) - - (** Alternative specification via [fold_right] *) - - Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : - fold f m i = List.fold_right (uncurry f) i (rev (bindings m)). - Proof. - rewrite fold_1. symmetry. apply fold_left_rev_right. - Qed. - - (** ** Induction principles about fold contributed by S. Lescuyer *) - - (** In the following lemma, the step hypothesis is deliberately restricted - to the precise map m we are considering. *) - - Lemma fold_rec : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m, Empty m -> P m i) -> - (forall k e a m' m'', MapsTo k e m -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Hempty Hstep. - rewrite fold_spec_right. - set (F:=uncurry f). - set (l:=rev (bindings m)). - assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). - { - intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. - revert H; unfold l; rewrite InA_rev, bindings_mapsto_iff; auto with *. } - assert (Hdup : NoDupA eqk l). - { unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. - apply bindings_3w. } - assert (Hsame : forall k, find k m = findA (eqb k) l). - { intros k. unfold l. rewrite bindings_o, findA_rev; auto. - apply bindings_3w. } - clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. - - (* empty *) - intros m Hsame; simpl. - apply Hempty. intros k e. - rewrite find_mapsto_iff, Hsame; simpl; discriminate. - - (* step *) - intros m Hsame; destruct a as (k,e); simpl. - apply Hstep' with (of_list l); auto. - + rewrite InA_cons; left; red; auto with map. - + inversion_clear Hdup. contradict H. destruct H as (e',He'). - apply InA_eqke_eqk with k e'; auto with map. - rewrite <- of_list_1; auto. - + intro k'. rewrite Hsame, add_o, of_list_1b. simpl. - rewrite eqb_sym. unfold eqb. now destruct E.eq_dec. - inversion_clear Hdup; auto with map. - + apply IHl. - * intros; eapply Hstep'; eauto. - * inversion_clear Hdup; auto. - * intros; apply of_list_1b. inversion_clear Hdup; auto. - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this - case, [P] must be compatible with equality of sets *) - - Theorem fold_rec_bis : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - (P empty i) -> - (forall k e a m', MapsTo k e m -> ~In k m' -> - P m' a -> P (add k e m') (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Pmorphism Pempty Pstep. - apply fold_rec; intros. - apply Pmorphism with empty; auto. intro k. rewrite empty_o. - case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. - intro H'; elim (H k e'); auto. - apply Pmorphism with (add k e m'); try intro; auto. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), - P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> - P (fold f m i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : - the step hypothesis must here be applicable anywhere. - At the same time, it looks more like an induction principle, - and hence can be easier to use. *) - - Lemma fold_rec_weak : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - P empty i -> - (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> - forall m, P m (fold f m i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) - (m : t elt), - R i j -> - (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> - R (fold f m i) (fold g m j). - Proof. - intros A B R f g i j m Rempty Rstep. - rewrite 2 fold_spec_right. set (l:=rev (bindings m)). - assert (Rstep' : forall k e a b, InA eqke (k,e) l -> - R a b -> R (f k e a) (g k e b)). - { intros; apply Rstep; auto. - rewrite bindings_mapsto_iff, <- InA_rev; auto with map. } - clearbody l; clear Rstep m. - induction l; simpl; auto. - apply Rstep'; auto. - destruct a; simpl; rewrite InA_cons; left; red; auto with map. - Qed. - - (** From the induction principle on [fold], we can deduce some general - induction principles on maps. *) - - Lemma map_induction : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - Lemma map_induction_bis : - forall P : t elt -> Type, - (forall m m', Equal m m' -> P m -> P m') -> - P empty -> - (forall x e m, ~In x m -> P m -> P (add x e m)) -> - forall m, P m. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m empty) m. - Proof. - intros. - apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. - intros m' Heq k'. - rewrite empty_o. - case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. - intro; elim (Heq k' e'); auto. - intros k e a m' m'' _ _ Hadd Heq k'. - red in Heq. rewrite Hadd, 2 add_o, Heq; auto. - Qed. - - Section Fold_More. - - (** ** Additional properties of fold *) - - (** When a function [f] is compatible and allows transpositions, we can - compute [fold f] in any order. *) - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - - Lemma fold_Empty (f:key->elt->A->A) : - forall m i, Empty m -> eqA (fold f m i) i. - Proof. - intros. apply fold_rec_nodep with (P:=fun a => eqA a i). - reflexivity. - intros. elim (H k e); auto. - Qed. - - Lemma fold_init (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). - Proof. - intros Hf m i i' Hi. apply fold_rel with (R:=eqA); auto. - intros. now apply Hf. - Qed. - - (** Transpositions of f (a.k.a diamond property). - Could we swap two sequential calls to f, i.e. do we have: - - f k e (f k' e' a) == f k' e' (f k e a) - - First, we do no need this equation for all keys, but only - when k and k' aren't equal, as suggested by Pierre Castéran. - Think for instance of [f] being [M.add] : in general, we don't have - [M.add k e (M.add k e' m) == M.add k e' (M.add k e m)]. - Fortunately, we will never encounter this situation during a real - [fold], since the keys received by this [fold] are unique. - NB: without this condition, this condition would be - [SetoidList.transpose2]. - - Secondly, instead of the equation above, we now use a statement - with more basic equalities, allowing to prove [fold_commutes] even - when [f] isn't a morphism. - NB: When [f] is a morphism, [Diamond f] gives back the equation above. -*) - - Definition Diamond (f:key->elt->A->A) := - forall k k' e e' a b b', ~E.eq k k' -> - eqA (f k e a) b -> eqA (f k' e' a) b' -> eqA (f k e b') (f k' e' b). - - Lemma fold_commutes (f:key->elt->A->A) : - Diamond f -> - forall i m k e, ~In k m -> - eqA (fold f m (f k e i)) (f k e (fold f m i)). - Proof. - intros Hf i m k e H. - apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. - - reflexivity. - - intros k' e' b a Hm E. - apply Hf with a; try easy. - contradict H; rewrite <- H. now exists e'. - Qed. - - Hint Resolve NoDupA_eqk_eqke NoDupA_rev bindings_3w : map. - - Lemma fold_Proper (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - Proper (Equal==>eqA==>eqA) (fold f). - Proof. - intros Hf Hf' m1 m2 Hm i j Hi. - rewrite 2 fold_spec_right. - assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). - assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). - apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke) - ; auto with *. - - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *. now apply Hf. - - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto with map. - - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto. - rewrite h'. eapply Hf'; now eauto. - - rewrite <- NoDupA_altdef; auto. - - intros (k,e). - rewrite 2 InA_rev, <- 2 bindings_mapsto_iff, 2 find_mapsto_iff, Hm; - auto with *. - Qed. - - Lemma fold_Equal (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m1 m2 i, - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros. now apply fold_Proper. - Qed. - - Lemma fold_Add (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> - eqA (fold f m2 i) (f k e (fold f m1 i)). - Proof. - intros Hf Hf' m1 m2 k e i Hm1 Hm2. - rewrite 2 fold_spec_right. - set (f':=uncurry f). - change (f k e (fold_right f' i (rev (bindings m1)))) - with (f' (k,e) (fold_right f' i (rev (bindings m1)))). - assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). - assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). - apply fold_right_add_restr with - (R:=complement eqk)(eqA:=eqke); auto with *. - - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. now apply Hf. - - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto with map. - - intros (k1,e1) (k2,e2) z1 z2; unfold eq_key, f', uncurry; simpl. - eapply Hf'; now eauto. - - rewrite <- NoDupA_altdef; auto. - - rewrite InA_rev, <- bindings_mapsto_iff by (auto with * ). firstorder. - - intros (a,b). - rewrite InA_cons, 2 InA_rev, <- 2 bindings_mapsto_iff, - 2 find_mapsto_iff by (auto with * ). - unfold eq_key_elt; simpl. - rewrite Hm2, !find_spec, add_mapsto_new; intuition. - Qed. - - Lemma fold_add (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m k e i, ~In k m -> - eqA (fold f (add k e m) i) (f k e (fold f m i)). - Proof. - intros. now apply fold_Add. - Qed. - - End Fold_More. - - (** * Cardinal *) - - Lemma cardinal_fold (m : t elt) : - cardinal m = fold (fun _ _ => S) m 0. - Proof. - rewrite cardinal_1, fold_1. - symmetry; apply fold_left_length; auto. - Qed. - - Lemma cardinal_Empty : forall m : t elt, - Empty m <-> cardinal m = 0. - Proof. - intros. - rewrite cardinal_1, bindings_Empty. - destruct (bindings m); intuition; discriminate. - Qed. - - Lemma Equal_cardinal (m m' : t elt) : - Equal m m' -> cardinal m = cardinal m'. - Proof. - intro. rewrite 2 cardinal_fold. - apply fold_Equal with (eqA:=eq); try congruence; auto with map. - Qed. - - Lemma cardinal_0 (m : t elt) : Empty m -> cardinal m = 0. - Proof. - intros; rewrite <- cardinal_Empty; auto. - Qed. - - Lemma cardinal_S m m' x e : - ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). - Proof. - intros. rewrite 2 cardinal_fold. - change S with ((fun _ _ => S) x e). - apply fold_Add with (eqA:=eq); try congruence; auto with map. - Qed. - - Lemma cardinal_inv_1 : forall m : t elt, - cardinal m = 0 -> Empty m. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - Hint Resolve cardinal_inv_1 : map. - - Lemma cardinal_inv_2 : - forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros; rewrite M.cardinal_spec in *. - generalize (bindings_mapsto_iff m). - destruct (bindings m); try discriminate. - exists p; auto. - rewrite H0; destruct p; simpl; auto. - constructor; red; auto with map. - Qed. - - Lemma cardinal_inv_2b : - forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros. - generalize (@cardinal_inv_2 m); destruct cardinal. - elim H;auto. - eauto. - Qed. - - Lemma not_empty_mapsto (m : t elt) : - ~Empty m -> exists k e, MapsTo k e m. - Proof. - intro. - destruct (@cardinal_inv_2b m) as ((k,e),H'). - contradict H. now apply cardinal_inv_1. - exists k; now exists e. - Qed. - - Lemma not_empty_in (m:t elt) : - ~Empty m -> exists k, In k m. - Proof. - intro. destruct (not_empty_mapsto H) as (k,Hk). - now exists k. - Qed. - - (** * Additional notions over maps *) - - Definition Disjoint (m m' : t elt) := - forall k, ~(In k m /\ In k m'). - - Definition Partition (m m1 m2 : t elt) := - Disjoint m1 m2 /\ - (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). - - (** * Emulation of some functions lacking in the interface *) - - Definition filter (f : key -> elt -> bool)(m : t elt) := - fold (fun k e m => if f k e then add k e m else m) m empty. - - Definition for_all (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then b else false) m true. - - Definition exists_ (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then true else b) m false. - - Definition partition (f : key -> elt -> bool)(m : t elt) := - (filter f m, filter (fun k e => negb (f k e)) m). - - (** [update] adds to [m1] all the bindings of [m2]. It can be seen as - an [union] operator which gives priority to its 2nd argument - in case of binding conflit. *) - - Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. - - (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. - It can be seen as an [inter] operator, with priority to its 1st argument - in case of binding conflit. *) - - Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. - - (** [diff] erases from [m1] all bindings whose key is in [m2]. *) - - Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. - - (** Properties of these abbreviations *) - - Lemma filter_iff (f : key -> elt -> bool) : - Proper (E.eq==>eq==>eq) f -> - forall m k e, - MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. - Proof. - unfold filter. - set (f':=fun k e m => if f k e then add k e m else m). - intros Hf m. pattern m, (fold f' m empty). apply fold_rec. - - - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. - elim (Hm' k e); auto. - - - intros k e acc m1 m2 Hke Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. - unfold f'; simpl. - rewrite add_mapsto_new by trivial. - case_eq (f k e); intros Hfke; simpl; - rewrite ?add_mapsto_iff, IH; clear IH; intuition. - + rewrite <- Hfke; apply Hf; auto with map. - + right. repeat split; trivial. contradict Hn. rewrite Hn. now exists e'. - + assert (f k e = f k' e') by (apply Hf; auto). congruence. - Qed. - - Lemma for_all_filter f m : - for_all f m = is_empty (filter (fun k e => negb (f k e)) m). - Proof. - unfold for_all, filter. - eapply fold_rel with (R:=fun x y => x = is_empty y). - - symmetry. apply is_empty_iff. apply empty_1. - - intros; subst. destruct (f k e); simpl; trivial. - symmetry. apply not_true_is_false. rewrite is_empty_spec. - intros H'. specialize (H' k). now rewrite add_spec1 in H'. - Qed. - - Lemma exists_filter f m : - exists_ f m = negb (is_empty (filter f m)). - Proof. - unfold for_all, filter. - eapply fold_rel with (R:=fun x y => x = negb (is_empty y)). - - symmetry. rewrite negb_false_iff. apply is_empty_iff. apply empty_1. - - intros; subst. destruct (f k e); simpl; trivial. - symmetry. rewrite negb_true_iff. apply not_true_is_false. - rewrite is_empty_spec. - intros H'. specialize (H' k). now rewrite add_spec1 in H'. - Qed. - - Lemma for_all_iff f m : - Proper (E.eq==>eq==>eq) f -> - (for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true)). - Proof. - intros Hf. - rewrite for_all_filter. - rewrite <- is_empty_iff. unfold Empty. - split; intros H k e; specialize (H k e); - rewrite filter_iff in * by solve_proper; intuition. - - destruct (f k e); auto. - - now rewrite H0 in H2. - Qed. - - Lemma exists_iff f m : - Proper (E.eq==>eq==>eq) f -> - (exists_ f m = true <-> - (exists k e, MapsTo k e m /\ f k e = true)). - Proof. - intros Hf. - rewrite exists_filter. rewrite negb_true_iff. - rewrite <- not_true_iff_false, <- is_empty_iff. - split. - - intros H. apply not_empty_mapsto in H. now setoid_rewrite filter_iff in H. - - unfold Empty. setoid_rewrite filter_iff; trivial. firstorder. - Qed. - - Lemma Disjoint_alt : forall m m', - Disjoint m m' <-> - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). - Proof. - unfold Disjoint; split. - intros H k v v' H1 H2. - apply H with k; split. - exists v; trivial. - exists v'; trivial. - intros H k ((v,Hv),(v',Hv')). - eapply H; eauto. - Qed. - - Section Partition. - Variable f : key -> elt -> bool. - Hypothesis Hf : Proper (E.eq==>eq==>eq) f. - - Lemma partition_iff_1 : forall m m1 k e, - m1 = fst (partition f m) -> - (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). - Proof. - unfold partition; simpl; intros. subst m1. - apply filter_iff; auto. - Qed. - - Lemma partition_iff_2 : forall m m2 k e, - m2 = snd (partition f m) -> - (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). - Proof. - unfold partition; simpl; intros. subst m2. - rewrite filter_iff. - split; intros (H,H'); split; auto. - destruct (f k e); simpl in *; auto. - rewrite H'; auto. - repeat red; intros. f_equal. apply Hf; auto. - Qed. - - Lemma partition_Partition : forall m m1 m2, - partition f m = (m1,m2) -> Partition m m1 m2. - Proof. - intros. split. - rewrite Disjoint_alt. intros k e e'. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - intros (U,V) (W,Z). rewrite <- (mapsto_fun U W) in Z; congruence. - intros k e. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - destruct (f k e); intuition. - Qed. - - End Partition. - - Lemma Partition_In : forall m m1 m2 k, - Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. - Proof. - intros m m1 m2 k Hm Hk. - destruct (In_dec m1 k) as [H|H]; [left|right]; auto. - destruct Hm as (Hm,Hm'). - destruct Hk as (e,He); rewrite Hm' in He; destruct He. - elim H; exists e; auto. - exists e; auto. - Defined. - - Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. - Proof. - intros m1 m2 H k (H1,H2). elim (H k); auto. - Qed. - - Lemma Partition_sym : forall m m1 m2, - Partition m m1 m2 -> Partition m m2 m1. - Proof. - intros m m1 m2 (H,H'); split. - apply Disjoint_sym; auto. - intros; rewrite H'; intuition. - Qed. - - Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> - (Empty m <-> (Empty m1 /\ Empty m2)). - Proof. - intros m m1 m2 (Hdisj,Heq). split. - intro He. - split; intros k e Hke; elim (He k e); rewrite Heq; auto. - intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. - elim (He1 k e); auto. - elim (He2 k e); auto. - Qed. - - Lemma Partition_Add : - forall m m' x e , ~In x m -> Add x e m m' -> - forall m1 m2, Partition m' m1 m2 -> - exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ - Add x e m3 m2 /\ Partition m m1 m3). - Proof. - unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). - assert (Heq : Equal m (remove x m')). - { change (Equal m' (add x e m)) in Hadd. rewrite Hadd. - intro k. rewrite remove_o, add_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He, <- not_find_in_iff; auto. } - assert (H : MapsTo x e m'). - { change (Equal m' (add x e m)) in Hadd; rewrite Hadd. - apply add_1; auto with map. } - rewrite Hor in H; destruct H. - - - (* first case : x in m1 *) - exists (remove x m1); left. split; [|split]. - + (* add *) - change (Equal m1 (add x e (remove x m1))). - intro k. - rewrite add_o, remove_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H1; destruct H1; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e|exists e']; auto. - apply MapsTo_1 with k'; auto with map. - - - (* second case : x in m2 *) - exists (remove x m2); right. split; [|split]. - + (* add *) - change (Equal m2 (add x e (remove x m2))). - intro k. - rewrite add_o, remove_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H2; destruct H2; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e'|exists e]; auto. - apply MapsTo_1 with k'; auto with map. - Qed. - - Lemma Partition_fold : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond eqA f -> - forall m m1 m2 i, - Partition m m1 m2 -> - eqA (fold f m i) (fold f m1 (fold f m2 i)). - Proof. - intros A eqA st f Comp Tra. - induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. - - - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. - rewrite (Partition_Empty Hp) in Hm. destruct Hm. - rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. - - - intros m1 m2 i Hp. - destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). - + (* fst case: m3 is (k,e)::m1 *) - assert (~In k m3). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - transitivity (f k e (fold f m i)). - apply fold_Add with (eqA:=eqA); auto. - symmetry. - transitivity (f k e (fold f m3 (fold f m2 i))). - apply fold_Add with (eqA:=eqA); auto. - apply Comp; auto with map. - symmetry; apply IH; auto. - + (* snd case: m3 is (k,e)::m2 *) - assert (~In k m3). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - assert (~In k m1). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - transitivity (f k e (fold f m i)). - apply fold_Add with (eqA:=eqA); auto. - transitivity (f k e (fold f m1 (fold f m3 i))). - apply Comp; auto using IH with map. - transitivity (fold f m1 (f k e (fold f m3 i))). - symmetry. - apply fold_commutes with (eqA:=eqA); auto. - apply fold_init with (eqA:=eqA); auto. - symmetry. - apply fold_Add with (eqA:=eqA); auto. - Qed. - - Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> - cardinal m = cardinal m1 + cardinal m2. - Proof. - intros. - rewrite (cardinal_fold m), (cardinal_fold m1). - set (f:=fun (_:key)(_:elt)=>S). - setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). - rewrite <- cardinal_fold. - apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. - apply Partition_fold with (eqA:=eq); compute; auto with map. congruence. - Qed. - - Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> - let f := fun k (_:elt) => mem k m1 in - Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). - Proof. - intros m m1 m2 Hm f. - assert (Hf : Proper (E.eq==>eq==>eq) f). - intros k k' Hk e e' _; unfold f; rewrite Hk; auto. - set (m1':= fst (partition f m)). - set (m2':= snd (partition f m)). - split; rewrite Equal_mapsto_iff; intros k e. - rewrite (@partition_iff_1 f Hf m m1') by auto. - unfold f. - rewrite <- mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - exists e; auto. - elim (Hm k); split; auto; exists e; auto. - rewrite (@partition_iff_2 f Hf m m2') by auto. - unfold f. - rewrite <- not_mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - elim (Hm k); split; auto; exists e; auto. - elim H1; exists e; auto. - Qed. - - Lemma update_mapsto_iff : forall m m' k e, - MapsTo k e (update m m') <-> - (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). - Proof. - unfold update. - intros m m'. - pattern m', (fold (@add _) m' m). apply fold_rec. - - - intros m0 Hm0 k e. - assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). - intuition. - elim (Hm0 k e); auto. - - - intros k e m0 m1 m2 _ Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd. - rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. - Qed. - - Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> - { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. - Proof. - intros m m' k e H. rewrite update_mapsto_iff in H. - destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. - elim H'; exists e; auto. - Defined. - - Lemma update_in_iff : forall m m' k, - In k (update m m') <-> In k m \/ In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite update_mapsto_iff in H. - destruct H; [right|left]; exists e; intuition. - destruct (In_dec m' k) as [H|H]. - destruct H as (e,H). intros _; exists e. - rewrite update_mapsto_iff; left; auto. - destruct 1 as [H'|H']; [|elim H; auto]. - destruct H' as (e,H'). exists e. - rewrite update_mapsto_iff; right; auto. - Qed. - - Lemma diff_mapsto_iff : forall m m' k e, - MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. - Proof. - intros m m' k e. - unfold diff. - rewrite filter_iff. - intuition. - rewrite mem_1 in *; auto; discriminate. - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma diff_in_iff : forall m m' k, - In k (diff m m') <-> In k m /\ ~In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite diff_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. - Qed. - - Lemma restrict_mapsto_iff : forall m m' k e, - MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. - Proof. - intros m m' k e. - unfold restrict. - rewrite filter_iff. - intuition. - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma restrict_in_iff : forall m m' k, - In k (restrict m m') <-> In k m /\ In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite restrict_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. - Qed. - - (** specialized versions analyzing only keys (resp. bindings) *) - - Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). - Definition filter_range (f : elt -> bool) := filter (fun _ => f). - Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). - Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). - Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). - Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). - Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). - Definition partition_range (f : elt -> bool) := partition (fun _ => f). - - End Elt. - - Instance cardinal_m {elt} : Proper (Equal ==> Logic.eq) (@cardinal elt). - Proof. intros m m'. apply Equal_cardinal. Qed. - - Instance Disjoint_m {elt} : Proper (Equal ==> Equal ==> iff) (@Disjoint elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. - rewrite <- Hm1, <- Hm2; auto. - rewrite Hm1, Hm2; auto. - Qed. - - Instance Partition_m {elt} : - Proper (Equal ==> Equal ==> Equal ==> iff) (@Partition elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. - rewrite <- Hm2, <- Hm3. - split; intros (H,H'); split; auto; intros. - rewrite <- Hm1, <- Hm2, <- Hm3; auto. - rewrite Hm1, Hm2, Hm3; auto. - Qed. - -(* - Instance filter_m0 {elt} (f:key->elt->bool) : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - Proper (Equal==>Equal) (filter f). - Proof. - intros Hf m m' Hm. apply Equal_mapsto_iff. intros. - now rewrite !filter_iff, Hm. - Qed. -*) - - Instance filter_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@filter elt). - Proof. - intros f f' Hf m m' Hm. unfold filter. - rewrite 2 fold_spec_right. - set (l := rev (bindings m)). - set (l' := rev (bindings m')). - set (op := fun (f:key->elt->bool) => - uncurry (fun k e acc => if f k e then add k e acc else acc)). - change (Equal (fold_right (op f) empty l) (fold_right (op f') empty l')). - assert (Hl : NoDupA eq_key l). - { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } - assert (Hl' : NoDupA eq_key l'). - { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } - assert (H : PermutationA eq_key_elt l l'). - { apply NoDupA_equivlistA_PermutationA. - - apply eqke_equiv. - - now apply NoDupA_eqk_eqke. - - now apply NoDupA_eqk_eqke. - - intros (k,e); unfold l, l'. rewrite 2 InA_rev, 2 bindings_spec1. - rewrite Equal_mapsto_iff in Hm. apply Hm. } - destruct (PermutationA_decompose (eqke_equiv _) H) as (l0,(P,E)). - transitivity (fold_right (op f) empty l0). - - apply fold_right_equivlistA_restr2 - with (eqA:=Logic.eq)(R:=complement eq_key); auto with *. - + intros p p' <- acc acc' Hacc. - destruct p as (k,e); unfold op, uncurry; simpl. - destruct (f k e); now rewrite Hacc. - + intros (k,e) (k',e') z z'. - unfold op, complement, uncurry, eq_key; simpl. - intros Hk Hz. - destruct (f k e), (f k' e'); rewrite <- Hz; try reflexivity. - now apply add_add_2. - + apply NoDupA_incl with eq_key; trivial. intros; subst; now red. - + apply PermutationA_preserves_NoDupA with l; auto with *. - apply Permutation_PermutationA; auto with *. - apply NoDupA_incl with eq_key; trivial. intros; subst; now red. - + apply NoDupA_altdef. apply NoDupA_rev. apply eqk_equiv. - apply bindings_spec2w. - + apply PermutationA_equivlistA; auto with *. - apply Permutation_PermutationA; auto with *. - - clearbody l'. clear l Hl Hl' H P m m' Hm. - induction E. - + reflexivity. - + simpl. destruct x as (k,e), x' as (k',e'). - unfold op, uncurry at 1 3; simpl. - destruct H; simpl in *. rewrite <- (Hf _ _ H _ _ H0). - destruct (f k e); trivial. now f_equiv. - Qed. - - Instance for_all_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@for_all elt). - Proof. - intros f f' Hf m m' Hm. rewrite 2 for_all_filter. - (* Strange: we cannot rewrite Hm here... *) - f_equiv. f_equiv; trivial. - intros k k' Hk e e' He. f_equal. now apply Hf. - Qed. - - Instance exists_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@exists_ elt). - Proof. - intros f f' Hf m m' Hm. rewrite 2 exists_filter. - f_equal. now apply is_empty_m, filter_m. - Qed. - - Fact diamond_add {elt} : Diamond Equal (@add elt). - Proof. - intros k k' e e' a b b' Hk <- <-. now apply add_add_2. - Qed. - - Instance update_m {elt} : Proper (Equal ==> Equal ==> Equal) (@update elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - unfold update. - apply fold_Proper; auto using diamond_add with *. - Qed. - - Instance restrict_m {elt} : Proper (Equal==>Equal==>Equal) (@restrict elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 y. - unfold restrict. - apply eq_option_alt. intros e. - rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. - clear. intros x x' Hx e e' He. now rewrite Hx. - clear. intros x x' Hx e e' He. now rewrite Hx. - Qed. - - Instance diff_m {elt} : Proper (Equal==>Equal==>Equal) (@diff elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 y. - unfold diff. - apply eq_option_alt. intros e. - rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. - clear. intros x x' Hx e e' He. now rewrite Hx. - clear. intros x x' Hx e e' He. now rewrite Hx. - Qed. - -End WProperties_fun. - -(** * Same Properties for self-contained weak maps and for full maps *) - -Module WProperties (M:WS) := WProperties_fun M.E M. -Module Properties := WProperties. - -(** * Properties specific to maps with ordered keys *) - -Module OrdProperties (M:S). - Module Import ME := OrderedTypeFacts M.E. - Module Import O:=KeyOrderedType M.E. - Module Import P:=Properties M. - Import M. - - Section Elt. - Variable elt:Type. - - Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. - Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. - - Section Bindings. - - Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), - sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. - Proof. - apply SortA_equivlistA_eqlistA; eauto with *. - Qed. - - Ltac klean := unfold O.eqke, O.ltk, RelCompFun in *; simpl in *. - Ltac keauto := klean; intuition; eauto. - - Definition gtb (p p':key*elt) := - match E.compare (fst p) (fst p') with Gt => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). - - Definition bindings_lt p m := List.filter (gtb p) (bindings m). - Definition bindings_ge p m := List.filter (leb p) (bindings m). - - Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. - Proof. - intros (x,e) (y,e'); unfold gtb; klean. - case E.compare_spec; intuition; try discriminate; ME.order. - Qed. - - Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. - Proof. - intros (x,e) (y,e'); unfold leb, gtb; klean. - case E.compare_spec; intuition; try discriminate; ME.order. - Qed. - - Instance gtb_compat : forall p, Proper (eqke==>eq) (gtb p). - Proof. - red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); - destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); klean; auto. - - intros. symmetry; rewrite H2. rewrite <-H, <-H1; auto. - - intros. rewrite H1. rewrite H, <- H2; auto. - Qed. - - Instance leb_compat : forall p, Proper (eqke==>eq) (leb p). - Proof. - intros x a b H. unfold leb; f_equal; apply gtb_compat; auto. - Qed. - - Hint Resolve gtb_compat leb_compat bindings_spec2 : map. - - Lemma bindings_split : forall p m, - bindings m = bindings_lt p m ++ bindings_ge p m. - Proof. - unfold bindings_lt, bindings_ge, leb; intros. - apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. - intros; destruct x; destruct y; destruct p. - rewrite gtb_1 in H; klean. - apply not_true_iff_false in H0. rewrite gtb_1 in H0. klean. ME.order. - Qed. - - Lemma bindings_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (bindings m') - (bindings_lt (x,e) m ++ (x,e):: bindings_ge (x,e) m). - Proof. - intros; unfold bindings_lt, bindings_ge. - apply sort_equivlistA_eqlistA; auto with *. - - apply (@SortA_app _ eqke); auto with *. - + apply (@filter_sort _ eqke); auto with *; keauto. - + constructor; auto with map. - * apply (@filter_sort _ eqke); auto with *; keauto. - * rewrite (@InfA_alt _ eqke); auto with *; try (keauto; fail). - { intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite leb_1 in H2. - destruct y; klean. - rewrite <- bindings_mapsto_iff in H1. - assert (~E.eq x t0). - { contradict H. - exists e0; apply MapsTo_1 with t0; auto. - ME.order. } - ME.order. } - { apply (@filter_sort _ eqke); auto with *; keauto. } - + intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite gtb_1 in H3. - destruct y; destruct x0; klean. - inversion_clear H2. - * red in H4; klean; destruct H4; simpl in *. ME.order. - * rewrite filter_InA in H4; auto with *; destruct H4. - rewrite leb_1 in H4. klean; ME.order. - - intros (k,e'). - rewrite InA_app_iff, InA_cons, 2 filter_InA, - <-2 bindings_mapsto_iff, leb_1, gtb_1, - find_mapsto_iff, (H0 k), <- find_mapsto_iff, - add_mapsto_iff by (auto with * ). - change (eqke (k,e') (x,e)) with (E.eq k x /\ e' = e). - klean. - split. - + intros [(->,->)|(Hk,Hm)]. - * right; now left. - * destruct (lt_dec k x); intuition. - + intros [(Hm,LT)|[(->,->)|(Hm,EQ)]]. - * right; split; trivial; ME.order. - * now left. - * destruct (eq_dec x k) as [Hk|Hk]. - elim H. exists e'. now rewrite Hk. - right; auto. - Qed. - - Lemma bindings_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> - eqlistA eqke (bindings m') (bindings m ++ (x,e)::nil). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - apply (@SortA_app _ eqke); auto with *. - intros. - inversion_clear H2. - destruct x0; destruct y. - rewrite <- bindings_mapsto_iff in H1. - destruct H3; klean. - rewrite H2. - apply H; firstorder. - inversion H3. - red; intros a; destruct a. - rewrite InA_app_iff, InA_cons, InA_nil, <- 2 bindings_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with *). - change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). - intuition. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma bindings_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> - eqlistA eqke (bindings m') ((x,e)::bindings m). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - change (sort ltk (((x,e)::nil) ++ bindings m)). - apply (@SortA_app _ eqke); auto with *. - intros. - inversion_clear H1. - destruct y; destruct x0. - rewrite <- bindings_mapsto_iff in H2. - destruct H3; klean. - rewrite H1. - apply H; firstorder. - inversion H3. - red; intros a; destruct a. - rewrite InA_cons, <- 2 bindings_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with * ). - change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). - intuition. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma bindings_Equal_eqlistA : forall (m m': t elt), - Equal m m' -> eqlistA eqke (bindings m) (bindings m'). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - red; intros. - destruct x; do 2 rewrite <- bindings_mapsto_iff. - do 2 rewrite find_mapsto_iff; rewrite H; split; auto. - Qed. - - End Bindings. - - Section Min_Max_Elt. - - (** We emulate two [max_elt] and [min_elt] functions. *) - - Fixpoint max_elt_aux (l:list (key*elt)) := match l with - | nil => None - | (x,e)::nil => Some (x,e) - | (x,e)::l => max_elt_aux l - end. - Definition max_elt m := max_elt_aux (bindings m). - - Lemma max_elt_Above : - forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). - Proof. - red; intros. - rewrite remove_in_iff in H0. - destruct H0. - rewrite bindings_in_iff in H1. - destruct H1. - unfold max_elt in *. - generalize (bindings_spec2 m). - revert x e H y x0 H0 H1. - induction (bindings m). - simpl; intros; try discriminate. - intros. - destruct a; destruct l; simpl in *. - injection H; clear H; intros; subst. - inversion_clear H1. - red in H; simpl in *; intuition. - now elim H0. - inversion H. - change (max_elt_aux (p::l) = Some (x,e)) in H. - generalize (IHl x e H); clear IHl; intros IHl. - inversion_clear H1; [ | inversion_clear H2; eauto ]. - red in H3; simpl in H3; destruct H3. - destruct p as (p1,p2). - destruct (E.eq_dec p1 x) as [Heq|Hneq]. - rewrite <- Heq; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - transitivity p1; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - eapply IHl; eauto with *. - econstructor; eauto. - red; eauto with *. - inversion H2; auto. - Qed. - - Lemma max_elt_MapsTo : - forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold max_elt in *. - rewrite bindings_mapsto_iff. - induction (bindings m). - simpl; try discriminate. - destruct a; destruct l; simpl in *. - injection H; intros; subst; constructor; red; auto with *. - constructor 2; auto. - Qed. - - Lemma max_elt_Empty : - forall m, max_elt m = None -> Empty m. - Proof. - intros. - unfold max_elt in *. - rewrite bindings_Empty. - induction (bindings m); auto. - destruct a; destruct l; simpl in *; try discriminate. - assert (H':=IHl H); discriminate. - Qed. - - Definition min_elt m : option (key*elt) := match bindings m with - | nil => None - | (x,e)::_ => Some (x,e) - end. - - Lemma min_elt_Below : - forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). - Proof. - unfold min_elt, Below; intros. - rewrite remove_in_iff in H0; destruct H0. - rewrite bindings_in_iff in H1. - destruct H1. - generalize (bindings_spec2 m). - destruct (bindings m). - try discriminate. - destruct p; injection H; intros; subst. - inversion_clear H1. - red in H2; destruct H2; simpl in *; ME.order. - inversion_clear H4. - rewrite (@InfA_alt _ eqke) in H3; eauto with *. - apply (H3 (y,x0)); auto. - Qed. - - Lemma min_elt_MapsTo : - forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold min_elt in *. - rewrite bindings_mapsto_iff. - destruct (bindings m). - simpl; try discriminate. - destruct p; simpl in *. - injection H; intros; subst; constructor; red; auto with *. - Qed. - - Lemma min_elt_Empty : - forall m, min_elt m = None -> Empty m. - Proof. - intros. - unfold min_elt in *. - rewrite bindings_Empty. - destruct (bindings m); auto. - destruct p; simpl in *; discriminate. - Qed. - - End Min_Max_Elt. - - Section Induction_Principles. - - Lemma map_induction_max : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. - - case_eq (max_elt m); intros. - destruct p. - assert (Add k e (remove k m) m). - { apply max_elt_MapsTo, find_spec, add_id in H. - unfold Add. symmetry. now rewrite add_remove_1. } - apply X0 with (remove k m) k e; auto with map. - apply IHn. - assert (S n = S (cardinal (remove k m))). - { rewrite Heqn. - eapply cardinal_S; eauto with map. } - inversion H1; auto. - eapply max_elt_Above; eauto. - - apply X; apply max_elt_Empty; auto. - Qed. - - Lemma map_induction_min : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. - - case_eq (min_elt m); intros. - destruct p. - assert (Add k e (remove k m) m). - { apply min_elt_MapsTo, find_spec, add_id in H. - unfold Add. symmetry. now rewrite add_remove_1. } - apply X0 with (remove k m) k e; auto. - apply IHn. - assert (S n = S (cardinal (remove k m))). - { rewrite Heqn. - eapply cardinal_S; eauto with map. } - inversion H1; auto. - eapply min_elt_Below; eauto. - - apply X; apply min_elt_Empty; auto. - Qed. - - End Induction_Principles. - - Section Fold_properties. - - (** The following lemma has already been proved on Weak Maps, - but with one additional hypothesis (some [transpose] fact). *) - - Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros m1 m2 A eqA st f i Hf Heq. - rewrite 2 fold_spec_right. - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. - apply eqlistA_rev. apply bindings_Equal_eqlistA. auto. - Qed. - - Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Above x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (f x e (fold f m1 i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (bindings m1 ++ (x,e)::nil))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. - apply eqlistA_rev. - apply bindings_Add_Above; auto. - rewrite distr_rev; simpl. - reflexivity. - Qed. - - Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Below x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (fold f m1 (f x e i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (((x,e)::nil)++bindings m1))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. - apply eqlistA_rev. - simpl; apply bindings_Add_Below; auto. - rewrite distr_rev; simpl. - rewrite fold_right_app. - reflexivity. - Qed. - - End Fold_properties. - - End Elt. - -End OrdProperties. diff --git a/theories/MMaps/MMapInterface.v b/theories/MMaps/MMapInterface.v deleted file mode 100644 index 05c5e5d8fb..0000000000 --- a/theories/MMaps/MMapInterface.v +++ /dev/null @@ -1,292 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* elt->bool) e1 e2 := cmp e1 e2 = true. - -(** ** Weak signature for maps - - No requirements for an ordering on keys nor elements, only decidability - of equality on keys. First, a functorial signature: *) - -Module Type WSfun (E : DecidableType). - - Definition key := E.t. - Hint Transparent key. - - Definition eq_key {elt} (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt {elt} (p p':key*elt) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Parameter t : Type -> Type. - (** the abstract type of maps *) - - Section Ops. - - Parameter empty : forall {elt}, t elt. - (** The empty map. *) - - Variable elt:Type. - - Parameter is_empty : t elt -> bool. - (** Test whether a map is empty or not. *) - - Parameter add : key -> elt -> t elt -> t elt. - (** [add x y m] returns a map containing the same bindings as [m], - plus a binding of [x] to [y]. If [x] was already bound in [m], - its previous binding disappears. *) - - Parameter find : key -> t elt -> option elt. - (** [find x m] returns the current binding of [x] in [m], - or [None] if no such binding exists. *) - - Parameter remove : key -> t elt -> t elt. - (** [remove x m] returns a map containing the same bindings as [m], - except for [x] which is unbound in the returned map. *) - - Parameter mem : key -> t elt -> bool. - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) - - Parameter bindings : t elt -> list (key*elt). - (** [bindings m] returns an assoc list corresponding to the bindings - of [m], in any order. *) - - Parameter cardinal : t elt -> nat. - (** [cardinal m] returns the number of bindings in [m]. *) - - Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1] ... [kN] are the keys of all bindings in [m] - (in any order), and [d1] ... [dN] are the associated data. *) - - Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, - that is, contain equal keys and associate them with equal data. - [cmp] is the equality predicate used to compare the data associated - with the keys. *) - - Variable elt' elt'' : Type. - - Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated - value a of all bindings of [m] has been replaced by the result of the - application of [f] to [a]. Since Coq is purely functional, the order - in which the bindings are passed to [f] is irrelevant. *) - - Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [map], but the function receives as arguments both the - key and the associated value for each binding of the map. *) - - Parameter merge : (key -> option elt -> option elt' -> option elt'') -> - t elt -> t elt' -> t elt''. - (** [merge f m m'] creates a new map whose bindings belong to the ones - of either [m] or [m']. The presence and value for a key [k] is - determined by [f k e e'] where [e] and [e'] are the (optional) - bindings of [k] in [m] and [m']. *) - - End Ops. - Section Specs. - - Variable elt:Type. - - Parameter MapsTo : key -> elt -> t elt -> Prop. - - Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. - - Global Declare Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - - Variable m m' : t elt. - Variable x y : key. - Variable e : elt. - - Parameter find_spec : find x m = Some e <-> MapsTo x e m. - Parameter mem_spec : mem x m = true <-> In x m. - Parameter empty_spec : find x (@empty elt) = None. - Parameter is_empty_spec : is_empty m = true <-> forall x, find x m = None. - Parameter add_spec1 : find x (add x e m) = Some e. - Parameter add_spec2 : ~E.eq x y -> find y (add x e m) = find y m. - Parameter remove_spec1 : find x (remove x m) = None. - Parameter remove_spec2 : ~E.eq x y -> find y (remove x m) = find y m. - - (** Specification of [bindings] *) - Parameter bindings_spec1 : - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - (** When compared with ordered maps, here comes the only - property that is really weaker: *) - Parameter bindings_spec2w : NoDupA eq_key (bindings m). - - (** Specification of [cardinal] *) - Parameter cardinal_spec : cardinal m = length (bindings m). - - (** Specification of [fold] *) - Parameter fold_spec : - forall {A} (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - - (** Equality of maps *) - - (** Caveat: there are at least three distinct equality predicates on maps. - - The simpliest (and maybe most natural) way is to consider keys up to - their equivalence [E.eq], but elements up to Leibniz equality, in - the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - - Unfortunately, this [Equal] predicate can't be used to describe - the [equal] function, since this function (for compatibility with - ocaml) expects a boolean comparison [cmp] that may identify more - elements than Leibniz. So logical specification of [equal] is done - via another predicate [Equivb] - - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], - it can be generalized in a [Equiv] expecting a more general - (possibly non-decidable) equality predicate on elements *) - - Definition Equal (m m':t elt) := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). - - (** Specification of [equal] *) - Parameter equal_spec : forall cmp : elt -> elt -> bool, - equal cmp m m' = true <-> Equivb cmp m m'. - - End Specs. - Section SpecMaps. - - Variables elt elt' elt'' : Type. - - Parameter map_spec : forall (f:elt->elt') m x, - find x (map f m) = option_map f (find x m). - - Parameter mapi_spec : forall (f:key->elt->elt') m x, - exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - - Parameter merge_spec1 : - forall (f:key->option elt->option elt'->option elt'') m m' x, - In x m \/ In x m' -> - exists y:key, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - - Parameter merge_spec2 : - forall (f:key -> option elt->option elt'->option elt'') m m' x, - In x (merge f m m') -> In x m \/ In x m'. - - End SpecMaps. -End WSfun. - -(** ** Static signature for Weak Maps - - Similar to [WSfun] but expressed in a self-contained way. *) - -Module Type WS. - Declare Module E : DecidableType. - Include WSfun E. -End WS. - - - -(** ** Maps on ordered keys, functorial signature *) - -Module Type Sfun (E : OrderedType). - Include WSfun E. - - Definition lt_key {elt} (p p':key*elt) := E.lt (fst p) (fst p'). - - (** Additional specification of [bindings] *) - - Parameter bindings_spec2 : forall {elt}(m : t elt), sort lt_key (bindings m). - - (** Remark: since [fold] is specified via [bindings], this stronger - specification of [bindings] has an indirect impact on [fold], - which can now be proved to receive bindings in increasing order. *) - -End Sfun. - - -(** ** Maps on ordered keys, self-contained signature *) - -Module Type S. - Declare Module E : OrderedType. - Include Sfun E. -End S. - - - -(** ** Maps with ordering both on keys and datas *) - -Module Type Sord. - - Declare Module Data : OrderedType. - Declare Module MapS : S. - Import MapS. - - Definition t := MapS.t Data.t. - - Include HasEq <+ HasLt <+ IsEq <+ IsStrOrder. - - Definition cmp e e' := - match Data.compare e e' with Eq => true | _ => false end. - - Parameter eq_spec : forall m m', eq m m' <-> Equivb cmp m m'. - - Parameter compare : t -> t -> comparison. - - Parameter compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). - -End Sord. - - -(* TODO: provides filter + partition *) - -(* TODO: provide split - Parameter split : key -> t elt -> t elt * option elt * t elt. - - Parameter split_spec k m : - split k m = (filter (fun x -> E.compare x k) m, find k m, filter ...) - - min_binding, max_binding, choose ? -*) diff --git a/theories/MMaps/MMapList.v b/theories/MMaps/MMapList.v deleted file mode 100644 index c521178cbd..0000000000 --- a/theories/MMaps/MMapList.v +++ /dev/null @@ -1,1144 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - assert (X.lt k' k); - [let e := fresh "e" in destruct H3 as (e,H3); - change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:MapsTo ?k ?e ?m |- _ => - assert (X.lt k' k); - [change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:InA eqke (?k,?e) ?m |- _ => - assert (X.lt k' k); - [change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - end. - -(** * [find] *) - -Fixpoint find (k:key) (m: t elt) : option elt := - match m with - | nil => None - | (k',x)::m' => - match X.compare k k' with - | Lt => None - | Eq => Some x - | Gt => find k m' - end - end. - -Lemma find_spec m (Hm:Sort m) x e : - find x m = Some e <-> MapsTo x e m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - split. discriminate. inversion 1. - - inversion_clear Hm. - unfold MapsTo in *. rewrite InA_cons, eqke_def. - case X.compare_spec; intros. - + split. injection 1 as ->; auto. - intros [(_,<-)|IN]; trivial. SortLt. MX.order. - + split. discriminate. - intros [(E,<-)|IN]; trivial; try SortLt; MX.order. - + rewrite IH; trivial. split; auto. - intros [(E,<-)|IN]; trivial. MX.order. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (m : t elt) : bool := - match m with - | nil => false - | (k',_) :: l => - match X.compare k k' with - | Lt => false - | Eq => true - | Gt => mem k l - end - end. - -Lemma mem_spec m (Hm:Sort m) x : mem x m = true <-> In x m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - split. discriminate. inversion 1. inversion_clear H0. - - inversion_clear Hm. - rewrite In_cons; simpl. - case X.compare_spec; intros. - + intuition. - + split. discriminate. intros [E|(e,IN)]. MX.order. - SortLt. MX.order. - + rewrite IH; trivial. split; auto. intros [E|IN]; trivial. - MX.order. -Qed. - -(** * [empty] *) - -Definition empty : t elt := nil. - -Lemma empty_spec x : find x empty = None. -Proof. - reflexivity. -Qed. - -Lemma empty_sorted : Sort empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_spec m : - is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m as [|(k,e) m]; simpl; split; trivial; try discriminate. - intros H. specialize (H k). now rewrite compare_refl in H. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => - match X.compare k k' with - | Lt => (k,x)::s - | Eq => (k,x)::l - | Gt => (k',y) :: add k x l - end - end. - -Lemma add_spec1 m x e : find x (add x e m) = Some e. -Proof. - induction m as [|(k,e') m IH]; simpl. - - now rewrite compare_refl. - - case X.compare_spec; simpl; rewrite ?compare_refl; trivial. - rewrite <- compare_gt_iff. now intros ->. -Qed. - -Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - case X.compare_spec; trivial; MX.order. - - case X.compare_spec; simpl; intros; trivial. - + rewrite <-H. case X.compare_spec; trivial; MX.order. - + do 2 (case X.compare_spec; trivial; try MX.order). - + now rewrite IH. -Qed. - -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), - Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0,H1. - simpl; case X.compare; intuition. -Qed. -Hint Resolve add_Inf. - -Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x',e'). - simpl; case (X.compare_spec x x'); intuition; inversion_clear Hm; auto. - constructor; auto. - apply Inf_eq with (x',e'); auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) : t elt := - match s with - | nil => nil - | (k',x) :: l => - match X.compare k k' with - | Lt => s - | Eq => l - | Gt => (k',x) :: remove k l - end - end. - -Lemma remove_spec1 m (Hm:Sort m) x : find x (remove x m) = None. -Proof. - induction m as [|(k,e') m IH]; simpl; trivial. - inversion_clear Hm. - case X.compare_spec; simpl. - - intros E. rewrite <- E in H0. - apply Sort_Inf_NotIn in H0; trivial. unfold In in H0. - setoid_rewrite <- find_spec in H0; trivial. - destruct (find x m); trivial. - elim H0; now exists e. - - rewrite <- compare_lt_iff. now intros ->. - - rewrite <- compare_gt_iff. intros ->; auto. -Qed. - -Lemma remove_spec2 m (Hm:Sort m) x y : - ~X.eq x y -> find y (remove x m) = find y m. -Proof. - induction m as [|(k,e') m IH]; simpl; trivial. - inversion_clear Hm. - case X.compare_spec; simpl; intros E E'; try rewrite IH; auto. - case X.compare_spec; simpl; trivial; try MX.order. - intros. rewrite <- E in H0,H1. clear E E'. - destruct (find y m) eqn:F; trivial. - apply find_spec in F; trivial. - SortLt. MX.order. -Qed. - -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), - Inf (x',e') m -> Inf (x',e') (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0. - simpl; case X.compare; intuition. - inversion_clear Hm. - apply Inf_lt with (x'',e''); auto. -Qed. -Hint Resolve remove_Inf. - -Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x',e'). - simpl; case X.compare_spec; intuition; inversion_clear Hm; auto. -Qed. - -(** * [bindings] *) - -Definition bindings (m: t elt) := m. - -Lemma bindings_spec1 m x e : - InA eqke (x,e) (bindings m) <-> MapsTo x e m. -Proof. - reflexivity. -Qed. - -Lemma bindings_spec2 m (Hm:Sort m) : sort ltk (bindings m). -Proof. - auto. -Qed. - -Lemma bindings_spec2w m (Hm:Sort m) : NoDupA eqk (bindings m). -Proof. - now apply Sort_NoDupA. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_spec m : forall (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. - induction m as [|(k,e) m IH]; simpl; auto. -Qed. - -(** * [equal] *) - -Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) : bool := - match m, m' with - | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Eq => cmp e e' && equal cmp l l' - | _ => false - end - | _, _ => false - end. - -Definition Equivb (cmp:elt->elt->bool) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. - induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl. - - trivial. - - intros _ cmp (H,_). - exfalso. apply (@In_nil elt k'). rewrite H, In_cons. now left. - - intros _ cmp (H,_). - exfalso. apply (@In_nil elt k). rewrite <- H, In_cons. now left. - - intros Hm' cmp E. - inversion_clear Hm; inversion_clear Hm'. - case X.compare_spec; intros E'. - + apply andb_true_intro; split. - * eapply E; eauto. apply InA_cons; now left. - * apply IH; clear IH; trivial. - destruct E as (E1,E2). split. - { intros x. clear E2. - split; intros; SortLt. - specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. - destruct E1 as ([E1|E1],_); eauto. MX.order. - specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. - destruct E1 as (_,[E1|E1]); eauto. MX.order. } - { intros x xe xe' Hx HX'. eapply E2; eauto. } - + assert (IN : In k ((k',e')::m')). - { apply E. apply In_cons; now left. } - apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. - SortLt. MX.order. - + assert (IN : In k' ((k,e)::m)). - { apply E. apply In_cons; now left. } - apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. - SortLt. MX.order. -Qed. - -Lemma equal_2 m (Hm:Sort m) m' (Hm':Sort m') cmp : - equal cmp m m' = true -> Equivb cmp m m'. -Proof. - revert m' Hm'. - induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl; - try discriminate. - - split. reflexivity. inversion 1. - - intros Hm'. case X.compare_spec; try discriminate. - rewrite andb_true_iff. intros E (C,EQ). - inversion_clear Hm; inversion_clear Hm'. - apply IH in EQ; trivial. - destruct EQ as (E1,E2). - split. - + intros x. rewrite 2 In_cons; simpl. rewrite <- E1. - intuition; now left; MX.order. - + intros x ex ex'. unfold MapsTo in *. rewrite 2 InA_cons, 2 eqke_def. - intuition; subst. - * trivial. - * SortLt. MX.order. - * SortLt. MX.order. - * eapply E2; eauto. -Qed. - -Lemma equal_spec m (Hm:Sort m) m' (Hm':Sort m') cmp : - equal cmp m m' = true <-> Equivb cmp m m'. -Proof. - split. now apply equal_2. now apply equal_1. -Qed. - -(** This lemma isn't part of the spec of [Equivb], but is used in [MMapAVL] *) - -Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> - (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). -Proof. - intros. - inversion H; subst. - inversion H0; subst. - destruct x; destruct y; compute in H1, H2. - split; intros. - apply equal_2; auto. - simpl. - case X.compare_spec; intros; try MX.order. - rewrite H2; simpl. - apply equal_1; auto. - apply equal_2; auto. - generalize (equal_1 H H0 H3). - simpl. - case X.compare_spec; try discriminate. - rewrite andb_true_iff. intuition. -Qed. - -Variable elt':Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -End Elt. -Arguments find {elt} k m. -Section Elt2. -Variable elt elt' : Type. - -(** Specification of [map] *) - -Lemma map_spec (f:elt->elt') m x : - find x (map f m) = option_map f (find x m). -Proof. - induction m as [|(k,e) m IH]; simpl; trivial. - now case X.compare_spec. -Qed. - -Lemma map_Inf (f:elt->elt') m x e e' : - Inf (x,e) m -> Inf (x,e') (map f m). -Proof. - induction m as [|(x0,e0) m IH]; simpl; auto. - inversion_clear 1; auto. -Qed. -Hint Resolve map_Inf. - -Lemma map_sorted (f:elt->elt')(m: t elt)(Hm : Sort m) : - Sort (map f m). -Proof. - induction m as [|(x,e) m IH]; simpl; auto. - inversion_clear Hm. constructor; eauto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_spec (f:key->elt->elt') m x : - exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m as [|(k,e) m IH]; simpl. - - now exists x. - - elim X.compare_spec; intros; simpl. - + now exists k. - + now exists x. - + apply IH. -Qed. - -Lemma mapi_Inf (f:key->elt->elt') m x e : - Inf (x,e) m -> Inf (x,f x e) (mapi f m). -Proof. - induction m as [|(x0,e0) m IH]; simpl; auto. - inversion_clear 1; auto. -Qed. -Hint Resolve mapi_Inf. - -Lemma mapi_sorted (f:key->elt->elt') m (Hm : Sort m) : - Sort (mapi f m). -Proof. - induction m as [|(x,e) m IH]; simpl; auto. - inversion_clear Hm; auto. -Qed. - -End Elt2. -Section Elt3. - -(** * [merge] *) - -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition option_cons {A}(k:key)(o:option A)(l:list (key*A)) := - match o with - | Some e => (k,e)::l - | None => l - end. - -Fixpoint merge_l (m : t elt) : t elt'' := - match m with - | nil => nil - | (k,e)::l => option_cons k (f k (Some e) None) (merge_l l) - end. - -Fixpoint merge_r (m' : t elt') : t elt'' := - match m' with - | nil => nil - | (k,e')::l' => option_cons k (f k None (Some e')) (merge_r l') - end. - -Fixpoint merge (m : t elt) : t elt' -> t elt'' := - match m with - | nil => merge_r - | (k,e) :: l => - fix merge_aux (m' : t elt') : t elt'' := - match m' with - | nil => merge_l m - | (k',e') :: l' => - match X.compare k k' with - | Lt => option_cons k (f k (Some e) None) (merge l m') - | Eq => option_cons k (f k (Some e) (Some e')) (merge l l') - | Gt => option_cons k' (f k' None (Some e')) (merge_aux l') - end - end - end. - -Notation oee' := (option elt * option elt')%type. - -Fixpoint combine (m : t elt) : t elt' -> t oee' := - match m with - | nil => map (fun e' => (None,Some e')) - | (k,e) :: l => - fix combine_aux (m':t elt') : list (key * oee') := - match m' with - | nil => map (fun e => (Some e,None)) m - | (k',e') :: l' => - match X.compare k k' with - | Lt => (k,(Some e, None))::combine l m' - | Eq => (k,(Some e, Some e'))::combine l l' - | Gt => (k',(None,Some e'))::combine_aux l' - end - end - end. - -Definition fold_right_pair {A B C}(f: A->B->C->C)(l:list (A*B))(i:C) := - List.fold_right (fun p => f (fst p) (snd p)) i l. - -Definition merge' m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := mapi (fun k p => f k (fst p) (snd p)) m0 in - fold_right_pair (option_cons (A:=elt'')) m1 nil. - -Lemma merge_equiv : forall m m', merge' m m' = merge m m'. -Proof. - unfold merge'. - induction m as [|(k,e) m IHm]; intros. - - (* merge_r *) - simpl. - induction m' as [|(k',e') m' IHm']; simpl; rewrite ?IHm'; auto. - - induction m' as [|(k',e') m' IHm']; simpl. - + f_equal. - (* merge_l *) - clear k e IHm. - induction m as [|(k,e) m IHm]; simpl; rewrite ?IHm; auto. - + elim X.compare_spec; intros; simpl; f_equal. - * apply IHm. - * apply IHm. - * apply IHm'. -Qed. - -Lemma combine_Inf : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - Inf (x,e) m -> - Inf (x,e') m' -> - Inf (x,e'') (combine m m'). -Proof. - induction m. - - intros. simpl. eapply map_Inf; eauto. - - induction m'; intros. - + destruct a. - replace (combine ((t0, e0) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. - eapply map_Inf; eauto. - + simpl. - destruct a as (k,e0); destruct a0 as (k',e0'). - elim X.compare_spec. - * inversion_clear H; auto. - * inversion_clear H; auto. - * inversion_clear H0; auto. -Qed. -Hint Resolve combine_Inf. - -Lemma combine_sorted m (Hm : Sort m) m' (Hm' : Sort m') : - Sort (combine m m'). -Proof. - revert m' Hm'. - induction m. - - intros; clear Hm. simpl. apply map_sorted; auto. - - induction m'; intros. - + clear Hm'. - destruct a. - replace (combine ((t0, e) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. - apply map_sorted; auto. - + simpl. - destruct a as (k,e); destruct a0 as (k',e'). - inversion_clear Hm; inversion_clear Hm'. - case X.compare_spec; [intros Heq| intros Hlt| intros Hlt]; - constructor; auto. - * assert (Inf (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_Inf _ H0 H3). - * assert (Inf (k, e') ((k',e')::m')) by auto. - exact (combine_Inf _ H0 H3). - * assert (Inf (k', e) ((k,e)::m)) by auto. - exact (combine_Inf _ H3 H2). -Qed. - -Lemma merge_sorted m (Hm : Sort m) m' (Hm' : Sort m') : - Sort (merge m m'). -Proof. - intros. - rewrite <- merge_equiv. - unfold merge'. - assert (Hmm':=combine_sorted Hm Hm'). - set (l0:=combine m m') in *; clearbody l0. - set (f':= fun k p => f k (fst p) (snd p)). - assert (H1:=mapi_sorted f' Hmm'). - set (l1:=mapi f' l0) in *; clearbody l1. - clear f' f Hmm' l0 Hm Hm' m m'. - (* Sort fold_right_pair *) - induction l1. - - simpl; auto. - - inversion_clear H1. - destruct a; destruct o; auto. - simpl. - constructor; auto. - clear IHl1. - (* Inf fold_right_pair *) - induction l1. - + simpl; auto. - + destruct a; destruct o; simpl; auto. - * inversion_clear H0; auto. - * inversion_clear H0. inversion_clear H. - compute in H1. - apply IHl1; auto. - apply Inf_lt with (t1, None); auto. -Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => Some (o,o') - end. - -Lemma combine_spec m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : - find x (combine m m') = at_least_one (find x m) (find x m'). -Proof. - revert m' Hm'. - induction m. - intros. - simpl. - induction m'. - intros; simpl; auto. - simpl; destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - inversion_clear Hm'; auto. - induction m'. - (* m' = nil *) - intros; destruct a; simpl. - destruct (X.compare_spec x t0) as [ |Hlt|Hlt]; simpl; auto. - inversion_clear Hm; clear H0 Hlt Hm' IHm t0. - induction m; simpl; auto. - inversion_clear H. - destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - (* m' <> nil *) - intros. - destruct a as (k,e); destruct a0 as (k',e'); simpl. - inversion Hm; inversion Hm'; subst. - destruct (X.compare_spec k k'); simpl; - destruct (X.compare_spec x k); - MX.order || destruct (X.compare_spec x k'); - simpl; try MX.order; auto. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = - at_least_one (find x m) (find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. -Qed. - -Definition at_least_one_then_f k (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => f k o o' - end. - -Lemma merge_spec0 m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : - exists y, X.eq y x /\ - find x (merge m m') = at_least_one_then_f y (find x m) (find x m'). -Proof. - intros. - rewrite <- merge_equiv. - unfold merge'. - assert (H:=combine_spec Hm Hm' x). - assert (H2:=combine_sorted Hm Hm'). - set (f':= fun k p => f k (fst p) (snd p)). - set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. - set (o':=find x m') in *; clearbody o'. - clear Hm Hm' m m'. revert H. - match goal with |- ?G => - assert (G/\(find x m0 = None -> - find x (fold_right_pair option_cons (mapi f' m0) nil) = None)); - [|intuition] end. - induction m0; simpl in *; intuition. - - exists x; split; [easy|]. - destruct o; destruct o'; simpl in *; try discriminate; auto. - - destruct a as (k,(oo,oo')); simpl in *. - inversion_clear H2. - destruct (X.compare_spec x k) as [Heq|Hlt|Hlt]; simpl in *. - + (* x = k *) - exists k; split; [easy|]. - assert (at_least_one_then_f k o o' = f k oo oo'). - { destruct o; destruct o'; simpl in *; inversion_clear H; auto. } - rewrite H2. - unfold f'; simpl. - destruct (f k oo oo'); simpl. - * elim X.compare_spec; trivial; try MX.order. - * destruct (IHm0 H0) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). - now compute. - symmetry in H5. - destruct (Sort_Inf_NotIn H0 (Inf_eq H5 H1)). - exists p; apply find_spec; auto. - + (* x < k *) - destruct (f' k (oo,oo')); simpl. - * elim X.compare_spec; trivial; try MX.order. - destruct o; destruct o'; simpl in *; try discriminate; auto. - now exists x. - * apply IHm0; trivial. - rewrite <- H. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - red; auto. - destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_spec; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - * elim X.compare_spec; trivial; try MX.order. - intros. apply IHm0; auto. - * apply IHm0; auto. - - - (* None -> None *) - destruct a as (k,(oo,oo')). - simpl. - inversion_clear H2. - destruct (X.compare_spec x k) as [Hlt|Heq|Hlt]; try discriminate. - + (* x < k *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - elim X.compare_spec; trivial; try MX.order. intros. - apply IHm0; auto. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - now compute. - destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_spec; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - elim X.compare_spec; trivial; try MX.order. intros. - apply IHm0; auto. - apply IHm0; auto. -Qed. - -(** Specification of [merge] *) - -Lemma merge_spec1 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (merge m m') = f y (find x m) (find x m'). -Proof. - intros. - destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). - exists y; split; [easy|]. rewrite H'. - destruct H as [(e,H)|(e,H)]; - apply find_spec in H; trivial; rewrite H; simpl; auto. - now destruct (find x m). -Qed. - -Lemma merge_spec2 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : - In x (merge m m') -> In x m \/ In x m'. -Proof. - intros. - destruct H as (e,H). - apply find_spec in H; auto using merge_sorted. - destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). - rewrite H in H'. - destruct (find x m) eqn:F. - - apply find_spec in F; eauto. - - destruct (find x m') eqn:F'. - + apply find_spec in F'; eauto. - + simpl in H'. discriminate. -Qed. - -End Elt3. -End Raw. - -Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. -Module E := X. - -Definition key := E.t. -Definition eq_key {elt} := @Raw.PX.eqk elt. -Definition eq_key_elt {elt} := @Raw.PX.eqke elt. -Definition lt_key {elt} := @Raw.PX.ltk elt. - -Record t_ (elt:Type) := Mk - {this :> Raw.t elt; - sorted : sort Raw.PX.ltk this}. -Definition t := t_. - -Definition empty {elt} := Mk (Raw.empty_sorted elt). - -Section Elt. - Variable elt elt' elt'':Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (Raw.add_sorted m.(sorted) x e). - Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Mk (Raw.remove_sorted m.(sorted) x). - Definition mem x m : bool := Raw.mem x m.(this). - Definition map f m : t elt' := Mk (Raw.map_sorted f m.(sorted)). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (Raw.mapi_sorted f m.(sorted)). - Definition merge f m (m':t elt') : t elt'' := - Mk (Raw.merge_sorted f m.(sorted) m'.(sorted)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := length m.(this). - Definition fold {A:Type}(f:key->elt->A->A) m (i:A) : A := - Raw.fold f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. - Qed. - - Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. - Proof. exact (Raw.find_spec m.(sorted)). Qed. - - Lemma mem_spec m : forall x, mem x m = true <-> In x m. - Proof. exact (Raw.mem_spec m.(sorted)). Qed. - - Lemma empty_spec : forall x, find x empty = None. - Proof. exact (Raw.empty_spec _). Qed. - - Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). - Proof. exact (Raw.is_empty_spec m.(this)). Qed. - - Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. - Proof. exact (Raw.add_spec1 m.(this)). Qed. - Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. - Proof. exact (Raw.add_spec2 m.(this)). Qed. - - Lemma remove_spec1 m : forall x, find x (remove x m) = None. - Proof. exact (Raw.remove_spec1 m.(sorted)). Qed. - Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. - Proof. exact (Raw.remove_spec2 m.(sorted)). Qed. - - Lemma bindings_spec1 m : forall x e, - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. exact (Raw.bindings_spec1 m.(this)). Qed. - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. exact (Raw.bindings_spec2w m.(sorted)). Qed. - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. exact (Raw.bindings_spec2 m.(sorted)). Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. reflexivity. Qed. - - Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. exact (Raw.fold_spec m.(this)). Qed. - - Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. - Proof. exact (Raw.equal_spec m.(sorted) m'.(sorted)). Qed. - -End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m : - forall x, find x (map f m) = option_map f (find x m). - Proof. exact (Raw.map_spec f m.(this)). Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : - forall x, exists y, - E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. exact (Raw.mapi_spec f m.(this)). Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x m \/ In x m' -> - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). - Proof. exact (Raw.merge_spec1 f m.(sorted) m'.(sorted)). Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x (merge f m m') -> In x m \/ In x m'. - Proof. exact (Raw.merge_spec2 m.(sorted) m'.(sorted)). Qed. - -End Make. - -Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D - with Module MapS.E := X. - -Module Data := D. -Module MapS := Make(X). -Import MapS. - -Module MD := OrderedTypeFacts(D). -Import MD. - -Definition t := MapS.t D.t. - -Definition cmp e e' := - match D.compare e e' with Eq => true | _ => false end. - -Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => True - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Eq => D.eq e e' /\ eq_list l l' - | _ => False - end - | _, _ => False - end. - -Definition eq m m' := eq_list m.(this) m'.(this). - -Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => False - | nil, _ => True - | _, nil => False - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Lt => True - | Gt => False - | Eq => D.lt e e' \/ (D.eq e e' /\ lt_list l l') - end - end. - -Definition lt m m' := lt_list m.(this) m'.(this). - -Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. -Proof. - intros (l,Hl); induction l. - intros (l',Hl'); unfold eq; simpl. - destruct l'; unfold equal; simpl; intuition. - intros (l',Hl'); unfold eq. - destruct l'. - destruct a; unfold equal; simpl; intuition. - destruct a as (x,e). - destruct p as (x',e'). - unfold equal; simpl. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; simpl; intuition. - unfold cmp at 1. - elim D.compare_spec; try MD.order; simpl. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Mk H3)). - unfold equal, eq in H5; simpl in H5; auto. - destruct (andb_prop _ _ H); clear H. - generalize H0; unfold cmp. - elim D.compare_spec; try MD.order; simpl; try discriminate. - destruct (andb_prop _ _ H); clear H. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Mk H3)). - unfold equal, eq in H6; simpl in H6; auto. -Qed. - -Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. -Proof. - now rewrite eq_equal, equal_spec. -Qed. - -Lemma eq_refl : forall m : t, eq m m. -Proof. - intros (m,Hm); induction m; unfold eq; simpl; auto. - destruct a. - destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. - - split. reflexivity. inversion_clear Hm. apply (IHm H). - - MapS.Raw.MX.order. - - MapS.Raw.MX.order. -Qed. - -Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. -Proof. - intros (m,Hm); induction m; - intros (m', Hm'); destruct m'; unfold eq; simpl; - try destruct a as (x,e); try destruct p as (x',e'); auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - inversion_clear Hm; inversion_clear Hm'. - apply (IHm H0 (Mk H4)); auto. -Qed. - -Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold eq; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - now transitivity e'. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H1 (Mk H6) (Mk H8)); intuition. -Qed. - -Instance eq_equiv : Equivalence eq. -Proof. split; [exact eq_refl|exact eq_sym|exact eq_trans]. Qed. - -Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; transitivity e'; auto. - left; MD.order. - left; MD.order. - right. - split. - transitivity e'; auto. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H2 (Mk H6) (Mk H8)); intuition. -Qed. - -Lemma lt_irrefl : forall m, ~ lt m m. -Proof. - intros (m,Hm); induction m; unfold lt; simpl; auto. - destruct a. - destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. - - intuition. MD.order. inversion_clear Hm. now apply (IHm H0). - - MapS.Raw.MX.order. -Qed. - -Instance lt_strorder : StrictOrder lt. -Proof. split; [exact lt_irrefl|exact lt_trans]. Qed. - -Lemma lt_compat1 : forall m1 m1' m2, eq m1 m1' -> lt m1 m2 -> lt m1' m2. -Proof. - intros (m1,Hm1); induction m1; - intros (m1',Hm1'); destruct m1'; - intros (m2,Hm2); destruct m2; unfold eq, lt; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; simpl; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; MD.order. - right. - split. - MD.order. - inversion_clear Hm1; inversion_clear Hm1'; inversion_clear Hm2. - apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. -Qed. - -Lemma lt_compat2 : forall m1 m2 m2', eq m2 m2' -> lt m1 m2 -> lt m1 m2'. -Proof. - intros (m1,Hm1); induction m1; - intros (m2,Hm2); destruct m2; - intros (m2',Hm2'); destruct m2'; unfold eq, lt; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; simpl; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; MD.order. - right. - split. - MD.order. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm2'. - apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. -Qed. - -Instance lt_compat : Proper (eq==>eq==>iff) lt. -Proof. - intros m1 m1' H1 m2 m2' H2. split; intros. - now apply (lt_compat2 H2), (lt_compat1 H1). - symmetry in H1, H2. - now apply (lt_compat2 H2), (lt_compat1 H1). -Qed. - -Ltac cmp_solve := - unfold eq, lt; simpl; elim X.compare_spec; try Raw.MX.order; auto. - -Fixpoint compare_list m1 m2 := match m1, m2 with -| nil, nil => Eq -| nil, _ => Lt -| _, nil => Gt -| (k1,e1)::m1, (k2,e2)::m2 => - match X.compare k1 k2 with - | Lt => Lt - | Gt => Gt - | Eq => match D.compare e1 e2 with - | Lt => Lt - | Gt => Gt - | Eq => compare_list m1 m2 - end - end -end. - -Definition compare m1 m2 := compare_list m1.(this) m2.(this). - -Lemma compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). -Proof. - unfold CompSpec. - intros (m1,Hm1)(m2,Hm2). unfold compare, eq, lt; simpl. - revert m2 Hm2. - induction m1 as [|(k1,e1) m1 IH1]; destruct m2 as [|(k2,e2) m2]; - try constructor; simpl; intros; auto. - elim X.compare_spec; simpl; try constructor; auto; intros. - elim D.compare_spec; simpl; try constructor; auto; intros. - inversion_clear Hm1; inversion_clear Hm2. - destruct (IH1 H1 _ H3); simpl; try constructor; auto. - elim X.compare_spec; try Raw.MX.order. right. now split. - elim X.compare_spec; try Raw.MX.order. now left. - elim X.compare_spec; try Raw.MX.order; auto. -Qed. - -End Make_ord. diff --git a/theories/MMaps/MMapPositive.v b/theories/MMaps/MMapPositive.v deleted file mode 100644 index adbec70574..0000000000 --- a/theories/MMaps/MMapPositive.v +++ /dev/null @@ -1,698 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* x - | y~1 => rev_append y x~1 - | y~0 => rev_append y x~0 - end. -Local Infix "@" := rev_append (at level 60). -Definition rev x := x@1. - -(** The module of maps over positive keys *) - -Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. - - Module E:=PositiveOrderedTypeBits. - Module ME:=KeyOrderedType E. - - Definition key := positive : Type. - - Definition eq_key {A} (p p':key*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt {A} (p p':key*A) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Definition lt_key {A} (p p':key*A) := E.lt (fst p) (fst p'). - - Instance eqk_equiv {A} : Equivalence (@eq_key A) := _. - Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _. - Instance ltk_strorder {A} : StrictOrder (@lt_key A) := _. - - Inductive tree (A : Type) := - | Leaf : tree A - | Node : tree A -> option A -> tree A -> tree A. - - Arguments Leaf {A}. - - Scheme tree_ind := Induction for tree Sort Prop. - - Definition t := tree. - - Definition empty {A} : t A := Leaf. - - Section A. - Variable A:Type. - - Fixpoint is_empty (m : t A) : bool := - match m with - | Leaf => true - | Node l None r => (is_empty l) &&& (is_empty r) - | _ => false - end. - - Fixpoint find (i : key) (m : t A) : option A := - match m with - | Leaf => None - | Node l o r => - match i with - | xH => o - | xO ii => find ii l - | xI ii => find ii r - end - end. - - Fixpoint mem (i : key) (m : t A) : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | xH => match o with None => false | _ => true end - | xO ii => mem ii l - | xI ii => mem ii r - end - end. - - Fixpoint add (i : key) (v : A) (m : t A) : t A := - match m with - | Leaf => - match i with - | xH => Node Leaf (Some v) Leaf - | xO ii => Node (add ii v Leaf) None Leaf - | xI ii => Node Leaf None (add ii v Leaf) - end - | Node l o r => - match i with - | xH => Node l (Some v) r - | xO ii => Node (add ii v l) o r - | xI ii => Node l o (add ii v r) - end - end. - - (** helper function to avoid creating empty trees that are not leaves *) - - Definition node (l : t A) (o: option A) (r : t A) : t A := - match o,l,r with - | None,Leaf,Leaf => Leaf - | _,_,_ => Node l o r - end. - - Fixpoint remove (i : key) (m : t A) : t A := - match m with - | Leaf => Leaf - | Node l o r => - match i with - | xH => node l None r - | xO ii => node (remove ii l) o r - | xI ii => node l o (remove ii r) - end - end. - - (** [bindings] *) - - Fixpoint xbindings (m : t A) (i : positive) (a: list (key*A)) := - match m with - | Leaf => a - | Node l None r => xbindings l i~0 (xbindings r i~1 a) - | Node l (Some e) r => xbindings l i~0 ((rev i,e) :: xbindings r i~1 a) - end. - - Definition bindings (m : t A) := xbindings m 1 nil. - - (** [cardinal] *) - - Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%nat - | Node l None r => (cardinal l + cardinal r)%nat - | Node l (Some _) r => S (cardinal l + cardinal r) - end. - - (** Specification proofs *) - - Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - - Lemma MapsTo_compat : Proper (E.eq==>eq==>eq==>iff) MapsTo. - Proof. - intros k k' Hk e e' He m m' Hm. red in Hk. now subst. - Qed. - - Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. - Proof. reflexivity. Qed. - - Lemma mem_find : - forall m x, mem x m = match find x m with None => false | _ => true end. - Proof. - induction m; destruct x; simpl; auto. - Qed. - - Lemma mem_spec : forall m x, mem x m = true <-> In x m. - Proof. - unfold In, MapsTo; intros m x; rewrite mem_find. - split. - - destruct (find x m). - exists a; auto. - intros; discriminate. - - destruct 1 as (e0,H0); rewrite H0; auto. - Qed. - - Lemma gleaf : forall (i : key), find i Leaf = None. - Proof. destruct i; simpl; auto. Qed. - - Theorem empty_spec: - forall (i: key), find i empty = None. - Proof. exact gleaf. Qed. - - Lemma is_empty_spec m : - is_empty m = true <-> forall k, find k m = None. - Proof. - induction m; simpl. - - intuition. apply empty_spec. - - destruct o. split; try discriminate. - intros H. now specialize (H xH). - rewrite <- andb_lazy_alt, andb_true_iff, IHm1, IHm2. - clear IHm1 IHm2. - split. - + intros (H1,H2) k. destruct k; simpl; auto. - + intros H; split; intros k. apply (H (xO k)). apply (H (xI k)). - Qed. - - Theorem add_spec1: - forall (m: t A) (i: key) (x: A), find i (add i x m) = Some x. - Proof. - intros m i; revert m. - induction i; destruct m; simpl; auto. - Qed. - - Theorem add_spec2: - forall (m: t A) (i j: key) (x: A), - i <> j -> find j (add i x m) = find j m. - Proof. - intros m i j; revert m i. - induction j; destruct i, m; simpl; intros; - rewrite ?IHj, ?gleaf; auto; try congruence. - Qed. - - Lemma rleaf : forall (i : key), remove i Leaf = Leaf. - Proof. destruct i; simpl; auto. Qed. - - Lemma gnode l o r i : find i (node l o r) = find i (Node l o r). - Proof. - destruct o,l,r; simpl; trivial. - destruct i; simpl; now rewrite ?gleaf. - Qed. - - Opaque node. - - Theorem remove_spec1: - forall (m: t A)(i: key), find i (remove i m) = None. - Proof. - induction m; simpl. - - intros; rewrite rleaf. apply gleaf. - - destruct i; simpl remove; rewrite gnode; simpl; auto. - Qed. - - Theorem remove_spec2: - forall (m: t A)(i j: key), - i <> j -> find j (remove i m) = find j m. - Proof. - induction m; simpl; intros. - - now rewrite rleaf. - - destruct i; simpl; rewrite gnode; destruct j; simpl; trivial; - try apply IHm1; try apply IHm2; congruence. - Qed. - - Local Notation InL := (InA eq_key_elt). - - Lemma xbindings_spec: forall m j acc k e, - InL (k,e) (xbindings m j acc) <-> - InL (k,e) acc \/ exists x, k=(j@x) /\ find x m = Some e. - Proof. - induction m as [|l IHl o r IHr]; simpl. - - intros. split; intro H. - + now left. - + destruct H as [H|[x [_ H]]]. assumption. - now rewrite gleaf in H. - - intros j acc k e. case o as [e'|]; - rewrite IHl, ?InA_cons, IHr; clear IHl IHr; split. - + intros [[H|[H|H]]|H]; auto. - * unfold eq_key_elt, E.eq, fst, snd in H. destruct H as (->,<-). - right. now exists 1. - * destruct H as (x,(->,H)). right. now exists x~1. - * destruct H as (x,(->,H)). right. now exists x~0. - + intros [H|H]; auto. - destruct H as (x,(->,H)). - destruct x; simpl in *. - * left. right. right. now exists x. - * right. now exists x. - * left. left. injection H as ->. reflexivity. - + intros [[H|H]|H]; auto. - * destruct H as (x,(->,H)). right. now exists x~1. - * destruct H as (x,(->,H)). right. now exists x~0. - + intros [H|H]; auto. - destruct H as (x,(->,H)). - destruct x; simpl in *. - * left. right. now exists x. - * right. now exists x. - * discriminate. - Qed. - - Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). - Proof. induction j; intros; simpl; auto. Qed. - - Lemma xbindings_sort m j acc : - sort lt_key acc -> - (forall x p, In x m -> InL p acc -> E.lt (j@x) (fst p)) -> - sort lt_key (xbindings m j acc). - Proof. - revert j acc. - induction m as [|l IHl o r IHr]; simpl; trivial. - intros j acc Hacc Hsacc. destruct o as [e|]. - - apply IHl;[constructor;[apply IHr; [apply Hacc|]|]|]. - + intros. now apply Hsacc. - + case_eq (xbindings r j~1 acc); [constructor|]. - intros (z,e') q H. constructor. - assert (H': InL (z,e') (xbindings r j~1 acc)). - { rewrite H. now constructor. } - clear H q. rewrite xbindings_spec in H'. - destruct H' as [H'|H']. - * apply (Hsacc 1 (z,e')); trivial. now exists e. - * destruct H' as (x,(->,H)). - red. simpl. now apply lt_rev_append. - + intros x (y,e') Hx Hy. inversion_clear Hy. - rewrite H. simpl. now apply lt_rev_append. - rewrite xbindings_spec in H. - destruct H as [H|H]. - * now apply Hsacc. - * destruct H as (z,(->,H)). simpl. - now apply lt_rev_append. - - apply IHl; [apply IHr; [apply Hacc|]|]. - + intros. now apply Hsacc. - + intros x (y,e') Hx H. rewrite xbindings_spec in H. - destruct H as [H|H]. - * now apply Hsacc. - * destruct H as (z,(->,H)). simpl. - now apply lt_rev_append. - Qed. - - Lemma bindings_spec1 m k e : - InA eq_key_elt (k,e) (bindings m) <-> MapsTo k e m. - Proof. - unfold bindings, MapsTo. rewrite xbindings_spec. - split; [ intros [H|(y & H & H')] | intros IN ]. - - inversion H. - - simpl in *. now subst. - - right. now exists k. - Qed. - - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. - unfold bindings. - apply xbindings_sort. constructor. inversion 2. - Qed. - - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. - apply ME.Sort_NoDupA. - apply bindings_spec2. - Qed. - - Lemma xbindings_length m j acc : - length (xbindings m j acc) = (cardinal m + length acc)%nat. - Proof. - revert j acc. - induction m; simpl; trivial; intros. - destruct o; simpl; rewrite IHm1; simpl; rewrite IHm2; - now rewrite ?Nat.add_succ_r, Nat.add_assoc. - Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. - unfold bindings. rewrite xbindings_length. simpl. - symmetry. apply Nat.add_0_r. - Qed. - - (** [map] and [mapi] *) - - Variable B : Type. - - Section Mapi. - - Variable f : key -> option A -> option B. - - Fixpoint xmapi (m : t A) (i : key) : t B := - match m with - | Leaf => Leaf - | Node l o r => Node (xmapi l (i~0)) - (f (rev i) o) - (xmapi r (i~1)) - end. - - End Mapi. - - Definition mapi (f : key -> A -> B) m := - xmapi (fun k => option_map (f k)) m 1. - - Definition map (f : A -> B) m := mapi (fun _ => f) m. - - End A. - - Lemma xgmapi: - forall (A B: Type) (f: key -> option A -> option B) (i j : key) (m: t A), - (forall k, f k None = None) -> - find i (xmapi f m j) = f (j@i) (find i m). - Proof. - induction i; intros; destruct m; simpl; rewrite ?IHi; auto. - Qed. - - Theorem mapi_spec0 : - forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), - find i (mapi f m) = option_map (f i) (find i m). - Proof. - intros. unfold mapi. rewrite xgmapi; simpl; auto. - Qed. - - Lemma mapi_spec : - forall (A B: Type) (f: key -> A -> B) (m: t A) (i:key), - exists j, E.eq j i /\ - find i (mapi f m) = option_map (f j) (find i m). - Proof. - intros. - exists i. split. reflexivity. apply mapi_spec0. - Qed. - - Lemma map_spec : - forall (elt elt':Type)(f:elt->elt')(m: t elt)(x:key), - find x (map f m) = option_map f (find x m). - Proof. - intros; unfold map. apply mapi_spec0. - Qed. - - Section merge. - Variable A B C : Type. - Variable f : key -> option A -> option B -> option C. - - Fixpoint xmerge (m1 : t A)(m2 : t B)(i:positive) : t C := - match m1 with - | Leaf => xmapi (fun k => f k None) m2 i - | Node l1 o1 r1 => - match m2 with - | Leaf => xmapi (fun k o => f k o None) m1 i - | Node l2 o2 r2 => - Node (xmerge l1 l2 (i~0)) - (f (rev i) o1 o2) - (xmerge r1 r2 (i~1)) - end - end. - - Lemma xgmerge: forall (i j: key)(m1:t A)(m2: t B), - (forall i, f i None None = None) -> - find i (xmerge m1 m2 j) = f (j@i) (find i m1) (find i m2). - Proof. - induction i; intros; destruct m1; destruct m2; simpl; auto; - rewrite ?xgmapi, ?IHi; simpl; auto. - Qed. - - End merge. - - Definition merge {A B C}(f:key->option A->option B->option C) m1 m2 := - xmerge - (fun k o1 o2 => match o1,o2 with - | None,None => None - | _, _ => f k o1 o2 - end) - m1 m2 xH. - - Lemma merge_spec1 {A B C}(f:key->option A->option B->option C) : - forall m m' x, - In x m \/ In x m' -> - exists y, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - Proof. - intros. exists x. split. reflexivity. - unfold merge. - rewrite xgmerge; simpl; auto. - rewrite <- 2 mem_spec, 2 mem_find in H. - destruct (find x m); simpl; auto. - destruct (find x m'); simpl; auto. intuition discriminate. - Qed. - - Lemma merge_spec2 {A B C}(f:key->option A->option B->option C) : - forall m m' x, In x (merge f m m') -> In x m \/ In x m'. - Proof. - intros. - rewrite <-mem_spec, mem_find in H. - unfold merge in H. - rewrite xgmerge in H; simpl; auto. - rewrite <- 2 mem_spec, 2 mem_find. - destruct (find x m); simpl in *; auto. - destruct (find x m'); simpl in *; auto. - Qed. - - Section Fold. - - Variables A B : Type. - Variable f : key -> A -> B -> B. - - (** the additional argument, [i], records the current path, in - reverse order (this should be more efficient: we reverse this argument - only at present nodes only, rather than at each node of the tree). - we also use this convention in all functions below - *) - - Fixpoint xfold (m : t A) (v : B) (i : key) := - match m with - | Leaf => v - | Node l (Some x) r => - xfold r (f (rev i) x (xfold l v i~0)) i~1 - | Node l None r => - xfold r (xfold l v i~0) i~1 - end. - Definition fold m i := xfold m i 1. - - End Fold. - - Lemma fold_spec : - forall {A}(m:t A){B}(i : B) (f : key -> A -> B -> B), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. - unfold fold, bindings. intros A m B i f. revert m i. - set (f' := fun a p => f (fst p) (snd p) a). - assert (H: forall m i j acc, - fold_left f' acc (xfold f m i j) = - fold_left f' (xbindings m j acc) i). - { induction m as [|l IHl o r IHr]; intros; trivial. - destruct o; simpl; now rewrite IHr, <- IHl. } - intros. exact (H m i 1 nil). - Qed. - - Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool := - match m1, m2 with - | Leaf, _ => is_empty m2 - | _, Leaf => is_empty m1 - | Node l1 o1 r1, Node l2 o2 r2 => - (match o1, o2 with - | None, None => true - | Some v1, Some v2 => cmp v1 v2 - | _, _ => false - end) - &&& equal cmp l1 l2 &&& equal cmp r1 r2 - end. - - Definition Equal (A:Type)(m m':t A) := - forall y, find y m = find y m'. - Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). - - Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - induction m. - - (* m = Leaf *) - destruct 1 as (E,_); simpl. - apply is_empty_spec; intros k. - destruct (find k m') eqn:F; trivial. - assert (H : In k m') by now exists a. - rewrite <- E in H. - destruct H as (x,H). red in H. now rewrite gleaf in H. - - (* m = Node *) - destruct m'. - + (* m' = Leaf *) - destruct 1 as (E,_); simpl. - destruct o. - * assert (H : In xH (@Leaf A)). - { rewrite <- E. now exists a. } - destruct H as (e,H). now red in H. - * apply andb_true_intro; split; apply is_empty_spec; intros k. - destruct (find k m1) eqn:F; trivial. - assert (H : In (xO k) (@Leaf A)). - { rewrite <- E. exists a; auto. } - destruct H as (x,H). red in H. now rewrite gleaf in H. - destruct (find k m2) eqn:F; trivial. - assert (H : In (xI k) (@Leaf A)). - { rewrite <- E. exists a; auto. } - destruct H as (x,H). red in H. now rewrite gleaf in H. - + (* m' = Node *) - destruct 1. - assert (Equivb cmp m1 m'1). - { split. - intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. - intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. } - assert (Equivb cmp m2 m'2). - { split. - intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. - intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. } - simpl. - destruct o; destruct o0; simpl. - repeat (apply andb_true_intro; split); auto. - apply (H0 xH); red; auto. - generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H4; try discriminate; eauto. - generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H5; try discriminate; eauto. - apply andb_true_intro; split; auto. - Qed. - - Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true -> Equivb cmp m m'. - Proof. - induction m. - (* m = Leaf *) - simpl. - split; intros. - split. - destruct 1; red in H0; destruct k; discriminate. - rewrite is_empty_spec in H. - intros (e,H'). red in H'. now rewrite H in H'. - red in H0; destruct k; discriminate. - (* m = Node *) - destruct m'. - (* m' = Leaf *) - simpl. - destruct o; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. - split; intros. - split; unfold In, MapsTo; destruct 1. - destruct k; simpl in *; try discriminate. - rewrite is_empty_spec in H1. - now rewrite H1 in H. - rewrite is_empty_spec in H0. - now rewrite H0 in H. - destruct k; simpl in *; discriminate. - unfold In, MapsTo; destruct k; simpl in *; discriminate. - (* m' = Node *) - destruct o; destruct o0; simpl; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. - destruct (andb_prop _ _ H0); clear H0. - destruct (IHm1 _ _ H2); clear H2 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - destruct k; unfold In, MapsTo in *; simpl in *. - eapply H4; eauto. - eapply H3; eauto. - congruence. - destruct (andb_prop _ _ H); clear H. - destruct (IHm1 _ _ H0); clear H0 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - destruct k; unfold In, MapsTo in *; simpl in *. - eapply H3; eauto. - eapply H2; eauto. - try discriminate. - Qed. - - Lemma equal_spec : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true <-> Equivb cmp m m'. - Proof. - split. apply equal_2. apply equal_1. - Qed. - -End PositiveMap. - -(** Here come some additional facts about this implementation. - Most are facts that cannot be derivable from the general interface. *) - -Module PositiveMapAdditionalFacts. - Import PositiveMap. - - (* Derivable from the Map interface *) - Theorem gsspec {A} i j x (m: t A) : - find i (add j x m) = if E.eq_dec i j then Some x else find i m. - Proof. - destruct (E.eq_dec i j) as [->|]; - [ apply add_spec1 | apply add_spec2; auto ]. - Qed. - - (* Not derivable from the Map interface *) - Theorem gsident {A} i (m:t A) v : - find i m = Some v -> add i v m = m. - Proof. - revert m. - induction i; destruct m; simpl in *; try congruence. - - intro H; now rewrite (IHi m2 H). - - intro H; now rewrite (IHi m1 H). - Qed. - - Lemma xmapi_ext {A B}(f g: key -> option A -> option B) : - (forall k (o : option A), f k o = g k o) -> - forall m i, xmapi f m i = xmapi g m i. - Proof. - induction m; intros; simpl; auto. now f_equal. - Qed. - - Theorem xmerge_commut{A B C} - (f: key -> option A -> option B -> option C) - (g: key -> option B -> option A -> option C) : - (forall k o1 o2, f k o1 o2 = g k o2 o1) -> - forall m1 m2 i, xmerge f m1 m2 i = xmerge g m2 m1 i. - Proof. - intros E. - induction m1; destruct m2; intros i; simpl; trivial; f_equal; - try apply IHm1_1; try apply IHm1_2; try apply xmapi_ext; - intros; apply E. - Qed. - - Theorem merge_commut{A B C} - (f: key -> option A -> option B -> option C) - (g: key -> option B -> option A -> option C) : - (forall k o1 o2, f k o1 o2 = g k o2 o1) -> - forall m1 m2, merge f m1 m2 = merge g m2 m1. - Proof. - intros E m1 m2. - unfold merge. apply xmerge_commut. - intros k [x1|] [x2|]; trivial. - Qed. - -End PositiveMapAdditionalFacts. diff --git a/theories/MMaps/MMapWeakList.v b/theories/MMaps/MMapWeakList.v deleted file mode 100644 index 656c61e112..0000000000 --- a/theories/MMaps/MMapWeakList.v +++ /dev/null @@ -1,687 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a = a'. -Proof. split; congruence. Qed. - -Module Raw (X:DecidableType). - -Module Import PX := KeyDecidableType X. - -Definition key := X.t. -Definition t (elt:Type) := list (X.t * elt). - -Ltac dec := match goal with - | |- context [ X.eq_dec ?x ?x ] => - let E := fresh "E" in destruct (X.eq_dec x x) as [E|E]; [ | now elim E] - | H : X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [_|E]; [ | now elim E] - | H : ~X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [E|_]; [ now elim H | ] - | |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [E|E] -end. - -Section Elt. - -Variable elt : Type. -Notation NoDupA := (@NoDupA _ eqk). - -(** * [find] *) - -Fixpoint find (k:key) (s: t elt) : option elt := - match s with - | nil => None - | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' - end. - -Lemma find_spec : forall m (Hm:NoDupA m) x e, - find x m = Some e <-> MapsTo x e m. -Proof. - unfold PX.MapsTo. - induction m as [ | (k,e) m IH]; simpl. - - split; inversion 1. - - intros Hm k' e'. rewrite InA_cons. - change (eqke (k',e') (k,e)) with (X.eq k' k /\ e' = e). - inversion_clear Hm. dec. - + rewrite Some_iff; intuition. - elim H. apply InA_eqk with (k',e'); auto. - + rewrite IH; intuition. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (s : t elt) : bool := - match s with - | nil => false - | (k',_) :: l => if X.eq_dec k k' then true else mem k l - end. - -Lemma mem_spec : forall m (Hm:NoDupA m) x, mem x m = true <-> In x m. -Proof. - induction m as [ | (k,e) m IH]; simpl; intros Hm x. - - split. discriminate. inversion_clear 1. inversion H0. - - inversion_clear Hm. rewrite PX.In_cons; simpl. - rewrite <- IH by trivial. - dec; intuition. -Qed. - -(** * [empty] *) - -Definition empty : t elt := nil. - -Lemma empty_spec x : find x empty = None. -Proof. - reflexivity. -Qed. - -Lemma empty_NoDup : NoDupA empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m; simpl; intuition; try discriminate. - specialize (H a). - revert H. now dec. -Qed. - -(* Not part of the exported specifications, used later for [merge]. *) - -Lemma find_eq : forall m (Hm:NoDupA m) x x', - X.eq x x' -> find x m = find x' m. -Proof. - induction m; simpl; auto; destruct a; intros. - inversion_clear Hm. - rewrite (IHm H1 x x'); auto. - dec; dec; trivial. - elim E0. now transitivity x. - elim E. now transitivity x'. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l - end. - -Lemma add_spec1 m x e : find x (add x e m) = Some e. -Proof. - induction m as [ | (k,e') m IH]; simpl. - - now dec. - - dec; simpl; now dec. -Qed. - -Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. -Proof. - intros N. - assert (N' : ~X.eq y x) by now contradict N. - induction m as [ | (k,e') m IH]; simpl. - - dec; trivial. - - repeat (dec; simpl); trivial. elim N. now transitivity k. -Qed. - -Lemma add_InA : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. -Proof. - induction m as [ | (k,e') m IH]; simpl; intros. - - inversion_clear H0. elim H. symmetry; apply H1. inversion_clear H1. - - revert H0; dec; rewrite !InA_cons. - + rewrite E. intuition. - + intuition. right; eapply IH; eauto. -Qed. - -Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). -Proof. - induction m as [ | (k,e') m IH]; simpl; intros Hm x e. - - constructor; auto. now inversion 1. - - inversion_clear Hm. dec; constructor; auto. - + contradict H. apply InA_eqk with (x,e); auto. - + contradict H; apply add_InA with x e; auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) : t elt := - match s with - | nil => nil - | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. - -Lemma remove_spec1 m (Hm: NoDupA m) x : find x (remove x m) = None. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial. - inversion_clear Hm. - repeat (dec; simpl); auto. - destruct (find x m) eqn:F; trivial. - apply find_spec in F; trivial. - elim H. apply InA_eqk with (x,e); auto. -Qed. - -Lemma remove_spec2 m (Hm: NoDupA m) x y : ~X.eq x y -> - find y (remove x m) = find y m. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial; intros E. - inversion_clear Hm. - repeat (dec; simpl); auto. - elim E. now transitivity k. -Qed. - -Lemma remove_InA : forall m (Hm:NoDupA m) x y e, - InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial; intros. - inversion_clear Hm. - revert H; dec; rewrite !InA_cons; intuition. - right; eapply H; eauto. -Qed. - -Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - inversion_clear Hm. - destruct a as (x',e'). - simpl; case (X.eq_dec x x'); auto. - constructor; auto. - contradict H; apply remove_InA with x; auto. -Qed. - -(** * [bindings] *) - -Definition bindings (m: t elt) := m. - -Lemma bindings_spec1 m x e : InA eqke (x,e) (bindings m) <-> MapsTo x e m. -Proof. - reflexivity. -Qed. - -Lemma bindings_spec2w m (Hm:NoDupA m) : NoDupA (bindings m). -Proof. - trivial. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_spec : forall m (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. - induction m as [ | (k,e) m IH]; simpl; auto. -Qed. - -(** * [equal] *) - -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with - | None => false - | Some e' => cmp e e' - end. - -Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - fold (fun k e b => andb (check cmp k e m') b) m true. - -Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). - -Definition Submap (cmp:elt->elt->bool) m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Definition Equivb (cmp:elt->elt->bool) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. -Proof. - unfold Submap, submap. - induction m. - simpl; auto. - destruct a; simpl; intros. - destruct H. - inversion_clear Hm. - assert (H3 : In t0 m'). - { apply H; exists e; auto with *. } - destruct H3 as (e', H3). - assert (H4 : find t0 m' = Some e') by now apply find_spec. - unfold check at 2. rewrite H4. - rewrite (H0 t0); simpl; auto with *. - eapply IHm; auto. - split; intuition. - apply H. - destruct H6 as (e'',H6); exists e''; auto. - apply H0 with k; auto. -Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. -Proof. - unfold Submap, submap. - induction m. - simpl; auto. - intuition. - destruct H0; inversion H0. - inversion H0. - - destruct a; simpl; intros. - inversion_clear Hm. - rewrite andb_b_true in H. - assert (check cmp t0 e m' = true). - clear H1 H0 Hm' IHm. - set (b:=check cmp t0 e m') in *. - generalize H; clear H; generalize b; clear b. - induction m; simpl; auto; intros. - destruct a; simpl in *. - destruct (andb_prop _ _ (IHm _ H)); auto. - rewrite H2 in H. - destruct (IHm H1 m' Hm' cmp H); auto. - unfold check in H2. - case_eq (find t0 m'); [intros e' H5 | intros H5]; - rewrite H5 in H2; try discriminate. - split; intros. - destruct H6 as (e0,H6); inversion_clear H6. - compute in H7; destruct H7; subst. - exists e'. - apply PX.MapsTo_eq with t0; auto with *. - apply find_spec; auto. - apply H3. - exists e0; auto. - inversion_clear H6. - compute in H8; destruct H8; subst. - assert (H8 : MapsTo t0 e'0 m'). { eapply PX.MapsTo_eq; eauto. } - apply find_spec in H8; trivial. congruence. - apply H4 with k; auto. -Qed. - -(** Specification of [equal] *) - -Lemma equal_spec : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - equal cmp m m' = true <-> Equivb cmp m m'. -Proof. - unfold Equivb, equal. - split. - - intros. - destruct (andb_prop _ _ H); clear H. - generalize (submap_2 Hm Hm' H0). - generalize (submap_2 Hm' Hm H1). - firstorder. - - intuition. - apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. -Qed. -End Elt. -Section Elt2. -Variable elt elt' : Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -(** Specification of [map] *) - -Lemma map_spec (f:elt->elt')(m:t elt)(x:key) : - find x (map f m) = option_map f (find x m). -Proof. - induction m as [ | (k,e) m IH]; simpl; trivial. - dec; simpl; trivial. -Qed. - -Lemma map_NoDup m (Hm : NoDupA (@eqk elt) m)(f:elt->elt') : - NoDupA (@eqk elt') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - inversion H. - destruct a; inversion H; auto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_spec (f:key->elt->elt')(m:t elt)(x:key) : - exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m as [ | (k,e) m IH]; simpl; trivial. - - now exists x. - - dec; simpl. - + now exists k. - + destruct IH as (y,(Hy,H)). now exists y. -Qed. - -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), - NoDupA (@eqk elt') (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm; auto. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - inversion_clear H. - destruct a; inversion_clear H; auto. -Qed. - -End Elt2. - -Lemma mapfst_InA {elt}(m:t elt) x : - InA X.eq x (List.map fst m) <-> In x m. -Proof. - induction m as [| (k,e) m IH]; simpl; auto. - - split; inversion 1. inversion H0. - - rewrite InA_cons, In_cons. simpl. now rewrite IH. -Qed. - -Lemma mapfst_NoDup {elt}(m:t elt) : - NoDupA X.eq (List.map fst m) <-> NoDupA eqk m. -Proof. - induction m as [| (k,e) m IH]; simpl. - - split; constructor. - - split; inversion_clear 1; constructor; try apply IH; trivial. - + contradict H0. rewrite mapfst_InA. eapply In_alt'; eauto. - + rewrite mapfst_InA. contradict H0. now apply In_alt'. -Qed. - -Lemma filter_NoDup f (m:list key) : - NoDupA X.eq m -> NoDupA X.eq (List.filter f m). -Proof. - induction 1; simpl. - - constructor. - - destruct (f x); trivial. constructor; trivial. - contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)). - exists y; split; trivial. now rewrite filter_In in H. -Qed. - -Lemma NoDupA_unique_repr (l:list key) x y : - NoDupA X.eq l -> X.eq x y -> List.In x l -> List.In y l -> x = y. -Proof. - intros H E Hx Hy. - induction H; simpl in *. - - inversion Hx. - - intuition; subst; trivial. - elim H. apply InA_alt. now exists y. - elim H. apply InA_alt. now exists x. -Qed. - -Section Elt3. - -Variable elt elt' elt'' : Type. - -Definition restrict (m:t elt)(k:key) := - match find k m with - | None => true - | Some _ => false - end. - -Definition domains (m:t elt)(m':t elt') := - List.map fst m ++ List.filter (restrict m) (List.map fst m'). - -Lemma domains_InA m m' (Hm : NoDupA eqk m) x : - InA X.eq x (domains m m') <-> In x m \/ In x m'. -Proof. - unfold domains. - assert (Proper (X.eq==>eq) (restrict m)). - { intros k k' Hk. unfold restrict. now rewrite (find_eq Hm Hk). } - rewrite InA_app_iff, filter_InA, !mapfst_InA; intuition. - unfold restrict. - destruct (find x m) eqn:F. - - left. apply find_spec in F; trivial. now exists e. - - now right. -Qed. - -Lemma domains_NoDup m m' : NoDupA eqk m -> NoDupA eqk m' -> - NoDupA X.eq (domains m m'). -Proof. - intros Hm Hm'. unfold domains. - apply NoDupA_app; auto with *. - - now apply mapfst_NoDup. - - now apply filter_NoDup, mapfst_NoDup. - - intros x. - rewrite mapfst_InA. intros (e,H). - apply find_spec in H; trivial. - rewrite InA_alt. intros (y,(Hy,H')). - rewrite (find_eq Hm Hy) in H. - rewrite filter_In in H'. destruct H' as (_,H'). - unfold restrict in H'. now rewrite H in H'. -Qed. - -Fixpoint fold_keys (f:key->option elt'') l := - match l with - | nil => nil - | k::l => - match f k with - | Some e => (k,e)::fold_keys f l - | None => fold_keys f l - end - end. - -Lemma fold_keys_In f l x e : - List.In (x,e) (fold_keys f l) <-> List.In x l /\ f x = Some e. -Proof. - induction l as [|k l IH]; simpl. - - intuition. - - destruct (f k) eqn:F; simpl; rewrite IH; clear IH; intuition; - try left; congruence. -Qed. - -Lemma fold_keys_NoDup f l : - NoDupA X.eq l -> NoDupA eqk (fold_keys f l). -Proof. - induction 1; simpl. - - constructor. - - destruct (f x); trivial. - constructor; trivial. contradict H. - apply InA_alt in H. destruct H as ((k,e'),(E,H)). - rewrite fold_keys_In in H. - apply InA_alt. exists k. now split. -Qed. - -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition merge m m' : t elt'' := - fold_keys (fun k => f k (find k m) (find k m')) (domains m m'). - -Lemma merge_NoDup m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m') : - NoDupA (@eqk elt'') (merge m m'). -Proof. - now apply fold_keys_NoDup, domains_NoDup. -Qed. - -Lemma merge_spec1 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : - In x m \/ In x m' -> - exists y:key, X.eq y x /\ - find x (merge m m') = f y (find x m) (find x m'). -Proof. - assert (Hmm' : NoDupA eqk (merge m m')) by now apply merge_NoDup. - rewrite <- domains_InA; trivial. - rewrite InA_alt. intros (y,(Hy,H)). - exists y; split; [easy|]. - rewrite (find_eq Hm Hy), (find_eq Hm' Hy). - destruct (f y (find y m) (find y m')) eqn:F. - - apply find_spec; trivial. - red. apply InA_alt. exists (y,e). split. now split. - unfold merge. apply fold_keys_In. now split. - - destruct (find x (merge m m')) eqn:F'; trivial. - rewrite <- F; clear F. symmetry. - apply find_spec in F'; trivial. - red in F'. rewrite InA_alt in F'. - destruct F' as ((y',e'),(E,F')). - unfold merge in F'; rewrite fold_keys_In in F'. - destruct F' as (H',F'). - compute in E; destruct E as (Hy',<-). - replace y with y'; trivial. - apply (@NoDupA_unique_repr (domains m m')); auto. - now apply domains_NoDup. - now transitivity x. -Qed. - -Lemma merge_spec2 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : - In x (merge m m') -> In x m \/ In x m'. -Proof. - rewrite <- domains_InA; trivial. - intros (e,H). red in H. rewrite InA_alt in H. destruct H as ((k,e'),(E,H)). - unfold merge in H; rewrite fold_keys_In in H. destruct H as (H,_). - apply InA_alt. exists k. split; trivial. now destruct E. -Qed. - -End Elt3. -End Raw. - - -Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. - - Module E := X. - Definition key := E.t. - Definition eq_key {elt} := @Raw.PX.eqk elt. - Definition eq_key_elt {elt} := @Raw.PX.eqke elt. - - Record t_ (elt:Type) := Mk - {this :> Raw.t elt; - nodup : NoDupA Raw.PX.eqk this}. - Definition t := t_. - - Definition empty {elt} : t elt := Mk (Raw.empty_NoDup elt). - -Section Elt. - Variable elt elt' elt'':Type. - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition find x m : option elt := Raw.find x m.(this). - Definition mem x m : bool := Raw.mem x m.(this). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (Raw.add_NoDup m.(nodup) x e). - Definition remove x m : t elt := Mk (Raw.remove_NoDup m.(nodup) x). - Definition map f m : t elt' := Mk (Raw.map_NoDup m.(nodup) f). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (Raw.mapi_NoDup m.(nodup) f). - Definition merge f m (m':t elt') : t elt'' := - Mk (Raw.merge_NoDup f m.(nodup) m'.(nodup)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := length m.(this). - Definition fold {A}(f:key->elt->A->A) m (i:A) : A := Raw.fold f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := Raw.Equivb cmp m.(this) m'.(this). - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. - Qed. - - Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. - Proof. exact (Raw.find_spec m.(nodup)). Qed. - - Lemma mem_spec m : forall x, mem x m = true <-> In x m. - Proof. exact (Raw.mem_spec m.(nodup)). Qed. - - Lemma empty_spec : forall x, find x empty = None. - Proof. exact (Raw.empty_spec _). Qed. - - Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). - Proof. exact (Raw.is_empty_spec m.(this)). Qed. - - Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. - Proof. exact (Raw.add_spec1 m.(this)). Qed. - Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. - Proof. exact (Raw.add_spec2 m.(this)). Qed. - - Lemma remove_spec1 m : forall x, find x (remove x m) = None. - Proof. exact (Raw.remove_spec1 m.(nodup)). Qed. - Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. - Proof. exact (Raw.remove_spec2 m.(nodup)). Qed. - - Lemma bindings_spec1 m : forall x e, - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. exact (Raw.bindings_spec1 m.(this)). Qed. - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. exact (Raw.bindings_spec2w m.(nodup)). Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. reflexivity. Qed. - - Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. exact (Raw.fold_spec m.(this)). Qed. - - Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. - Proof. exact (Raw.equal_spec m.(nodup) m'.(nodup)). Qed. - -End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m : - forall x, find x (map f m) = option_map f (find x m). - Proof. exact (Raw.map_spec f m.(this)). Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : - forall x, exists y, - E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. exact (Raw.mapi_spec f m.(this)). Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x m \/ In x m' -> - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). - Proof. exact (Raw.merge_spec1 f m.(nodup) m'.(nodup)). Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x (merge f m m') -> In x m \/ In x m'. - Proof. exact (Raw.merge_spec2 m.(nodup) m'.(nodup)). Qed. - -End Make. diff --git a/theories/MMaps/MMaps.v b/theories/MMaps/MMaps.v deleted file mode 100644 index 054d07225a..0000000000 --- a/theories/MMaps/MMaps.v +++ /dev/null @@ -1,16 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* occur_var env id concl) false hyp0 in + let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env in + let dep_in_concl = Option.cata (fun id -> occur_var env id concl) false hyp0 in + let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = -- cgit v1.2.3 From 33617aa7b36f157f6314a83dde6ba45164ddd05b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 14 Dec 2015 15:04:52 +0100 Subject: Changing "P is assumed" to "P is declared". The term "assumed" refers more to the type of the object than to the name of the object. It is particularly misguiding when P:Prop since P is assumed would suggest that a proof of P is assumed, and not that the variable P itself is declared (see discussion with P. Castéran on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015). --- library/declare.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/library/declare.ml b/library/declare.ml index c1697a434a..40858eeec6 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -413,7 +413,10 @@ let definition_message id = Flags.if_verbose msg_info (pr_id id ++ str " is defined") let assumption_message id = - Flags.if_verbose msg_info (pr_id id ++ str " is assumed") + (* Changing "assumed" to "declared", "assuming" referring more to + the type of the object than to the name of the object (see + discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) + Flags.if_verbose msg_info (pr_id id ++ str " is declared") (** Global universe names, in a different summary *) -- cgit v1.2.3 From 10fd3ae92d9077a1ef0ad19e35e205b1941a6278 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 1 Jan 2016 12:06:31 +0100 Subject: Continuing 003fe3d5e on parsing positions. - Being stricter on the ordinal suffix accepted (only st for 1, 21, etc, nd for 2, 22, etc., etc.) - Reporting when the suffix is not the expected one (rather than considering that, e.g. 2st, is two tokens, a number then an identifier). --- parsing/lexer.ml4 | 45 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 35 insertions(+), 10 deletions(-) diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index d7941bedb4..d6d03cb85d 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -80,6 +80,7 @@ module Error = struct | Undefined_token | Bad_token of string | UnsupportedUnicode of int + | IncorrectIndex of char list exception E of t @@ -92,7 +93,16 @@ module Error = struct | Undefined_token -> "Undefined token" | Bad_token tok -> Format.sprintf "Bad token %S" tok | UnsupportedUnicode x -> - Printf.sprintf "Unsupported Unicode character (0x%x)" x) + Printf.sprintf "Unsupported Unicode character (0x%x)" x + | IncorrectIndex l -> + let l = List.map (fun c -> Char.code c - 48) l in + let s = match l with + | c::d::l -> + let l = List.map string_of_int (List.rev l) in + String.concat "" l ^ CString.ordinal (10 * d + c) + | [c] -> CString.ordinal c + | [] -> assert false in + Printf.sprintf "%s expected" s) (* Require to fix the Camlp4 signature *) let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) @@ -269,15 +279,30 @@ let check_no_char s = | [_;_] -> true | _ -> assert false -let rec number_or_index c len = parser - | [< ' ('0'..'9' as c); s >] -> number_or_index c (store len c) s - | [< s >] -> +let is_teen = function + | _::'1'::l -> true + | _ -> false + +let is_gt3 = function + | c::_ when c == '1' || c == '2' || c == '3' -> false + | _ -> true + +let check_gt3 l loc len = + if not (l == ['0']) && (is_teen l || is_gt3 l) then (false, len) + else err loc (IncorrectIndex l) + +let check_n n l loc len = + if List.hd l == n && not (is_teen l) then (false, len) + else err loc (IncorrectIndex l) + +let rec number_or_index bp l len = parser + | [< ' ('0'..'9' as c); s >] -> number_or_index bp (c::l) (store len c) s + | [< s >] ep -> match Stream.npeek 2 s with - | ['s';'t'] when c = '1' && check_no_char s -> njunk 2 s; false, len - | ['n';'d'] when c = '2' && check_no_char s -> njunk 2 s; false, len - | ['r';'d'] when c = '3' && check_no_char s -> njunk 2 s; false, len - | ['t';'h'] when not (len=1 && c='0') && check_no_char s -> - njunk 2 s; false, len + | ['s';'t'] when check_no_char s -> njunk 2 s; check_n '1' l (bp,ep) len + | ['n';'d'] when check_no_char s -> njunk 2 s; check_n '2' l (bp,ep) len + | ['r';'d'] when check_no_char s -> njunk 2 s; check_n '3' l (bp,ep) len + | ['t';'h'] when check_no_char s -> njunk 2 s; check_gt3 l (bp,ep) len | _ -> true, len let rec string in_comments bp len = parser @@ -527,7 +552,7 @@ let rec next_token = parser bp let id = get_buff len in comment_stop bp; (try find_keyword id s with Not_found -> IDENT id), (bp, ep) - | [< ' ('0'..'9' as c); (b,len) = number_or_index c (store 0 c) >] ep -> + | [< ' ('0'..'9' as c); (b,len) = number_or_index bp [c] (store 0 c) >] ep -> comment_stop bp; (if b then INT (get_buff len) else INDEX (get_buff len)), (bp, ep) | [< ''\"'; len = string None bp 0 >] ep -> -- cgit v1.2.3 From 072aa1f8c4e3ff08d1343e1f068a41648c06b7fd Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 14 Jan 2016 10:07:31 +0100 Subject: Updating and improving the documentation of intros patterns. In particular, documenting bracketing of last pattern on by default. --- doc/common/macros.tex | 1 + doc/refman/RefMan-tac.tex | 112 +++++++++++++++++++++------------------------- 2 files changed, 51 insertions(+), 62 deletions(-) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 3b12f259b6..077e2f0dfb 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -198,6 +198,7 @@ \newcommand{\pattern}{\nterm{pattern}} % pattern for pattern-matching \newcommand{\orpattern}{\nterm{or\_pattern}} \newcommand{\intropattern}{\nterm{intro\_pattern}} +\newcommand{\intropatternlist}{\nterm{intro\_pattern\_list}} \newcommand{\disjconjintropattern}{\nterm{disj\_conj\_intro\_pattern}} \newcommand{\namingintropattern}{\nterm{naming\_intro\_pattern}} \newcommand{\termpattern}{\nterm{term\_pattern}} % term with holes diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 815594d8e9..36bd036a95 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -802,7 +802,7 @@ the tactic {\tt intro} applies the tactic {\tt hnf} until the tactic \end{Variants} -\subsection{\tt intros {\intropattern} \mbox{\dots} \intropattern} +\subsection{\tt intros {\intropatternlist}} \label{intros-pattern} \tacindex{intros \intropattern} \index{Introduction patterns} @@ -811,9 +811,11 @@ the tactic {\tt intro} applies the tactic {\tt hnf} until the tactic \index{Disjunctive/conjunctive introduction patterns} \index{Equality introduction patterns} - -This extension of the tactic {\tt intros} combines introduction of -variables or hypotheses and case analysis. An {\em introduction pattern} is +This extension of the tactic {\tt intros} allows to apply tactics on +the fly on the variables or hypotheses which have been introduced. An +{\em introduction pattern list} {\intropatternlist} is a list of +introduction patterns possibly containing the filling introduction +patterns {\tt *} and {\tt **}. An {\em introduction pattern} is either: \begin{itemize} \item a {\em naming introduction pattern}, i.e. either one of: @@ -827,7 +829,7 @@ either: \item a {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: \begin{itemize} \item a disjunction of lists of patterns: - {\tt [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} + {\tt [$\intropatternlist_1$ | \dots\ | $\intropatternlist_n$]} \item a conjunction of patterns: {\tt ($p_1$ , \dots\ , $p_n$)} \item a list of patterns {\tt ($p_1$ \&\ \dots\ \&\ $p_n$)} for sequence of right-associative binary constructs @@ -844,10 +846,6 @@ either: \item the wildcard: {\tt \_} \end{itemize} -Introduction patterns can be combined into lists. An {\em introduction - pattern list} is a list of introduction patterns possibly containing -the filling introduction patterns {\tt *} and {\tt **}. - Assuming a goal of type $Q \to P$ (non-dependent product), or of type $\forall x:T,~P$ (dependent product), the behavior of {\tt intros $p$} is defined inductively over the structure of the @@ -860,21 +858,22 @@ introduction pattern~$p$: \item introduction on \texttt{\ident} behaves as described in Section~\ref{intro}; \item introduction over a disjunction of list of patterns {\tt - [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} - expects the product to be over an inductive type - whose number of constructors is $n$ (or more generally over a type - of conclusion an inductive type built from $n$ constructors, - e.g. {\tt C -> A\textbackslash/B} with $n=2$ since {\tt - A\textbackslash/B} has 2 constructors): it destructs the introduced - hypothesis as {\tt destruct} (see Section~\ref{destruct}) would and - applies on each generated subgoal the corresponding tactic; - \texttt{intros}~$p_{i1}$ {\ldots} $p_{im_i}$; if the disjunctive - pattern is part of a sequence of patterns, then {\Coq} completes the - pattern so that all the arguments of the constructors of the - inductive type are introduced (for instance, the list of patterns - {\tt [$\;$|$\;$] H} applied on goal {\tt forall x:nat, x=0 -> 0=x} - behaves the same as the list of patterns {\tt [$\,$|$\,$?$\,$] H}, - up to one exception explained in the Remark below); + [$\intropatternlist_{1}$ | \dots\ | $\intropatternlist_n$]} expects + the product to be over an inductive type whose number of + constructors is $n$ (or more generally over a type of conclusion an + inductive type built from $n$ constructors, e.g. {\tt C -> + A\textbackslash/B} with $n=2$ since {\tt A\textbackslash/B} has 2 + constructors): it destructs the introduced hypothesis as {\tt + destruct} (see Section~\ref{destruct}) would and applies on each + generated subgoal the corresponding tactic; + \texttt{intros}~$\intropatternlist_i$. The introduction patterns in + $\intropatternlist_i$ are expected to consume no more than the + number of arguments of the $i^{\mbox{\scriptsize th}}$ + constructor. If it consumes less, then {\Coq} completes the pattern + so that all the arguments of the constructors of the inductive type + are introduced (for instance, the list of patterns {\tt [$\;$|$\;$] + H} applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same + as the list of patterns {\tt [$\,$|$\,$?$\,$] H}); \item introduction over a conjunction of patterns {\tt ($p_1$, \ldots, $p_n$)} expects the goal to be a product over an inductive type $I$ with a single constructor that itself has at least $n$ arguments: it @@ -926,19 +925,6 @@ introduction pattern~$p$: not any more a quantification or an implication. \end{itemize} -Then, if $p_1$ ... $p_n$ is a list of introduction patterns possibly -containing {\tt *} or {\tt **}, {\tt intros $p_1$ ... $p_n$} -\begin{itemize} -\item introduction over {\tt *} introduces all forthcoming quantified - variables appearing in a row; -\item introduction over {\tt **} introduces all forthcoming quantified - variables or hypotheses until the goal is not any more a - quantification or an implication; -\item introduction over an introduction pattern $p$ introduces the - forthcoming quantified variables or premise of the goal and applies - the introduction pattern $p$ to it. -\end{itemize} - \Example \begin{coq_example} @@ -949,37 +935,39 @@ intros * [a | (_,c)] f. Abort. \end{coq_eval} -\Rem {\tt intros $p_1~\ldots~p_n$} is not fully equivalent to -\texttt{intros $p_1$;\ldots; intros $p_n$} for the following reasons: -\label{bracketing-last} -\begin{itemize} -\item A wildcard pattern never succeeds when applied isolated on a - dependent product, while it succeeds as part of a list of - introduction patterns if the hypotheses that depends on it are - erased too. -\item A disjunctive or conjunctive pattern followed by an introduction - pattern forces the introduction in the context of all arguments of - the constructors before applying the next pattern while a terminal - disjunctive or conjunctive pattern does not. Here is an example - -\begin{coq_example} -Goal forall n:nat, n = 0 -> n = 0. -intros [ | ] H. -Show 2. -Undo. -intros [ | ]; intros H. -Show 2. -\end{coq_example} +\Rem {\tt intros $p_1~\ldots~p_n$} is not equivalent to \texttt{intros + $p_1$;\ldots; intros $p_n$} for the following reason: If one of the +$p_i$ is a wildcard pattern, he might succeed in the first case +because the further hypotheses it depends in are eventually erased too +while it might fail in the second case because of dependencies in +hypotheses which are not yet introduced (and a fortiori not yet +erased). + +\Rem In {\tt intros $\intropatternlist$}, if the last introduction +pattern is a disjunctive or conjunctive pattern {\tt + [$\intropatternlist_1$ | \dots\ | $\intropatternlist_n$]}, the +completion of $\intropatternlist_i$ so that all the arguments of the +$i^{\mbox{\scriptsize th}}$ constructors of the corresponding +inductive type are introduced can be controlled with the +following option: +\optindex{Bracketing Last Introduction Pattern} -\end{itemize} +\begin{quote} +{\tt Set Bracketing Last Introduction Pattern} +\end{quote} -This later behavior can be avoided by setting the following option: +Force completion, if needed, when the last introduction pattern is a +disjunctive or conjunctive pattern (this is the default). \begin{quote} -\optindex{Bracketing Last Introduction Pattern} -{\tt Set Bracketing Last Introduction Pattern} +{\tt Unset Bracketing Last Introduction Pattern} \end{quote} +Deactivate completion when the last introduction pattern is a disjunctive +or conjunctive pattern. + + + \subsection{\tt clear \ident} \tacindex{clear} \label{clear} -- cgit v1.2.3 From 00e27eac9fe207d754952c1ddb0e12861ee293c9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 30 Dec 2015 21:17:02 +0100 Subject: Moving is_quantified_hypothesis to new proof engine. --- tactics/elim.ml | 4 ++-- tactics/tacinterp.ml | 2 +- tactics/tactics.ml | 20 ++++++++++---------- tactics/tactics.mli | 4 ++-- 4 files changed, 15 insertions(+), 15 deletions(-) diff --git a/tactics/elim.ml b/tactics/elim.ml index d3aa160925..182240b554 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -161,8 +161,8 @@ let induction_trailer abs_i abs_j bargs = let double_ind h1 h2 = Proofview.Goal.nf_enter { enter = begin fun gl -> - let abs_i = of_old (depth_of_quantified_hypothesis true h1) gl in - let abs_j = of_old (depth_of_quantified_hypothesis true h2) gl in + let abs_i = depth_of_quantified_hypothesis true h1 gl in + let abs_j = depth_of_quantified_hypothesis true h2 gl in let abs = if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else if abs_i > abs_j then Proofview.tclUNIT (abs_j,abs_i) else diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 74ddd6b575..5f5adaafb5 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1852,7 +1852,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (* TODO: move sigma as a side-effect *) (* spiwack: the [*p] variants are for printing *) let cp = c in - let c = Tacmach.New.of_old (fun gl -> interp_induction_arg ist gl c) gl in + let c = interp_induction_arg ist gl c in let ipato = interp_intro_pattern_naming_option ist env sigma ipato in let ipatsp = ipats in let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 00afc99e8e..c949a58b1d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -910,25 +910,25 @@ let intros_replacing ids = (* User-level introduction tactics *) -let pf_lookup_hypothesis_as_renamed env ccl = function +let lookup_hypothesis_as_renamed env ccl = function | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id -let pf_lookup_hypothesis_as_renamed_gen red h gl = - let env = pf_env gl in +let lookup_hypothesis_as_renamed_gen red h gl = + let env = Proofview.Goal.env gl in let rec aux ccl = - match pf_lookup_hypothesis_as_renamed env ccl h with + match lookup_hypothesis_as_renamed env ccl h with | None when red -> aux (snd ((fst (Redexpr.reduction_of_red_expr env (Red true))) - env (project gl) ccl)) + env (Sigma.to_evar_map (Proofview.Goal.sigma gl)) ccl)) | x -> x in - try aux (Tacmach.pf_concl gl) + try aux (Proofview.Goal.concl gl) with Redelimination -> None -let is_quantified_hypothesis id g = - match pf_lookup_hypothesis_as_renamed_gen false (NamedHyp id) g with +let is_quantified_hypothesis id gl = + match lookup_hypothesis_as_renamed_gen false (NamedHyp id) gl with | Some _ -> true | None -> false @@ -940,7 +940,7 @@ let msg_quantified_hypothesis = function str " non dependent hypothesis" let depth_of_quantified_hypothesis red h gl = - match pf_lookup_hypothesis_as_renamed_gen red h gl with + match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> errorlabstrm "lookup_quantified_hypothesis" @@ -951,7 +951,7 @@ let depth_of_quantified_hypothesis red h gl = let intros_until_gen red h = Proofview.Goal.nf_enter { enter = begin fun gl -> - let n = Tacmach.New.of_old (depth_of_quantified_hypothesis red h) gl in + let n = depth_of_quantified_hypothesis red h gl in Tacticals.New.tclDO n (if red then introf else intro) end } diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 2ae72f4a5a..32483d0506 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -25,7 +25,7 @@ open Locus (** {6 General functions. } *) -val is_quantified_hypothesis : Id.t -> goal sigma -> bool +val is_quantified_hypothesis : Id.t -> ([`NF],'b) Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) @@ -73,7 +73,7 @@ val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> goal sigma -> int + bool -> quantified_hypothesis -> ([`NF],'b) Proofview.Goal.t -> int val intros_until : quantified_hypothesis -> unit Proofview.tactic -- cgit v1.2.3 From 67b9b34d409c793dc449104525684852353ee064 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Jan 2016 21:40:23 +0100 Subject: Removing ident and var generic arguments. --- grammar/argextend.ml4 | 2 -- grammar/q_coqast.ml4 | 2 -- interp/constrarg.ml | 8 ++++++-- lib/genarg.ml | 12 ------------ lib/genarg.mli | 4 +--- printing/pptactic.ml | 10 ++++------ tactics/tacintern.ml | 11 ++++++----- tactics/tacinterp.ml | 14 +++++++------- tactics/tacsubst.ml | 5 ++--- 9 files changed, 26 insertions(+), 42 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 639097afa8..9abe5d7cfc 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -30,8 +30,6 @@ let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function - | IdentArgType -> <:expr< Constrarg.wit_ident >> - | VarArgType -> <:expr< Constrarg.wit_var >> | ConstrArgType -> <:expr< Constrarg.wit_constr >> | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index 494ec6ba29..798d428e98 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -223,8 +223,6 @@ let mlexpr_of_red_expr = function <:expr< Genredexpr.ExtraRedExpr $mlexpr_of_string s$ >> let rec mlexpr_of_argtype loc = function - | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> - | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> diff --git a/interp/constrarg.ml b/interp/constrarg.ml index 44623f9c9a..94c13fe796 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -31,9 +31,11 @@ let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob let wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type = Genarg.make0 None "tactic" -let wit_ident = unsafe_of_type IdentArgType +let wit_ident = + Genarg.make0 None "ident" -let wit_var = unsafe_of_type VarArgType +let wit_var = + Genarg.make0 ~dyn:(val_tag (topwit wit_ident)) None "var" let wit_ref = Genarg.make0 None "ref" @@ -68,6 +70,8 @@ let wit_clause_dft_concl = let () = register_name0 wit_int_or_var "Constrarg.wit_int_or_var"; register_name0 wit_ref "Constrarg.wit_ref"; + register_name0 wit_ident "Constrarg.wit_ident"; + register_name0 wit_var "Constrarg.wit_var"; register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern"; register_name0 wit_tactic "Constrarg.wit_tactic"; register_name0 wit_sort "Constrarg.wit_sort"; diff --git a/lib/genarg.ml b/lib/genarg.ml index 6108c15555..af9ea70ec5 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -56,9 +56,6 @@ struct end type argument_type = - (* Basic types *) - | IdentArgType - | VarArgType (* Specific types *) | ConstrArgType | ListArgType of argument_type @@ -67,8 +64,6 @@ type argument_type = | ExtraArgType of string let rec argument_type_eq arg1 arg2 = match arg1, arg2 with -| IdentArgType, IdentArgType -> true -| VarArgType, VarArgType -> true | ConstrArgType, ConstrArgType -> true | ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 | OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 @@ -78,8 +73,6 @@ let rec argument_type_eq arg1 arg2 = match arg1, arg2 with | _ -> false let rec pr_argument_type = function -| IdentArgType -> str "ident" -| VarArgType -> str "var" | ConstrArgType -> str "constr" | ListArgType t -> pr_argument_type t ++ spc () ++ str "list" | OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" @@ -204,13 +197,10 @@ let default_empty_value t = (** Beware: keep in sync with the corresponding types *) let base_create n = Val.Base (Dyn.create n) -let ident_T = base_create "ident" let genarg_T = base_create "genarg" let constr_T = base_create "constr" let rec val_tag = function -| IdentArgType -> cast_tag ident_T -| VarArgType -> cast_tag ident_T (** Must ensure that toplevel types of Var and Ident agree! *) | ConstrArgType -> cast_tag constr_T | ExtraArgType s -> cast_tag (String.Map.find s !arg0_map).dyn @@ -232,8 +222,6 @@ let try_prj wit v = match prj (val_tag wit) v with let rec val_cast : type a. a typed_abstract_argument_type -> Val.t -> a = fun wit v -> match unquote wit with -| IdentArgType -| VarArgType | ConstrArgType | ExtraArgType _ -> try_prj wit v | ListArgType t -> diff --git a/lib/genarg.mli b/lib/genarg.mli index 674ee97ae8..8d929f9f69 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -212,10 +212,8 @@ val val_cast : 'a typed_abstract_argument_type -> Val.t -> 'a type argument_type = (** Basic types *) - | IdentArgType - | VarArgType - (** Specific types *) | ConstrArgType + (** Specific types *) | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type diff --git a/printing/pptactic.ml b/printing/pptactic.ml index a5716279f3..df5f57dac1 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -267,8 +267,6 @@ module Make let rec pr_raw_generic_rec prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with - | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x) - | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x) | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) | ListArgType _ -> let list_unpacker wit l = @@ -297,8 +295,6 @@ module Make let rec pr_glb_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x) - | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x) | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) | ListArgType _ -> let list_unpacker wit l = @@ -326,8 +322,6 @@ module Make let rec pr_top_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) - | VarArgType -> pr_id (out_gen (topwit wit_var) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) | ListArgType _ -> let list_unpacker wit l = @@ -1415,6 +1409,10 @@ let () = (pr_or_var int) (pr_or_var int) int; Genprint.register_print0 Constrarg.wit_ref pr_reference (pr_or_var (pr_located pr_global)) pr_global; + Genprint.register_print0 Constrarg.wit_ident + pr_id pr_id pr_id; + Genprint.register_print0 Constrarg.wit_var + (pr_located pr_id) (pr_located pr_id) pr_id; Genprint.register_print0 Constrarg.wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index e6273401dd..ac0c4b266b 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -720,11 +720,6 @@ and intern_match_rule onlytac ist = function and intern_genarg ist x = match genarg_tag x with - | IdentArgType -> - let lf = ref Id.Set.empty in - map_raw wit_ident (intern_ident lf) ist x - | VarArgType -> - map_raw wit_var intern_hyp ist x | ConstrArgType -> map_raw wit_constr intern_constr ist x | ListArgType _ -> @@ -823,9 +818,15 @@ let () = in Genintern.register_intern0 wit_clause_dft_concl intern_clause +let intern_ident' ist id = + let lf = ref Id.Set.empty in + (ist, intern_ident lf ist id) + let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_ref (lift intern_global_reference); + Genintern.register_intern0 wit_ident intern_ident'; + Genintern.register_intern0 wit_var (lift intern_hyp); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 5f5adaafb5..adca226303 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1518,11 +1518,11 @@ and interp_match_goal ist lz lr lmr = (* Interprets extended tactic generic arguments *) and interp_genarg ist x : Val.t Ftactic.t = let open Ftactic.Notations in - match genarg_tag x with - | IdentArgType -> - interp_focussed wit_ident (interp_ident ist) x - | VarArgType -> - interp_focussed wit_var (interp_hyp ist) x + (** Ad-hoc handling of some types. *) + let tag = genarg_tag x in + if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then + interp_genarg_var_list ist x + else match tag with | ConstrArgType -> Ftactic.nf_s_enter { s_enter = begin fun gl -> let c = Genarg.out_gen (glbwit wit_constr) x in @@ -1534,8 +1534,6 @@ and interp_genarg ist x : Val.t Ftactic.t = end } | ListArgType ConstrArgType -> interp_genarg_constr_list ist x - | ListArgType VarArgType -> - interp_genarg_var_list ist x | ListArgType _ -> let list_unpacker wit l = let map x = @@ -2182,6 +2180,8 @@ let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigm let () = Geninterp.register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); Geninterp.register_interp0 wit_ref (lift interp_reference); + Geninterp.register_interp0 wit_ident (lift interp_ident); + Geninterp.register_interp0 wit_var (lift interp_hyp); Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 754c886205..0061237bf3 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -276,9 +276,6 @@ and subst_match_rule subst = function and subst_genarg subst (x:glob_generic_argument) = match genarg_tag x with - | IdentArgType -> - in_gen (glbwit wit_ident) (out_gen (glbwit wit_ident) x) - | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x) | ConstrArgType -> in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) | ListArgType _ -> @@ -314,6 +311,8 @@ and subst_genarg subst (x:glob_generic_argument) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_ident (fun _ v -> v); + Genintern.register_subst0 wit_var (fun _ v -> v); Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); Genintern.register_subst0 wit_tactic subst_tactic; Genintern.register_subst0 wit_sort (fun _ v -> v); -- cgit v1.2.3 From 448866f0ec5291d58677d8fccbefde493ade0ee2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Jan 2016 22:20:16 +0100 Subject: Removing constr generic argument. --- dev/top_printers.ml | 4 ++-- grammar/argextend.ml4 | 1 - grammar/q_coqast.ml4 | 1 - interp/constrarg.ml | 4 +++- lib/genarg.ml | 13 +------------ lib/genarg.mli | 2 -- parsing/pcoq.ml | 4 ++-- printing/pptactic.ml | 9 ++++++--- tactics/tacintern.ml | 3 +-- tactics/tacinterp.ml | 14 +++----------- tactics/tacsubst.ml | 3 +-- 11 files changed, 19 insertions(+), 39 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index cbebcdfcd4..cc1cf23d60 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -510,7 +510,7 @@ let _ = try Vernacinterp.vinterp_add false ("PrintConstr", 0) (function - [c] when genarg_tag c = ConstrArgType && true -> + [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in (fun () -> in_current_context constr_display c) | _ -> failwith "Vernac extension: cannot occur") @@ -526,7 +526,7 @@ let _ = try Vernacinterp.vinterp_add false ("PrintPureConstr", 0) (function - [c] when genarg_tag c = ConstrArgType && true -> + [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in (fun () -> in_current_context print_pure_constr c) | _ -> failwith "Vernac extension: cannot occur") diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 9abe5d7cfc..cb006186a3 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -30,7 +30,6 @@ let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function - | ConstrArgType -> <:expr< Constrarg.wit_constr >> | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> | PairArgType (t1,t2) -> diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index 798d428e98..e11b37fc0a 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -223,7 +223,6 @@ let mlexpr_of_red_expr = function <:expr< Genredexpr.ExtraRedExpr $mlexpr_of_string s$ >> let rec mlexpr_of_argtype loc = function - | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> | Genarg.PairArgType (t1,t2) -> diff --git a/interp/constrarg.ml b/interp/constrarg.ml index 94c13fe796..a8dfd02e1d 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -44,7 +44,8 @@ let wit_quant_hyp = Genarg.make0 None "quant_hyp" let wit_sort : (glob_sort, glob_sort, sorts) genarg_type = Genarg.make0 None "sort" -let wit_constr = unsafe_of_type ConstrArgType +let wit_constr = + Genarg.make0 None "constr" let wit_constr_may_eval = Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) None "constr_may_eval" @@ -75,6 +76,7 @@ let () = register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern"; register_name0 wit_tactic "Constrarg.wit_tactic"; register_name0 wit_sort "Constrarg.wit_sort"; + register_name0 wit_constr "Constrarg.wit_constr"; register_name0 wit_uconstr "Constrarg.wit_uconstr"; register_name0 wit_open_constr "Constrarg.wit_open_constr"; register_name0 wit_constr_may_eval "Constrarg.wit_constr_may_eval"; diff --git a/lib/genarg.ml b/lib/genarg.ml index af9ea70ec5..c2c1014f17 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -57,14 +57,12 @@ end type argument_type = (* Specific types *) - | ConstrArgType | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type | ExtraArgType of string let rec argument_type_eq arg1 arg2 = match arg1, arg2 with -| ConstrArgType, ConstrArgType -> true | ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 | OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 | PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) -> @@ -73,7 +71,6 @@ let rec argument_type_eq arg1 arg2 = match arg1, arg2 with | _ -> false let rec pr_argument_type = function -| ConstrArgType -> str "constr" | ListArgType t -> pr_argument_type t ++ spc () ++ str "list" | OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" | PairArgType (t1, t2) -> @@ -190,19 +187,12 @@ let default_empty_value t = | _ -> None) | ExtraArgType s -> (String.Map.find s !arg0_map).nil - | _ -> None in + in match aux t with | Some v -> Some (Obj.obj v) | None -> None -(** Beware: keep in sync with the corresponding types *) -let base_create n = Val.Base (Dyn.create n) -let genarg_T = base_create "genarg" -let constr_T = base_create "constr" - let rec val_tag = function - (** Must ensure that toplevel types of Var and Ident agree! *) -| ConstrArgType -> cast_tag constr_T | ExtraArgType s -> cast_tag (String.Map.find s !arg0_map).dyn | ListArgType t -> cast_tag (Val.List (val_tag t)) | OptArgType t -> cast_tag (Val.Opt (val_tag t)) @@ -222,7 +212,6 @@ let try_prj wit v = match prj (val_tag wit) v with let rec val_cast : type a. a typed_abstract_argument_type -> Val.t -> a = fun wit v -> match unquote wit with -| ConstrArgType | ExtraArgType _ -> try_prj wit v | ListArgType t -> let Val.Dyn (tag, v) = v in diff --git a/lib/genarg.mli b/lib/genarg.mli index 8d929f9f69..56c09f14fc 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -211,8 +211,6 @@ val val_cast : 'a typed_abstract_argument_type -> Val.t -> 'a (** {6 Type reification} *) type argument_type = - (** Basic types *) - | ConstrArgType (** Specific types *) | ListArgType of argument_type | OptArgType of argument_type diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index df0d262062..3ed5304251 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -272,7 +272,7 @@ let create_entry u s etyp = new_entry etyp u s let create_constr_entry s = - outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) + outGramObj (rawwit wit_constr) (create_entry uconstr s (unquote (rawwit wit_constr))) let create_generic_entry s wit = outGramObj wit (create_entry utactic s (unquote wit)) @@ -633,7 +633,7 @@ let compute_entry allow_create adjust forpat = function let u = get_univ u in let e = try get_entry u n - with Not_found when allow_create -> create_entry u n ConstrArgType in + with Not_found when allow_create -> create_entry u n (unquote (rawwit wit_constr)) in object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index df5f57dac1..a8fa8313f2 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -267,7 +267,6 @@ module Make let rec pr_raw_generic_rec prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with - | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) | ListArgType _ -> let list_unpacker wit l = let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in @@ -295,7 +294,6 @@ module Make let rec pr_glb_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) | ListArgType _ -> let list_unpacker wit l = let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in @@ -322,7 +320,6 @@ module Make let rec pr_top_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | ConstrArgType -> prc (out_gen (topwit wit_constr) x) | ListArgType _ -> let list_unpacker wit l = let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in @@ -1426,6 +1423,12 @@ let () = ; Genprint.register_print0 Constrarg.wit_sort pr_glob_sort pr_glob_sort (pr_sort Evd.empty); + Genprint.register_print0 + Constrarg.wit_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; Genprint.register_print0 Constrarg.wit_uconstr Ppconstr.pr_constr_expr diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index ac0c4b266b..6f6c4a05a1 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -720,8 +720,6 @@ and intern_match_rule onlytac ist = function and intern_genarg ist x = match genarg_tag x with - | ConstrArgType -> - map_raw wit_constr intern_constr ist x | ListArgType _ -> let list_unpacker wit l = let map x = @@ -830,6 +828,7 @@ let () = Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); + Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_red_expr (lift intern_red_expr); diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index adca226303..71a6e043b5 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1522,18 +1522,9 @@ and interp_genarg ist x : Val.t Ftactic.t = let tag = genarg_tag x in if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then interp_genarg_var_list ist x - else match tag with - | ConstrArgType -> - Ftactic.nf_s_enter { s_enter = begin fun gl -> - let c = Genarg.out_gen (glbwit wit_constr) x in - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let (sigma, c) = interp_constr ist env sigma c in - let c = in_gen (topwit wit_constr) c in - Sigma.Unsafe.of_pair (Ftactic.return c, sigma) - end } - | ListArgType ConstrArgType -> + else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then interp_genarg_constr_list ist x + else match tag with | ListArgType _ -> let list_unpacker wit l = let map x = @@ -2184,6 +2175,7 @@ let () = Geninterp.register_interp0 wit_var (lift interp_hyp); Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); + Geninterp.register_interp0 wit_constr (lifts interp_constr); Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); Geninterp.register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 0061237bf3..4f79115240 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -276,8 +276,6 @@ and subst_match_rule subst = function and subst_genarg subst (x:glob_generic_argument) = match genarg_tag x with - | ConstrArgType -> - in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) | ListArgType _ -> let list_unpacker wit l = let map x = @@ -315,6 +313,7 @@ let () = Genintern.register_subst0 wit_var (fun _ v -> v); Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); Genintern.register_subst0 wit_tactic subst_tactic; + Genintern.register_subst0 wit_constr subst_glob_constr; Genintern.register_subst0 wit_sort (fun _ v -> v); Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); -- cgit v1.2.3 From 65b45fe6e86cc8b642069e33c3b7073f48b592a9 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Thu, 26 Nov 2015 15:56:47 +0100 Subject: Partially fixing #4408: coqdep --help is up to date. --- tools/coqdep.ml | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index e0e017e88a..e51572fc35 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -426,12 +426,25 @@ let coq_dependencies_dump chan dumpboxes = end let usage () = - eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-Q dir coqdir] [-R dir coqdir] +\n"; - eprintf " extra options:\n"; - eprintf " -sort : output the file names ordered by dependencies\n"; - eprintf " -coqlib dir : set the coq standard library directory\n"; - eprintf " -exclude-dir f : skip subdirectories named 'f' during -R search\n"; + eprintf " usage: coqdep [options] +\n"; + eprintf " options:\n"; + eprintf " -c : \n"; + eprintf " -D : \n"; + eprintf " -w : \n"; + eprintf " -boot : \n"; + eprintf " -sort : output the given file name ordered by dependencies\n"; + eprintf " -noglob | -no-glob : \n"; + eprintf " -I dir -as logname : adds (non recursively) dir to coq load path under logical name logname\n"; + eprintf " -I dir : adds (non recursively) dir to ocaml path\n"; + eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *) + eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; + eprintf " -Q dir logname : add (recusively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; + eprintf " -dumpgraphbox f : print a dot dependency graph box in file 'f'\n"; + eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R search\n"; + eprintf " -coqlib dir : set the coq standard library directory\n"; + eprintf " -suffix s : \n"; + eprintf " -slash : deprecated, no effect\n"; exit 1 let split_period = Str.split (Str.regexp (Str.quote ".")) -- cgit v1.2.3 From d6d81d63591e37fd74c841165afd9e3baf6e0d8d Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 13 Nov 2015 15:56:47 +0100 Subject: Fix #4408. Removed documentation for broken -D -w (but the option are still there). Fixed documentation of others. --- man/coqdep.1 | 65 ++++++++++++++++++++++++++++++++++++--------------------- tools/coqdep.ml | 13 +++++++----- 2 files changed, 49 insertions(+), 29 deletions(-) diff --git a/man/coqdep.1 b/man/coqdep.1 index 5a6cd609e6..81f7e1e0df 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -46,7 +46,9 @@ commands (Require, Require Export, Require Import), commands and .IR Load \& commands. Dependencies relative to modules from the Coq library are not -printed. +printed except if +.BR \-boot \& +is given. Dependencies of Caml modules are computed by looking at .IR open \& @@ -59,35 +61,50 @@ directives and the dot notation .BI \-c Prints the dependencies of Caml modules. (On Caml modules, the behaviour is exactly the same as ocamldep). -.TP -.BI \-w -Prints a warning if a Coq command -.IR Declare \& -.IR ML \& -.IR Module \& -is incorrect. (For instance, you wrote `Declare ML Module "A".', -but the module A contains #open "B"). The correct command is printed -(see option \-D). The warning is printed on standard error. -.TP -.BI \-D -This commands looks for every command -.IR Declare \& -.IR ML \& -.IR Module \& -of each Coq file given as argument and complete (if needed) -the list of Caml modules. The new command is printed on -the standard output. No dependency is computed with this option. +\" THESE OPTIONS ARE BROKEN CURRENTLY +\" .TP +\" .BI \-w +\" Prints a warning if a Coq command +\" .IR Declare \& +\" .IR ML \& +\" .IR Module \& +\" is incorrect. (For instance, you wrote `Declare ML Module "A".', +\" but the module A contains #open "B"). The correct command is printed +\" (see option \-D). The warning is printed on standard error. +\" .TP +\" .BI \-D +\" This commands looks for every command +\" .IR Declare \& +\" .IR ML \& +\" .IR Module \& +\" of each Coq file given as argument and complete (if needed) +\" the list of Caml modules. The new command is printed on +\" the standard output. No dependency is computed with this option. .TP -.BI \-I \ directory -The files .v .ml .mli of the directory -.IR directory \& -are taken into account during the calculus of dependencies, -but their own dependencies are not printed. +.BI \-I/\-Q/\-R \ options +Have the same effects on load path and modules names than for other +coq commands (coqtop, coqc). .TP .BI \-coqlib \ directory Indicates where is the Coq library. The default value has been determined at installation time, and therefore this option should not be used under normal circumstances. +.TP +.BI \-dumpgraph[box] \ file +Dumps a dot dependency graph in file +.IR file \&. +.TP +.BI \-exclude-dir \ dir +Skips subdirectory +.IR dir \ during +.BR -R/-Q \ search. +.TP +.B \-sort +Output the given file name ordered by dependencies. +.TP +.B \-boot +For coq developpers, prints dependencies over coq library files +(omitted by default). .SH SEE ALSO diff --git a/tools/coqdep.ml b/tools/coqdep.ml index e51572fc35..011293a901 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -428,10 +428,13 @@ end let usage () = eprintf " usage: coqdep [options] +\n"; eprintf " options:\n"; - eprintf " -c : \n"; - eprintf " -D : \n"; - eprintf " -w : \n"; - eprintf " -boot : \n"; + eprintf " -c : Also print the dependencies of caml modules (=ocamldep).\n"; + (* Does not work anymore *) + (* eprintf " -w : Print informations on missing or wrong \"Declare + ML Module\" commands in coq files.\n"; *) + (* Does not work anymore: *) + (* eprintf " -D : Prints the missing ocmal module names. No dependency computed.\n"; *) + eprintf " -boot : For coq developpers, prints dependencies over coq library files (omitted by default).\n"; eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; eprintf " -I dir -as logname : adds (non recursively) dir to coq load path under logical name logname\n"; @@ -441,7 +444,7 @@ let usage () = eprintf " -Q dir logname : add (recusively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; eprintf " -dumpgraphbox f : print a dot dependency graph box in file 'f'\n"; - eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R search\n"; + eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R/-Q search\n"; eprintf " -coqlib dir : set the coq standard library directory\n"; eprintf " -suffix s : \n"; eprintf " -slash : deprecated, no effect\n"; -- cgit v1.2.3 From 088977e086a5fd72f5f724192e5cb5ba1a0d9bb6 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 15 Jan 2016 17:30:00 +0100 Subject: Minor edits in output of coqdep --help. --- tools/coqdep.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 011293a901..aaea1ee703 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -437,8 +437,8 @@ let usage () = eprintf " -boot : For coq developpers, prints dependencies over coq library files (omitted by default).\n"; eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; - eprintf " -I dir -as logname : adds (non recursively) dir to coq load path under logical name logname\n"; - eprintf " -I dir : adds (non recursively) dir to ocaml path\n"; + eprintf " -I dir -as logname : add (non recursively) dir to coq load path under logical name logname\n"; + eprintf " -I dir : add (non recursively) dir to ocaml path\n"; eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *) eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; eprintf " -Q dir logname : add (recusively) and open (non recursively) dir to coq load path under logical name logname\n"; -- cgit v1.2.3 From 74a5cfa8b2f1a881ebf010160421cf0775c2a084 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 15 Jan 2016 17:49:49 +0100 Subject: Hooks for a third-party XML plugin. Contributed by Claudio Sacerdoti Coen. --- Makefile.build | 4 ++-- lib/flags.ml | 2 ++ lib/flags.mli | 2 ++ library/declare.ml | 19 ++++++++++++++++--- library/declare.mli | 5 +++++ library/declaremods.ml | 23 +++++++++++++++++++++-- library/declaremods.mli | 7 +++++++ library/lib.ml | 6 ++++++ library/lib.mli | 4 ++++ library/library.ml | 3 +++ library/library.mli | 3 +++ man/coqide.1 | 6 ++++++ man/coqtop.1 | 6 ++++++ parsing/lexer.ml4 | 6 ++++++ parsing/lexer.mli | 2 ++ plugins/xml/README | 19 ++++--------------- stm/stm.ml | 15 ++++++++++++--- stm/stm.mli | 3 +++ toplevel/coqtop.ml | 2 +- toplevel/usage.ml | 3 +++ toplevel/vernac.ml | 6 ++++++ toplevel/vernac.mli | 4 ++++ 22 files changed, 124 insertions(+), 26 deletions(-) diff --git a/Makefile.build b/Makefile.build index 032f465082..48f448ce8a 100644 --- a/Makefile.build +++ b/Makefile.build @@ -587,9 +587,9 @@ pluginsbyte: $(PLUGINS) ########################################################################### theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d - $(SHOW)'COQC -noinit $<' + $(SHOW)'COQC $(COQ_XML) -noinit $<' $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq + $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) diff --git a/lib/flags.ml b/lib/flags.ml index ab4ac03f80..bdae0adc9a 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -83,6 +83,8 @@ let profile = false let print_emacs = ref false let coqtop_ui = ref false +let xml_export = ref false + let ide_slave = ref false let ideslave_coqtop_flags = ref None diff --git a/lib/flags.mli b/lib/flags.mli index 8e37136560..be2682cbd9 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -44,6 +44,8 @@ val profile : bool val print_emacs : bool ref val coqtop_ui : bool ref +val xml_export : bool ref + val ide_slave : bool ref val ideslave_coqtop_flags : string option ref diff --git a/library/declare.ml b/library/declare.ml index 994a6557ad..8d86c4cf0f 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -32,6 +32,14 @@ type internal_flag = | InternalTacticRequest (* kernel action, no message is displayed *) | UserIndividualRequest (* user action, a message is displayed *) +(** XML output hooks *) + +let (f_xml_declare_variable, xml_declare_variable) = Hook.make ~default:ignore () +let (f_xml_declare_constant, xml_declare_constant) = Hook.make ~default:ignore () +let (f_xml_declare_inductive, xml_declare_inductive) = Hook.make ~default:ignore () + +let if_xml f x = if !Flags.xml_export then f x else () + (** Declaration of section variables and local definitions *) type section_variable_entry = @@ -83,6 +91,7 @@ let declare_variable id obj = declare_var_implicits id; Notation.declare_ref_arguments_scope (VarRef id); Heads.declare_head (EvalVarRef id); + if_xml (Hook.get f_xml_declare_variable) oname; oname @@ -216,6 +225,7 @@ let declare_constant_common id cst = let id = Label.to_id (pi3 (Constant.repr3 c)) in ignore(add_leaf id o); update_tables c; + let () = if_xml (Hook.get f_xml_declare_constant) (InternalTacticRequest, c) in match role with | Safe_typing.Subproof -> () | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|]) @@ -257,6 +267,7 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e cst_was_seff = false; } in let kn = declare_constant_common id cst in + let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in kn let declare_definition ?(internal=UserIndividualRequest) @@ -365,8 +376,9 @@ let declare_projections mind = let kn' = declare_constant id (ProjectionEntry entry, IsDefinition StructureComponent) in - assert(eq_constant kn kn')) kns; true - | Some None | None -> false + assert(eq_constant kn kn')) kns; true,true + | Some None -> true,false + | None -> false,false (* for initial declaration *) let declare_mind mie = @@ -375,9 +387,10 @@ let declare_mind mie = | [] -> anomaly (Pp.str "cannot declare an empty list of inductives") in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in let mind = Global.mind_of_delta_kn kn in - let isprim = declare_projections mind in + let isrecord,isprim = declare_projections mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; + if_xml (Hook.get f_xml_declare_inductive) (isrecord,oname); oname, isprim (* Declaration messages *) diff --git a/library/declare.mli b/library/declare.mli index c6119a58ac..60676ff43f 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -71,6 +71,11 @@ val set_declare_scheme : the whole block and a boolean indicating if it is a primitive record. *) val declare_mind : mutual_inductive_entry -> object_name * bool +(** Hooks for XML output *) +val xml_declare_variable : (object_name -> unit) Hook.t +val xml_declare_constant : (internal_flag * constant -> unit) Hook.t +val xml_declare_inductive : (bool * object_name -> unit) Hook.t + (** Declaration messages *) val definition_message : Id.t -> unit diff --git a/library/declaremods.ml b/library/declaremods.ml index 7f607a51c9..0162de10ce 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -557,6 +557,17 @@ let openmodtype_info = Summary.ref ([] : module_type_body list) ~name:"MODTYPE-INFO" +(** XML output hooks *) + +let (f_xml_declare_module, xml_declare_module) = Hook.make ~default:ignore () +let (f_xml_start_module, xml_start_module) = Hook.make ~default:ignore () +let (f_xml_end_module, xml_end_module) = Hook.make ~default:ignore () +let (f_xml_declare_module_type, xml_declare_module_type) = Hook.make ~default:ignore () +let (f_xml_start_module_type, xml_start_module_type) = Hook.make ~default:ignore () +let (f_xml_end_module_type, xml_end_module_type) = Hook.make ~default:ignore () + +let if_xml f x = if !Flags.xml_export then f x else () + (** {6 Modules : start, end, declare} *) module RawModOps = struct @@ -578,7 +589,9 @@ let start_module interp_modast export id args res fs = openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); - Lib.add_frozen_state (); mp + Lib.add_frozen_state (); + if_xml (Hook.get f_xml_start_module) mp; + mp let end_module () = let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in @@ -617,6 +630,7 @@ let end_module () = assert (ModPath.equal (mp_of_kn (snd newoname)) mp); Lib.add_frozen_state () (* to prevent recaching *); + if_xml (Hook.get f_xml_end_module) mp; mp let declare_module interp_modast id args res mexpr_o fs = @@ -666,6 +680,7 @@ let declare_module interp_modast id args res mexpr_o fs = let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in ignore (Lib.add_leaf id (in_module sobjs)); + if_xml (Hook.get f_xml_declare_module) mp; mp end @@ -682,7 +697,9 @@ let start_modtype interp_modast id args mtys fs = openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); - Lib.add_frozen_state (); mp + Lib.add_frozen_state (); + if_xml (Hook.get f_xml_start_module_type) mp; + mp let end_modtype () = let oldoname,prefix,fs,lib_stack = Lib.end_modtype () in @@ -699,6 +716,7 @@ let end_modtype () = assert (ModPath.equal (mp_of_kn (snd oname)) mp); Lib.add_frozen_state ()(* to prevent recaching *); + if_xml (Hook.get f_xml_end_module_type) mp; mp let declare_modtype interp_modast id args mtys (mty,ann) fs = @@ -729,6 +747,7 @@ let declare_modtype interp_modast id args mtys (mty,ann) fs = check_subtypes_mt mp sub_mty_l; ignore (Lib.add_leaf id (in_modtype sobjs)); + if_xml (Hook.get f_xml_declare_module_type) mp; mp end diff --git a/library/declaremods.mli b/library/declaremods.mli index 319d168d05..8b9f70b35a 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -63,6 +63,13 @@ val start_modtype : val end_modtype : unit -> module_path +(** Hooks for XML output *) +val xml_declare_module : (module_path -> unit) Hook.t +val xml_start_module : (module_path -> unit) Hook.t +val xml_end_module : (module_path -> unit) Hook.t +val xml_declare_module_type : (module_path -> unit) Hook.t +val xml_start_module_type : (module_path -> unit) Hook.t +val xml_end_module_type : (module_path -> unit) Hook.t (** {6 Libraries i.e. modules on disk } *) diff --git a/library/lib.ml b/library/lib.ml index 297441e6e2..42cea4de8e 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -497,6 +497,10 @@ let full_section_segment_of_constant con = (*************) (* Sections. *) +(* XML output hooks *) +let (f_xml_open_section, xml_open_section) = Hook.make ~default:ignore () +let (f_xml_close_section, xml_close_section) = Hook.make ~default:ignore () + let open_section id = let olddir,(mp,oldsec) = !path_prefix in let dir = add_dirpath_suffix olddir id in @@ -508,6 +512,7 @@ let open_section id = (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); path_prefix := prefix; + if !Flags.xml_export then Hook.get f_xml_open_section id; add_section () @@ -536,6 +541,7 @@ let close_section () = let full_olddir = fst !path_prefix in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); + if !Flags.xml_export then Hook.get f_xml_close_section (basename (fst oname)); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls; diff --git a/library/lib.mli b/library/lib.mli index bb88317591..398149a50f 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -157,6 +157,10 @@ val unfreeze : frozen -> unit val init : unit -> unit +(** XML output hooks *) +val xml_open_section : (Names.Id.t -> unit) Hook.t +val xml_close_section : (Names.Id.t -> unit) Hook.t + (** {6 Section management for discharge } *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types diff --git a/library/library.ml b/library/library.ml index 024ac9e6fa..365d119ddf 100644 --- a/library/library.ml +++ b/library/library.ml @@ -555,6 +555,8 @@ let in_require : require_obj -> obj = (* Require libraries, import them if [export <> None], mark them for export if [export = Some true] *) +let (f_xml_require, xml_require) = Hook.make ~default:ignore () + let require_library_from_dirpath modrefl export = let needed, contents = List.fold_left rec_intern_library ([], DPMap.empty) modrefl in let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in @@ -568,6 +570,7 @@ let require_library_from_dirpath modrefl export = end else add_anonymous_leaf (in_require (needed,modrefl,export)); + if !Flags.xml_export then List.iter (Hook.get f_xml_require) modrefl; add_frozen_state () (* the function called by Vernacentries.vernac_import *) diff --git a/library/library.mli b/library/library.mli index d5e610dd67..fb0ce47950 100644 --- a/library/library.mli +++ b/library/library.mli @@ -67,6 +67,9 @@ val library_full_filename : DirPath.t -> string (** - Overwrite the filename of all libraries (used when restoring a state) *) val overwrite_library_filenames : string -> unit +(** {6 Hook for the xml exportation of libraries } *) +val xml_require : (DirPath.t -> unit) Hook.t + (** {6 Locate a library in the load paths } *) exception LibUnmappedDir exception LibNotFound diff --git a/man/coqide.1 b/man/coqide.1 index 6a3e67ad53..f82bf2ad40 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -123,6 +123,12 @@ Set sort Set impredicative. .TP .B \-dont\-load\-proofs Don't load opaque proofs in memory. +.TP +.B \-xml +Export XML files either to the hierarchy rooted in +the directory +.B COQ_XML_LIBRARY_ROOT +(if set) or to stdout (if unset). .SH SEE ALSO diff --git a/man/coqtop.1 b/man/coqtop.1 index 62d17aa674..feee7fd8b5 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -153,6 +153,12 @@ set sort Set impredicative .B \-dont\-load\-proofs don't load opaque proofs in memory +.TP +.B \-xml +export XML files either to the hierarchy rooted in +the directory $COQ_XML_LIBRARY_ROOT (if set) or to +stdout (if unset) + .SH SEE ALSO .BR coqc (1), diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index c6d5f3b925..022f19fdbb 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -298,6 +298,9 @@ let rec string in_comments bp len = parser | [< 'c; s >] -> string in_comments bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string +(* Hook for exporting comment into xml theory files *) +let (f_xml_output_comment, xml_output_comment) = Hook.make ~default:ignore () + (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with @@ -340,6 +343,9 @@ let null_comment s = let comment_stop ep = let current_s = Buffer.contents current in + if !Flags.xml_export && Buffer.length current > 0 && + (!between_com || not(null_comment current_s)) then + Hook.get f_xml_output_comment current_s; (if Flags.do_beautify() && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then let bp = match !comment_begin with diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 2b9bd37df7..2da3f3bfd9 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -29,6 +29,8 @@ type com_state val com_state: unit -> com_state val restore_com_state: com_state -> unit +val xml_output_comment : (string -> unit) Hook.t + val terminal : string -> Tok.t (** The lexer of Coq: *) diff --git a/plugins/xml/README b/plugins/xml/README index e3bcdaf056..3128189929 100644 --- a/plugins/xml/README +++ b/plugins/xml/README @@ -1,15 +1,4 @@ -The xml export plugin for Coq has been discontinued for lack of users: -it was most certainly broken while imposing a non-negligible cost on -Coq development. Its purpose was to give export Coq's kernel objects -in xml form for treatment by external tools. - -If you are looking for such a tool, you may want to look at commit -7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9 responsible for the deletion -of this plugin (for instance, git checkout -7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9^ including the "^", will lead -you to the last commit before the xml plugin was deleted). - -Bear in mind, however, that the plugin was not working properly at the -time. You may want instead to write to the original author of the -plugin, Claudio Sacerdoti-Coen at sacerdot@cs.unibo.it. He has a -stable version of the plugin for an old version of Coq. +The xml export plugin for Coq has been removed from the sources. +A backward compatible plug-in will be provided as a third-party plugin. +For more informations, contact +Claudio Sacerdoti Coen . diff --git a/stm/stm.ml b/stm/stm.ml index 168d8bf084..5a34e81114 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -53,6 +53,9 @@ let execution_error, execution_error_hook = Hook.make let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () +let tactic_being_run, tactic_being_run_hook = Hook.make + ~default:(fun _ -> ()) () + include Hook (* enables: Hooks.(call foo args) *) @@ -1800,16 +1803,21 @@ let known_state ?(redefine_qed=false) ~cache id = ), cache, true | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () -> reach ~cache:`Shallow view.next; + Hooks.(call tactic_being_run true); Partac.vernac_interp - cancel !Flags.async_proofs_n_tacworkers view.next id x + cancel !Flags.async_proofs_n_tacworkers view.next id x; + Hooks.(call tactic_being_run false) ), cache, true | `Cmd { cast = x; cqueue = `QueryQueue cancel } when Flags.async_proofs_is_master () -> (fun () -> reach view.next; Query.vernac_interp cancel view.next id x ), cache, false - | `Cmd { cast = x; ceff = eff } -> (fun () -> - reach view.next; vernac_interp id x; + | `Cmd { cast = x; ceff = eff; ctac } -> (fun () -> + reach view.next; + if ctac then Hooks.(call tactic_being_run true); + vernac_interp id x; + if ctac then Hooks.(call tactic_being_run false); if eff then update_global_env ()), cache, true | `Fork ((x,_,_,_), None) -> (fun () -> reach view.next; vernac_interp id x; @@ -2590,4 +2598,5 @@ let interp_hook = Hooks.interp_hook let with_fail_hook = Hooks.with_fail_hook let unreachable_state_hook = Hooks.unreachable_state_hook let get_fix_exn () = !State.fix_exn_ref +let tactic_being_run_hook = Hooks.tactic_being_run_hook (* vim:set foldmethod=marker: *) diff --git a/stm/stm.mli b/stm/stm.mli index 0c05c93d4d..ad89eb71f3 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -107,6 +107,9 @@ val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t val unreachable_state_hook : (Stateid.t -> Exninfo.iexn -> unit) Hook.t (* ready means that master has it at hand *) val state_ready_hook : (Stateid.t -> unit) Hook.t +(* called with true before and with false after a tactic explicitly + * in the document is run *) +val tactic_being_run_hook : (bool -> unit) Hook.t (* Messages from the workers to the master *) val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 5937fd5c7b..73ab77d08c 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -546,6 +546,7 @@ let parse_args arglist = |"-v"|"--version" -> Usage.version (exitcode ()) |"-verbose-compat-notations" -> verb_compat_ntn := true |"-where" -> print_where := true + |"-xml" -> Flags.xml_export := true (* Deprecated options *) |"-byte" -> warning "option -byte deprecated, call with .byte suffix" @@ -561,7 +562,6 @@ let parse_args arglist = |"-force-load-proofs" -> warning "Obsolete option \"-force-load-proofs\"." |"-unsafe" -> warning "Obsolete option \"-unsafe\"."; ignore (next ()) |"-quality" -> warning "Obsolete option \"-quality\"." - |"-xml" -> warning "Obsolete option \"-xml\"." (* Unknown option *) | s -> extras := s :: !extras diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 472503ced2..6ef5d01089 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -73,6 +73,9 @@ let print_usage_channel co command = \n -impredicative-set set sort Set impredicative\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ +\n -xml export XML files either to the hierarchy rooted in\ +\n the directory $COQ_XML_LIBRARY_ROOT (if set) or to\ +\n stdout (if unset)\ \n -time display the time taken by each command\ \n -m, --memory display total heap size at program exit\ \n (use environment variable\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index a0cd618e99..ada32ec3a2 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -277,6 +277,10 @@ let checknav loc ast = let eval_expr loc_ast = vernac_com (Flags.is_verbose()) checknav loc_ast +(* XML output hooks *) +let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore () +let (f_xml_end_library, xml_end_library) = Hook.make ~default:ignore () + (* Load a vernac file. Errors are annotated with file and location *) let load_vernac verb file = chan_beautify := @@ -311,6 +315,7 @@ let compile verbosely f = Aux_file.start_aux_file_for long_f_dot_v; Dumpglob.start_dump_glob long_f_dot_v; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); + if !Flags.xml_export then Hook.get f_xml_start_library (); let wall_clock1 = Unix.gettimeofday () in let _ = load_vernac verbosely long_f_dot_v in Stm.join (); @@ -320,6 +325,7 @@ let compile verbosely f = Aux_file.record_in_aux_at Loc.ghost "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); + if !Flags.xml_export then Hook.get f_xml_end_library (); Dumpglob.end_dump_glob () | BuildVio -> let long_f_dot_v = ensure_v f in diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index affc21713d..62e9f23904 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -23,6 +23,10 @@ val just_parsing : bool ref val eval_expr : Loc.t * Vernacexpr.vernac_expr -> unit +(** Set XML hooks *) +val xml_start_library : (unit -> unit) Hook.t +val xml_end_library : (unit -> unit) Hook.t + (** Load a vernac file, verbosely or not. Errors are annotated with file and location *) -- cgit v1.2.3 From 13e969e644a6ad23f6d326f3e4a253ae0393da9c Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 15 Jan 2016 20:29:41 +0100 Subject: Thanks Hugo, but let's remain factual. --- doc/refman/RefMan-pre.tex | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index e0dc496666..cb2ab5dc2f 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -1080,8 +1080,7 @@ Pierre-Marie Pédrot, Matthieu Sozeau, Arnaud Spiwack, Enrico Tassi as well as Bruno Barras, Yves Bertot, Frédéric Besson, Xavier Clerc, Pierre Corbineau, Jean-Christophe Filliâtre, Julien Forest, Sébastien Hinderer, Assia Mahboubi, Jean-Marc Notin, Yann Régis-Gianas, François -Ripault, Carst Tankink. Maxime Dénès brilliantly coordinated the -release process. +Ripault, Carst Tankink. Maxime Dénès coordinated the release process. \begin{flushright} Paris, January 2015, revised December 2015,\\ -- cgit v1.2.3 From 28ac569f0f8a0ae27552e4e4c20fc06ce12c720d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Jan 2016 23:34:52 +0100 Subject: Tactic notation printing accesses all the token data. --- grammar/tacextend.ml4 | 12 ++++-------- printing/pptactic.ml | 39 +++++++++++++++++++++++---------------- printing/pptactic.mli | 6 +++--- toplevel/metasyntax.ml | 10 ++-------- 4 files changed, 32 insertions(+), 35 deletions(-) diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index bf0c4fc215..a870722fdf 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -86,10 +86,6 @@ let rec make_args = function <:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >> | _::l -> make_args l -let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function - | ExtTerminal s -> <:expr< Some $mlexpr_of_string s$ >> - | ExtNonTerminal _ -> <:expr< None >> - let make_prod_item = function | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> | ExtNonTerminal (EntryName (nt, g), id) -> @@ -98,7 +94,7 @@ let make_prod_item = function $mlexpr_of_prod_entry_key g$ >> let mlexpr_of_clause cl = - mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) cl + mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl let rec make_tags loc = function | [] -> <:expr< [] >> @@ -112,9 +108,9 @@ let rec make_tags loc = function let make_one_printing_rule (pt,_,e) = let level = mlexpr_of_int 0 in (* only level 0 supported here *) let loc = MLast.loc_of_expr e in - let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in - <:expr< { Pptactic.pptac_args = $make_tags loc pt$; - pptac_prods = ($level$, $prods$) } >> + let prods = mlexpr_of_list make_prod_item pt in + <:expr< { Pptactic.pptac_level = $level$; + pptac_prods = $prods$ } >> let make_printing_rule r = mlexpr_of_list make_one_printing_rule r diff --git a/printing/pptactic.ml b/printing/pptactic.ml index a8fa8313f2..5bc242b2b2 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -26,11 +26,11 @@ open Printer let pr_global x = Nametab.pr_global_env Id.Set.empty x -type grammar_terminals = string option list +type grammar_terminals = Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list type pp_tactic = { - pptac_args : argument_type list; - pptac_prods : int * grammar_terminals; + pptac_level : int; + pptac_prods : grammar_terminals; } (* ML Extensions *) @@ -345,16 +345,22 @@ module Make with Not_found -> Genprint.generic_top_print x let rec tacarg_using_rule_token pr_gen = function - | Some s :: l, al -> keyword s :: tacarg_using_rule_token pr_gen (l,al) - | None :: l, a :: al -> + | Egramml.GramTerminal s :: l, al -> keyword s :: tacarg_using_rule_token pr_gen (l,al) + | Egramml.GramNonTerminal _ :: l, a :: al -> let r = tacarg_using_rule_token pr_gen (l,al) in pr_gen a :: r | [], [] -> [] | _ -> failwith "Inconsistent arguments of extended tactic" + type any_arg = AnyArg : 'a Genarg.raw_abstract_argument_type -> any_arg + + let filter_arg = function + | Egramml.GramTerminal _ -> None + | Egramml.GramNonTerminal (_, t, _) -> Some (AnyArg t) + let pr_tacarg_using_rule pr_gen l = let l = match l with - | (Some s :: l, al) -> + | (Egramml.GramTerminal s :: l, al) -> (** First terminal token should be considered as the name of the tactic, so we tag it differently than the other terminal tokens. *) primitive s :: (tacarg_using_rule_token pr_gen (l, al)) @@ -366,10 +372,10 @@ module Make try let pp_rules = Hashtbl.find prtac_tab s in let pp = pp_rules.(i) in - let () = if not (List.for_all2eq check pp.pptac_args l) then raise Not_found in - let (lev', pl) = pp.pptac_prods in - let p = pr_tacarg_using_rule pr_gen (pl,l) in - if lev' > lev then surround p else p + let args = List.map_filter filter_arg pp.pptac_prods in + let () = if not (List.for_all2eq check args l) then raise Not_found in + let p = pr_tacarg_using_rule pr_gen (pp.pptac_prods, l) in + if pp.pptac_level > lev then surround p else p with Not_found -> let name = str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ @@ -384,15 +390,15 @@ module Make let pr_alias_gen check pr_gen lev key l = try let pp = KNmap.find key !prnotation_tab in - let (lev', pl) = pp.pptac_prods in - let () = if not (List.for_all2eq check pp.pptac_args l) then raise Not_found in - let p = pr_tacarg_using_rule pr_gen (pl, l) in - if lev' > lev then surround p else p + let args = List.map_filter filter_arg pp.pptac_prods in + let () = if not (List.for_all2eq check args l) then raise Not_found in + let p = pr_tacarg_using_rule pr_gen (pp.pptac_prods, l) in + if pp.pptac_level > lev then surround p else p with Not_found -> KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" - let check_type t arg = match arg with - | TacGeneric arg -> argument_type_eq t (genarg_tag arg) + let check_type t arg = match t, arg with + | AnyArg t, TacGeneric arg -> argument_type_eq (unquote t) (genarg_tag arg) | _ -> false let unwrap_gen f = function TacGeneric x -> f x | _ -> assert false @@ -1347,6 +1353,7 @@ module Make (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) let check_val_type t arg = + let AnyArg t = t in let t = Genarg.val_tag (Obj.magic t) in (** FIXME *) let Val.Dyn (t', _) = arg in match Genarg.Val.eq t t' with diff --git a/printing/pptactic.mli b/printing/pptactic.mli index 30b9483db7..57c7f67fd4 100644 --- a/printing/pptactic.mli +++ b/printing/pptactic.mli @@ -41,11 +41,11 @@ val declare_extra_genarg_pprule : 'b glob_extra_genarg_printer -> 'c extra_genarg_printer -> unit -type grammar_terminals = string option list +type grammar_terminals = Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list type pp_tactic = { - pptac_args : argument_type list; - pptac_prods : int * grammar_terminals; + pptac_level : int; + pptac_prods : grammar_terminals; } val declare_ml_tactic_pprule : ml_tactic_name -> pp_tactic array -> unit diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 6ba5f4f875..6919729fe9 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -55,11 +55,6 @@ let make_terminal_status = function | GramTerminal s -> Some s | GramNonTerminal _ -> None -let rec make_tags = function - | GramTerminal s :: l -> make_tags l - | GramNonTerminal (loc, etyp, _) :: l -> Genarg.unquote etyp :: make_tags l - | [] -> [] - let make_fresh_key = let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in fun () -> @@ -133,10 +128,9 @@ let cons_production_parameter = function let add_tactic_notation (local,n,prods,e) = let ids = List.map_filter cons_production_parameter prods in let prods = List.map (interp_prod_item n) prods in - let tags = make_tags prods in let pprule = { - Pptactic.pptac_args = tags; - pptac_prods = (n, List.map make_terminal_status prods); + Pptactic.pptac_level = n; + pptac_prods = prods; } in let tac = Tacintern.glob_tactic_env ids (Global.env()) e in let parule = { -- cgit v1.2.3 From 3914cc110faeb67c399dda0791a600bad7b7ef31 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 16 Jan 2016 14:06:38 +0100 Subject: Less type-unsafety in Pcoq. --- parsing/pcoq.ml | 57 +++++++++++++++++---------------------------------------- 1 file changed, 17 insertions(+), 40 deletions(-) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 3ed5304251..313a62c680 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -53,10 +53,8 @@ end (** Grammar entries with associated types *) type grammar_object = Gramobj.grammar_object -type typed_entry = argument_type * grammar_object G.entry -let in_typed_entry t e = (t,Gramobj.weaken_entry e) -let type_of_typed_entry (t,e) = t -let object_of_typed_entry (t,e) = e +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a G.entry -> typed_entry +let object_of_typed_entry (TypedEntry (_, e)) = Gramobj.weaken_entry e let weaken_entry x = Gramobj.weaken_entry x (** General entry keys *) @@ -82,24 +80,6 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = type 's entry_name = EntryName : 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name -module type Gramtypes = -sig - val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry - val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry -end - -module Gramtypes : Gramtypes = -struct - let inGramObj rawwit = in_typed_entry (unquote rawwit) - let outGramObj (a:'a raw_abstract_argument_type) o = - if not (argument_type_eq (type_of_typed_entry o) (unquote a)) - then anomaly ~label:"outGramObj" (str "wrong type"); - (* downcast from grammar_object *) - Obj.magic (object_of_typed_entry o) -end - -open Gramtypes - (** Grammar extensions *) (** NB: [extend_statment = @@ -257,25 +237,23 @@ let new_entry etyp u s = if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr); let _ = Entry.create u s in let ename = uname ^ ":" ^ s in - let e = in_typed_entry etyp (Gram.entry_create ename) in - Hashtbl.add utab s e; e + let e = Gram.entry_create ename in + Hashtbl.add utab s (TypedEntry (etyp, e)); e let create_entry u s etyp = let utab = get_utable u in try - let e = Hashtbl.find utab s in + let TypedEntry (typ, e) = Hashtbl.find utab s in let u = Entry.univ_name u in - if not (argument_type_eq (type_of_typed_entry e) etyp) then + if not (argument_type_eq (unquote typ) (unquote etyp)) then failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - e + Obj.magic e with Not_found -> new_entry etyp u s -let create_constr_entry s = - outGramObj (rawwit wit_constr) (create_entry uconstr s (unquote (rawwit wit_constr))) +let create_constr_entry s = create_entry uconstr s (rawwit wit_constr) -let create_generic_entry s wit = - outGramObj wit (create_entry utactic s (unquote wit)) +let create_generic_entry s wit = create_entry utactic s wit (* [make_gen_entry] builds entries extensible by giving its name (a string) *) (* For entries extensible only via the ML name, Gram.entry_create is enough *) @@ -285,7 +263,7 @@ let make_gen_entry u rawwit s = let uname = Entry.univ_name u in let e = Gram.entry_create (uname ^ ":" ^ s) in let _ = Entry.create u s in - Hashtbl.add univ s (inGramObj rawwit e); e + Hashtbl.add univ s (TypedEntry (rawwit, e)); e (* Initial grammar entries *) @@ -633,7 +611,10 @@ let compute_entry allow_create adjust forpat = function let u = get_univ u in let e = try get_entry u n - with Not_found when allow_create -> create_entry u n (unquote (rawwit wit_constr)) in + with Not_found when allow_create -> + let wit = rawwit wit_constr in + TypedEntry (wit, create_entry u n wit) + in object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) @@ -779,9 +760,6 @@ let tactic_level s = else None else None -let type_of_entry u s = - type_of_typed_entry (get_entry u s) - let name_of_entry e = match String.split ':' (Gram.Entry.name e) with | u :: s :: [] -> Entry.unsafe_of_name (u, s) | _ -> assert false @@ -795,9 +773,8 @@ let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type = Obj.magic let try_get_entry u s = - (** Order the effects: type_of_entry can raise Not_found *) - let typ = type_of_entry u s in - let typ = unsafe_of_genarg typ in + (** Order the effects: get_entry can raise Not_found *) + let TypedEntry (typ, _) = get_entry u s in EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type = @@ -858,7 +835,7 @@ let rec interp_entry_name static up_level s sep = EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) let list_entry_names () = - let add_entry key (entry, _) accu = (key, entry) :: accu in + let add_entry key (TypedEntry (entry, _)) accu = (key, unquote entry) :: accu in let ans = Hashtbl.fold add_entry (get_utable uprim) [] in let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in Hashtbl.fold add_entry (get_utable utactic) ans -- cgit v1.2.3 From 8a3b19b62720e2324ef24003407c2e83335a51a5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 16 Jan 2016 14:57:48 +0100 Subject: Separating the parsing of user-defined entries from their intepretation. --- intf/extend.mli | 12 ++++++++++ parsing/pcoq.ml | 69 +++++++++++++++++++++++++++++++++++++++------------------ 2 files changed, 59 insertions(+), 22 deletions(-) diff --git a/intf/extend.mli b/intf/extend.mli index 975f194b07..651fa638b5 100644 --- a/intf/extend.mli +++ b/intf/extend.mli @@ -51,6 +51,18 @@ type constr_prod_entry_key = type simple_constr_prod_entry_key = (production_level,unit) constr_entry_key_gen +(** {5 AST for user-provided entries} *) + +type user_symbol = +| Ulist1 : user_symbol -> user_symbol +| Ulist1sep : user_symbol * string -> user_symbol +| Ulist0 : user_symbol -> user_symbol +| Ulist0sep : user_symbol * string -> user_symbol +| Uopt : user_symbol -> user_symbol +| Umodifiers : user_symbol -> user_symbol +| Uentry : string -> user_symbol +| Uentryl : string * int -> user_symbol + (** {5 Type-safe grammar extension} *) type ('self, 'a) symbol = diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 313a62c680..c8cd16aaf4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -754,12 +754,6 @@ let coincide s pat off = done; !break -let tactic_level s = - if Int.equal (String.length s) 7 && coincide s "tactic" 0 then - let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) - else None - else None - let name_of_entry e = match String.split ':' (Gram.Entry.name e) with | u :: s :: [] -> Entry.unsafe_of_name (u, s) | _ -> assert false @@ -800,32 +794,56 @@ let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext) else EntryName (rawwit wit_tactic, atactic n) -let rec interp_entry_name static up_level s sep = +let rec parse_user_entry s sep = let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - EntryName (wit_list t, Alist1 g) + let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + Ulist1 entry else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - EntryName (wit_list t, Alist1sep (g,sep)) + let entry = parse_user_entry (String.sub s 3 (l-12)) "" in + Ulist1sep (entry, sep) else if l > 5 && coincide s "_list" (l-5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - EntryName (wit_list t, Alist0 g) + let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + Ulist0 entry else if l > 9 && coincide s "_list_sep" (l-9) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - EntryName (wit_list t, Alist0sep (g,sep)) + let entry = parse_user_entry (String.sub s 0 (l-9)) "" in + Ulist0sep (entry, sep) else if l > 4 && coincide s "_opt" (l-4) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - EntryName (wit_opt t, Aopt g) + let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + Uopt entry else if l > 5 && coincide s "_mods" (l-5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - EntryName (wit_list t, Amodifiers g) + let entry = parse_user_entry (String.sub s 0 (l-1)) "" in + Umodifiers entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) else let s = match s with "hyp" -> "var" | _ -> s in - match tactic_level s with - | Some n -> get_tacentry n up_level - | None -> + Uentry s + +let rec interp_entry_name static up_level s sep = + let rec eval = function + | Ulist1 e -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist1 g) + | Ulist1sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist1sep (g, sep)) + | Ulist0 e -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist0 g) + | Ulist0sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Alist0sep (g, sep)) + | Uopt e -> + let EntryName (t, g) = eval e in + EntryName (wit_opt t, Aopt g) + | Umodifiers e -> + let EntryName (t, g) = eval e in + EntryName (wit_list t, Amodifiers g) + | Uentry s -> + begin try try_get_entry uprim s with Not_found -> try try_get_entry uconstr s with Not_found -> try try_get_entry utactic s with Not_found -> @@ -833,6 +851,13 @@ let rec interp_entry_name static up_level s sep = error ("Unknown entry "^s^".") else EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) + end + | Uentryl (s, n) -> + (** FIXME: do better someday *) + assert (String.equal s "tactic"); + get_tacentry n up_level + in + eval (parse_user_entry s sep) let list_entry_names () = let add_entry key (TypedEntry (entry, _)) accu = (key, unquote entry) :: accu in -- cgit v1.2.3 From e6b05180d789fb46bc91c71bc97efaf8b552f0fd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 16 Jan 2016 23:19:40 +0100 Subject: ML extensions use untyped representation of user entries. --- grammar/argextend.ml4 | 62 ++++++++++++++++++++++-------------------------- grammar/q_util.ml4 | 62 ++++++++++++++++++++++++++++++++---------------- grammar/q_util.mli | 6 +++-- grammar/tacextend.ml4 | 48 ++++++++++++------------------------- grammar/vernacextend.ml4 | 13 +++++----- parsing/pcoq.mli | 6 +++++ 6 files changed, 102 insertions(+), 95 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index cb006186a3..d976ee0192 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -12,6 +12,7 @@ open Genarg open Q_util open Egramml open Compat +open Extend open Pcoq let loc = CompatLoc.ghost @@ -42,37 +43,33 @@ let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> let has_extraarg l = let check = function - | ExtNonTerminal(EntryName (t, _), _) -> - begin match Genarg.unquote t with - | ExtraArgType _ -> true - | _ -> false - end + | ExtNonTerminal(ExtraArgType _, _, _) -> true | _ -> false in List.exists check l -let rec is_possibly_empty : type s a. (s, a) entry_key -> bool = function -| Aopt _ -> true -| Alist0 _ -> true -| Alist0sep _ -> true -| Amodifiers _ -> true -| Alist1 t -> is_possibly_empty t -| Alist1sep (t, _) -> is_possibly_empty t +let rec is_possibly_empty = function +| Uopt _ -> true +| Ulist0 _ -> true +| Ulist0sep _ -> true +| Umodifiers _ -> true +| Ulist1 t -> is_possibly_empty t +| Ulist1sep (t, _) -> is_possibly_empty t | _ -> false -let rec get_empty_entry : type s a. (s, a) entry_key -> _ = function -| Aopt _ -> <:expr< None >> -| Alist0 _ -> <:expr< [] >> -| Alist0sep _ -> <:expr< [] >> -| Amodifiers _ -> <:expr< [] >> -| Alist1 t -> <:expr< [$get_empty_entry t$] >> -| Alist1sep (t, _) -> <:expr< [$get_empty_entry t$] >> +let rec get_empty_entry = function +| Uopt _ -> <:expr< None >> +| Ulist0 _ -> <:expr< [] >> +| Ulist0sep _ -> <:expr< [] >> +| Umodifiers _ -> <:expr< [] >> +| Ulist1 t -> <:expr< [$get_empty_entry t$] >> +| Ulist1sep (t, _) -> <:expr< [$get_empty_entry t$] >> | _ -> assert false let statically_known_possibly_empty s (prods,_) = List.for_all (function - | ExtNonTerminal(EntryName (t, e), _) -> - begin match Genarg.unquote t with + | ExtNonTerminal(t, e, _) -> + begin match t with | ExtraArgType s' -> (* For ExtraArg we don't know (we'll have to test dynamically) *) (* unless it is a recursive call *) @@ -91,10 +88,10 @@ let possibly_empty_subentries loc (prods,act) = in let rec aux = function | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >> - | ExtNonTerminal(EntryName (_, e), id) :: tl when is_possibly_empty e -> + | ExtNonTerminal(_, e, id) :: tl when is_possibly_empty e -> bind_name id (get_empty_entry e) (aux tl) - | ExtNonTerminal(EntryName (t, _), id) :: tl -> - let t = match Genarg.unquote t with + | ExtNonTerminal(t, _, id) :: tl -> + let t = match t with | ExtraArgType _ as t -> t | _ -> assert false in @@ -132,8 +129,7 @@ let make_possibly_empty_subentries loc s cl = let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> - | ExtNonTerminal (EntryName (t, _), p) :: tl -> - let t = Genarg.unquote t in + | ExtNonTerminal (t, _, p) :: tl -> let p = Names.Id.to_string p in <:expr< (fun $lid:p$ -> @@ -145,7 +141,7 @@ let make_act loc act pil = let make_prod_item = function | ExtTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> - | ExtNonTerminal (EntryName (_, g), _) -> mlexpr_of_prod_entry_key g + | ExtNonTerminal (_, g, _) -> mlexpr_of_prod_entry_key g let rec make_prod = function | [] -> <:expr< Extend.Stop >> @@ -303,8 +299,8 @@ EXTEND | e = argtype; LIDENT "option" -> OptArgType e ] | "0" [ e = LIDENT -> - let EntryName (t, _) = interp_entry_name false TgAny e "" in - Genarg.unquote t + let e = parse_user_entry e "" in + type_of_user_symbol e | "("; e = argtype; ")" -> e ] ] ; argrule: @@ -312,11 +308,11 @@ EXTEND ; genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let entry = interp_entry_name false TgAny e "" in - ExtNonTerminal (entry, Names.Id.of_string s) + let e = parse_user_entry e "" in + ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let entry = interp_entry_name false TgAny e sep in - ExtNonTerminal (entry, Names.Id.of_string s) + let e = parse_user_entry e sep in + ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Lexer.add_keyword s; diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 4c1f25941f..af9de2df21 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -8,11 +8,12 @@ (* This file defines standard combinators to build ml expressions *) +open Extend open Compat type extend_token = | ExtTerminal of string -| ExtNonTerminal of unit Pcoq.entry_name * Names.Id.t +| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * Names.Id.t let mlexpr_of_list f l = List.fold_right @@ -66,23 +67,44 @@ let mlexpr_of_token = function | Tok.BULLET s -> <:expr< Tok.BULLET $mlexpr_of_string s$ >> | Tok.EOI -> <:expr< Tok.EOI >> -let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = function - | Pcoq.Atoken t -> <:expr< Pcoq.Atoken $mlexpr_of_token t$ >> - | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Alist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Pcoq.Aopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Aself -> <:expr< Pcoq.Aself >> - | Pcoq.Anext -> <:expr< Pcoq.Anext >> - | Pcoq.Aentry e -> - begin match Entry.repr e with - | Entry.Dynamic s -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:s$) >> - | Entry.Static (u, s) -> <:expr< Pcoq.Aentry (Entry.unsafe_of_name ($str:u$, $str:s$)) >> - end - | Pcoq.Aentryl (e, l) -> - begin match Entry.repr e with - | Entry.Dynamic s -> <:expr< Pcoq.Aentryl (Pcoq.name_of_entry $lid:s$) >> - | Entry.Static (u, s) -> <:expr< Pcoq.Aentryl (Entry.unsafe_of_name ($str:u$, $str:s$)) $mlexpr_of_int l$ >> +let repr_entry e = + let entry u = + let _ = Pcoq.get_entry u e in + Some (Entry.univ_name u, e) + in + try entry Pcoq.uprim with Not_found -> + try entry Pcoq.uconstr with Not_found -> + try entry Pcoq.utactic with Not_found -> None + +let rec mlexpr_of_prod_entry_key = function + | Extend.Ulist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> + | Extend.Ulist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> + | Extend.Ulist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> + | Extend.Ulist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> + | Extend.Uopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >> + | Extend.Umodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> + | Extend.Uentry e -> + begin match repr_entry e with + | None -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:e$) >> + | Some (u, s) -> <:expr< Pcoq.Aentry (Entry.unsafe_of_name ($str:u$, $str:s$)) >> end + | Extend.Uentryl (e, l) -> + (** Keep in sync with Pcoq! *) + assert (CString.equal e "tactic"); + if l = 5 then <:expr< Pcoq.Aentry (Pcoq.name_of_entry Pcoq.Tactic.binder_tactic) >> + else <:expr< Pcoq.Aentryl (Pcoq.name_of_entry Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> + +let type_entry u e = + let Pcoq.TypedEntry (t, _) = Pcoq.get_entry u e in + Genarg.unquote t + +let rec type_of_user_symbol = function +| Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) | Umodifiers s -> + Genarg.ListArgType (type_of_user_symbol s) +| Uopt s -> + Genarg.OptArgType (type_of_user_symbol s) +| Uentry e | Uentryl (e, _) -> + try type_entry Pcoq.uprim e with Not_found -> + try type_entry Pcoq.uconstr e with Not_found -> + try type_entry Pcoq.utactic e with Not_found -> + Genarg.ExtraArgType e diff --git a/grammar/q_util.mli b/grammar/q_util.mli index d9359de1e8..81ad422663 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -10,7 +10,7 @@ open Compat (* necessary for camlp4 *) type extend_token = | ExtTerminal of string -| ExtNonTerminal of unit Pcoq.entry_name * Names.Id.t +| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * Names.Id.t val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr @@ -34,4 +34,6 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr -val mlexpr_of_prod_entry_key : ('self, 'a) Pcoq.entry_key -> MLast.expr +val mlexpr_of_prod_entry_key : Extend.user_symbol -> MLast.expr + +val type_of_user_symbol : Extend.user_symbol -> Genarg.argument_type diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index a870722fdf..7ae9baf72a 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -27,24 +27,23 @@ let plugin_name = <:expr< __coq_plugin_name >> let rec make_patt = function | [] -> <:patt< [] >> - | ExtNonTerminal (_, p) :: l -> + | ExtNonTerminal (_, _, p) :: l -> let p = Names.Id.to_string p in <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l let rec make_when loc = function | [] -> <:expr< True >> - | ExtNonTerminal (EntryName (t, _), p) :: l -> + | ExtNonTerminal (t, _, p) :: l -> let p = Names.Id.to_string p in let l = make_when loc l in - let t = mlexpr_of_argtype loc (Genarg.unquote t) in + let t = mlexpr_of_argtype loc t in <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >> | _::l -> make_when loc l let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> - | ExtNonTerminal (EntryName (t, _), p) :: l -> - let t = Genarg.unquote t in + | ExtNonTerminal (t, _, p) :: l -> let p = Names.Id.to_string p in let loc = MLast.loc_of_expr e in let e = make_let raw e l in @@ -56,7 +55,7 @@ let rec make_let raw e = function let rec extract_signature = function | [] -> [] - | ExtNonTerminal (EntryName (t, _), _) :: l -> Genarg.unquote t :: extract_signature l + | ExtNonTerminal (t, _, _) :: l -> t :: extract_signature l | _::l -> extract_signature l @@ -78,18 +77,9 @@ let make_fun_clauses loc s l = let map c = Compat.make_fun loc [make_clause c] in mlexpr_of_list map l -let rec make_args = function - | [] -> <:expr< [] >> - | ExtNonTerminal (EntryName (t, _), p) :: l -> - let t = Genarg.unquote t in - let p = Names.Id.to_string p in - <:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >> - | _::l -> make_args l - let make_prod_item = function | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | ExtNonTerminal (EntryName (nt, g), id) -> - let nt = Genarg.unquote nt in + | ExtNonTerminal (nt, g, id) -> <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ $mlexpr_of_prod_entry_key g$ >> @@ -98,9 +88,8 @@ let mlexpr_of_clause cl = let rec make_tags loc = function | [] -> <:expr< [] >> - | ExtNonTerminal (EntryName (t, _), p) :: l -> + | ExtNonTerminal (t, _, p) :: l -> let l = make_tags loc l in - let t = Genarg.unquote t in let t = mlexpr_of_argtype loc t in <:expr< [ $t$ :: $l$ ] >> | _::l -> make_tags loc l @@ -115,8 +104,7 @@ let make_one_printing_rule (pt,_,e) = let make_printing_rule r = mlexpr_of_list make_one_printing_rule r let make_empty_check = function -| ExtNonTerminal (EntryName (t, e), _)-> - let t = Genarg.unquote t in +| ExtNonTerminal (t, e, _)-> let is_extra = match t with ExtraArgType _ -> true | _ -> false in if is_possibly_empty e || is_extra then (* This possibly parses epsilon *) @@ -153,17 +141,11 @@ let rec possibly_atomic loc = function (** Special treatment of constr entries *) let is_constr_gram = function | ExtTerminal _ -> false -| ExtNonTerminal (EntryName (_, e), _) -> - match e with - | Aentry e -> - begin match Entry.repr e with - | Entry.Static ("constr", "constr") -> true - | _ -> false - end - | _ -> false +| ExtNonTerminal (_, Extend.Uentry "constr", _) -> true +| _ -> false let make_var = function - | ExtNonTerminal (_, p) -> Some p + | ExtNonTerminal (_, _, p) -> Some p | _ -> assert false let declare_tactic loc s c cl = match cl with @@ -253,11 +235,11 @@ EXTEND ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let entry = interp_entry_name false TgAny e "" in - ExtNonTerminal (entry, Names.Id.of_string s) + let e = parse_user_entry e "" in + ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let entry = interp_entry_name false TgAny e sep in - ExtNonTerminal (entry, Names.Id.of_string s) + let e = parse_user_entry e sep in + ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); ExtTerminal s diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 8de59e5cd2..9d78c104ed 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -34,8 +34,7 @@ type rule = { let rec make_let e = function | [] -> e - | ExtNonTerminal (EntryName (t, _), p) :: l -> - let t = Genarg.unquote t in + | ExtNonTerminal (t, _, p) :: l -> let p = Names.Id.to_string p in let loc = MLast.loc_of_expr e in let e = make_let e l in @@ -50,7 +49,7 @@ let make_clause { r_patt = pt; r_branch = e; } = (* To avoid warnings *) let mk_ignore c pt = let names = CList.map_filter (function - | ExtNonTerminal (_, p) -> Some (Names.Id.to_string p) + | ExtNonTerminal (_, _, p) -> Some (Names.Id.to_string p) | _ -> None) pt in let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in let names = List.fold_left fold <:expr< () >> names in @@ -181,11 +180,11 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let entry = interp_entry_name false TgAny e "" in - ExtNonTerminal (entry, Names.Id.of_string s) + let e = parse_user_entry e "" in + ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let entry = interp_entry_name false TgAny e sep in - ExtNonTerminal (entry, Names.Id.of_string s) + let e = parse_user_entry e sep in + ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) | s = STRING -> ExtTerminal s ] ] diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 592c879197..aa2e092adc 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -153,11 +153,15 @@ type gram_universe = Entry.universe val get_univ : string -> gram_universe +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a Gram.entry -> typed_entry + val uprim : gram_universe val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe +val get_entry : gram_universe -> string -> typed_entry + val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> 'a Gram.entry @@ -282,6 +286,8 @@ type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target val interp_entry_name : bool (** true to fail on unknown entry *) -> 's target -> string -> string -> 's entry_name +val parse_user_entry : string -> string -> user_symbol + (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * argument_type) list -- cgit v1.2.3 From 43490147b0749f46eb90ff69c3bbdb3991fb526c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 00:36:40 +0100 Subject: Removing dynamic entries from Pcoq. --- parsing/entry.ml | 8 ++------ parsing/entry.mli | 8 +------- parsing/pcoq.ml | 12 +++--------- parsing/pcoq.mli | 3 +-- toplevel/metasyntax.ml | 2 +- 5 files changed, 8 insertions(+), 25 deletions(-) diff --git a/parsing/entry.ml b/parsing/entry.ml index 97d601320d..0519903d3d 100644 --- a/parsing/entry.ml +++ b/parsing/entry.ml @@ -11,9 +11,7 @@ open Util type 'a t = string * string -type repr = -| Static of string * string -| Dynamic of string +type repr = string * string type universe = string @@ -58,6 +56,4 @@ let unsafe_of_name (u, s) = assert (String.Set.mem uname !entries); (u, s) -let repr = function -| ("", u) -> Dynamic u -| (u, s) -> Static (u, s) +let repr (u, s) = (u, s) diff --git a/parsing/entry.mli b/parsing/entry.mli index 6854a5cb45..97cd5b1105 100644 --- a/parsing/entry.mli +++ b/parsing/entry.mli @@ -14,9 +14,7 @@ type 'a t unique names made of a universe and an entry name. They should be kept synchronized with the {!Pcoq} entries though. *) -type repr = -| Static of string * string -| Dynamic of string +type repr = string * string (** Representation of entries. *) (** Table of Coq statically defined grammar entries *) @@ -41,10 +39,6 @@ val create : universe -> string -> 'a t (** {5 Meta-programming} *) -val dynamic : string -> 'a t -(** Dynamic entries. They refer to entries defined in the code source and may - only be used in meta-programming definitions from the grammar directory. *) - val repr : 'a t -> repr val unsafe_of_name : (string * string) -> 'a t diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index c8cd16aaf4..291e919d85 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -224,10 +224,7 @@ let get_entry u s = Hashtbl.find utab s let get_typed_entry e = - let (u, s) = match Entry.repr e with - | Entry.Dynamic _ -> assert false - | Entry.Static (u, s) -> (u, s) - in + let (u, s) = Entry.repr e in let u = Entry.get_univ u in get_entry u s @@ -822,7 +819,7 @@ let rec parse_user_entry s sep = let s = match s with "hyp" -> "var" | _ -> s in Uentry s -let rec interp_entry_name static up_level s sep = +let rec interp_entry_name up_level s sep = let rec eval = function | Ulist1 e -> let EntryName (t, g) = eval e in @@ -847,10 +844,7 @@ let rec interp_entry_name static up_level s sep = try try_get_entry uprim s with Not_found -> try try_get_entry uconstr s with Not_found -> try try_get_entry utactic s with Not_found -> - if static then - error ("Unknown entry "^s^".") - else - EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) + error ("Unknown entry "^s^".") end | Uentryl (s, n) -> (** FIXME: do better someday *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index aa2e092adc..816220b47d 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -283,8 +283,7 @@ type 's entry_name = EntryName : type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target -val interp_entry_name : bool (** true to fail on unknown entry *) -> - 's target -> string -> string -> 's entry_name +val interp_entry_name : 's target -> string -> string -> 's entry_name val parse_user_entry : string -> string -> user_symbol diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 6919729fe9..9a27ae7df4 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -48,7 +48,7 @@ let add_token_obj s = Lib.add_anonymous_leaf (inToken s) let interp_prod_item lev = function | TacTerm s -> GramTerminal s | TacNonTerm (loc, nt, (_, sep)) -> - let EntryName (etyp, e) = interp_entry_name true (TgTactic lev) nt sep in + let EntryName (etyp, e) = interp_entry_name (TgTactic lev) nt sep in GramNonTerminal (loc, etyp, e) let make_terminal_status = function -- cgit v1.2.3 From 0d1345ea2423fc418a470786b0b33b80df3a67bc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 01:08:21 +0100 Subject: Temporary commit getting rid of Obj.magic unsafety for Genarg. This will allow an easier landing of the rewriting of Genarg. --- interp/constrarg.ml | 3 --- lib/genarg.ml | 3 +++ lib/genarg.mli | 3 +++ parsing/pcoq.ml | 22 ++++++---------------- printing/pptactic.ml | 11 ++++++----- 5 files changed, 18 insertions(+), 24 deletions(-) diff --git a/interp/constrarg.ml b/interp/constrarg.ml index a8dfd02e1d..f8957a24b8 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -19,9 +19,6 @@ let loc_of_or_by_notation f = function | AN c -> f c | ByNotation (loc,s,_) -> loc -let unsafe_of_type (t : argument_type) : ('a, 'b, 'c) Genarg.genarg_type = - Obj.magic t - let wit_int_or_var = Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) None "int_or_var" diff --git a/lib/genarg.ml b/lib/genarg.ml index c2c1014f17..5efb074440 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -117,6 +117,9 @@ type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type +let arg_list wit = ListArgType wit +let arg_opt wit = OptArgType wit + type ('a, 'b, 'c, 'l) cast = Obj.t let raw = Obj.obj diff --git a/lib/genarg.mli b/lib/genarg.mli index 56c09f14fc..8099c062ab 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -265,6 +265,9 @@ val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) gena val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type +val arg_list : ('a, 'l) abstract_argument_type -> ('a list, 'l) abstract_argument_type +val arg_opt : ('a, 'l) abstract_argument_type -> ('a option, 'l) abstract_argument_type + (** {5 Magic used by the parser} *) val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 291e919d85..d5acf59f6f 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -759,21 +759,11 @@ let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) else Aentryl (name_of_entry Tactic.tactic_expr, n) -let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type = - (** FIXME *) - Obj.magic - let try_get_entry u s = (** Order the effects: get_entry can raise Not_found *) let TypedEntry (typ, _) = get_entry u s in EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) -let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type = - fun t -> unsafe_of_genarg (ListArgType (unquote t)) - -let wit_opt : 'a raw_abstract_argument_type -> 'a option raw_abstract_argument_type = - fun t -> unsafe_of_genarg (OptArgType (unquote t)) - type _ target = | TgAny : 's target | TgTactic : int -> Tacexpr.raw_tactic_expr target @@ -823,22 +813,22 @@ let rec interp_entry_name up_level s sep = let rec eval = function | Ulist1 e -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist1 g) + EntryName (arg_list t, Alist1 g) | Ulist1sep (e, sep) -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist1sep (g, sep)) + EntryName (arg_list t, Alist1sep (g, sep)) | Ulist0 e -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist0 g) + EntryName (arg_list t, Alist0 g) | Ulist0sep (e, sep) -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Alist0sep (g, sep)) + EntryName (arg_list t, Alist0sep (g, sep)) | Uopt e -> let EntryName (t, g) = eval e in - EntryName (wit_opt t, Aopt g) + EntryName (arg_opt t, Aopt g) | Umodifiers e -> let EntryName (t, g) = eval e in - EntryName (wit_list t, Amodifiers g) + EntryName (arg_list t, Amodifiers g) | Uentry s -> begin try try_get_entry uprim s with Not_found -> diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 5bc242b2b2..e7443fd02e 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1354,11 +1354,12 @@ module Make let check_val_type t arg = let AnyArg t = t in - let t = Genarg.val_tag (Obj.magic t) in (** FIXME *) - let Val.Dyn (t', _) = arg in - match Genarg.Val.eq t t' with - | None -> false - | Some _ -> true +(* let t = Genarg.val_tag (Obj.magic t) in *) +(* let Val.Dyn (t', _) = arg in *) +(* match Genarg.Val.eq t t' with *) +(* | None -> false *) +(* | Some _ -> true *) + true (** FIXME *) let pr_alias pr lev key args = pr_alias_gen check_val_type pr lev key args -- cgit v1.2.3 From 32a18b19f99c82dea5358bdebeb19862d30c4973 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Jan 2016 22:39:23 +0100 Subject: Adding a structure indexed by tags. --- lib/dyn.ml | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- lib/dyn.mli | 29 +++++++++++++++++++++++++++++ 2 files changed, 84 insertions(+), 1 deletion(-) diff --git a/lib/dyn.ml b/lib/dyn.ml index 826cfaf8db..660ffc44ec 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -6,6 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module type TParam = +sig + type 'a t +end + module type S = sig type 'a tag @@ -14,6 +19,30 @@ type t = Dyn : 'a tag * 'a -> t val create : string -> 'a tag val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option val repr : 'a tag -> string + +type any = Any : 'a tag -> any + +val name : string -> any option + +module Map(M : TParam) : +sig + type t + val empty : t + val add : 'a tag -> 'a M.t -> t -> t + val remove : 'a tag -> t -> t + val find : 'a tag -> t -> 'a M.t + val mem : 'a tag -> t -> bool + + type any = Any : 'a tag * 'a M.t -> any + + type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } + val map : map -> t -> t + + val iter : (any -> unit) -> t -> unit + val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r + +end + val dump : unit -> (int * string) list end @@ -25,6 +54,8 @@ type 'a tag = int type t = Dyn : 'a tag * 'a -> t +type any = Any : 'a tag -> any + let dyntab = ref (Int.Map.empty : string Int.Map.t) (** Instead of working with tags as strings, which are costly, we use their hash. We ensure unicity of the hash in the [create] function. If ever a @@ -51,6 +82,29 @@ let repr s = let () = Printf.eprintf "Unknown dynamic tag %i\n%!" s in assert false +let name s = + let hash = Hashtbl.hash s in + if Int.Map.mem hash !dyntab then Some (Any hash) else None + let dump () = Int.Map.bindings !dyntab -end \ No newline at end of file +module Map(M : TParam) = +struct +type t = Obj.t M.t Int.Map.t +let cast : 'a M.t -> 'b M.t = Obj.magic +let empty = Int.Map.empty +let add tag v m = Int.Map.add tag (cast v) m +let remove tag m = Int.Map.remove tag m +let find tag m = cast (Int.Map.find tag m) +let mem = Int.Map.mem + +type any = Any : 'a tag * 'a M.t -> any + +type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } +let map f m = Int.Map.mapi f.map m + +let iter f m = Int.Map.iter (fun k v -> f (Any (k, v))) m +let fold f m accu = Int.Map.fold (fun k v accu -> f (Any (k, v)) accu) m accu +end + +end diff --git a/lib/dyn.mli b/lib/dyn.mli index 28587859e1..d39acdf5d7 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -7,6 +7,10 @@ (************************************************************************) (** Dynamics. Use with extreme care. Not for kids. *) +module type TParam = +sig + type 'a t +end module type S = sig @@ -16,7 +20,32 @@ type t = Dyn : 'a tag * 'a -> t val create : string -> 'a tag val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option val repr : 'a tag -> string + +type any = Any : 'a tag -> any + +val name : string -> any option + +module Map(M : TParam) : +sig + type t + val empty : t + val add : 'a tag -> 'a M.t -> t -> t + val remove : 'a tag -> t -> t + val find : 'a tag -> t -> 'a M.t + val mem : 'a tag -> t -> bool + + type any = Any : 'a tag * 'a M.t -> any + + type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } + val map : map -> t -> t + + val iter : (any -> unit) -> t -> unit + val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r + +end + val dump : unit -> (int * string) list + end (** FIXME: use OCaml 4.02 generative functors when available *) -- cgit v1.2.3 From be7f6f003ff4318dbe962ec141060a9daf92a80d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 12 Jan 2016 10:31:48 +0100 Subject: Reimplementing Genarg safely. No more Obj.magic in Genarg. We leverage the expressivity of GADT coupled with dynamic tags to get rid of unsafety. For now the API did not change in order to port the legacy code more easily. --- lib/genarg.ml | 288 +++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 196 insertions(+), 92 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index 5efb074440..030797da9c 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -9,12 +9,13 @@ open Pp open Util -module Dyn = Dyn.Make(struct end) +module ValT = Dyn.Make(struct end) +module ArgT = Dyn.Make(struct end) module Val = struct - type 'a typ = 'a Dyn.tag + type 'a typ = 'a ValT.tag type _ tag = | Base : 'a typ -> 'a tag @@ -26,7 +27,7 @@ struct let rec eq : type a b. a tag -> b tag -> (a, b) CSig.eq option = fun t1 t2 -> match t1, t2 with - | Base t1, Base t2 -> Dyn.eq t1 t2 + | Base t1, Base t2 -> ValT.eq t1 t2 | List t1, List t2 -> begin match eq t1 t2 with | None -> None @@ -48,7 +49,7 @@ struct | _ -> None let rec repr : type a. a tag -> std_ppcmds = function - | Base t -> str (Dyn.repr t) + | Base t -> str (ValT.repr t) | List t -> repr t ++ spc () ++ str "list" | Opt t -> repr t ++ spc () ++ str "option" | Pair (t1, t2) -> str "(" ++ repr t1 ++ str " * " ++ repr t2 ++ str ")" @@ -78,58 +79,147 @@ let rec pr_argument_type = function str "*" ++ spc () ++ pr_argument_type t2 ++ str ")" | ExtraArgType s -> str s -type ('raw, 'glob, 'top) genarg_type = argument_type +type (_, _, _) genarg_type = +| ExtraArg : ('a * 'b * 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type +| ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type +| OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type +| PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> + ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type + +let rec genarg_type_eq : type a1 a2 b1 b2 c1 c2. + (a1, b1, c1) genarg_type -> (a2, b2, c2) genarg_type -> + (a1 * b1 * c1, a2 * b2 * c2) CSig.eq option = +fun t1 t2 -> match t1, t2 with +| ExtraArg t1, ExtraArg t2 -> ArgT.eq t1 t2 +| ListArg t1, ListArg t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end +| OptArg t1, OptArg t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end +| PairArg (t1, u1), PairArg (t2, u2) -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> + match genarg_type_eq u1 u2 with + | None -> None + | Some Refl -> Some Refl + end +| _ -> None type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision *) (* Dynamics but tagged by a type expression *) -type rlevel -type glevel -type tlevel +type rlevel = [ `rlevel ] +type glevel = [ `glevel ] +type tlevel = [ `tlevel ] + +type _ level = +| Rlevel : rlevel level +| Glevel : glevel level +| Tlevel : tlevel level + +type (_, _) abstract_argument_type = +| Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type +| Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type +| Topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type + +type 'l generic_argument = GenArg : ('a, 'l) abstract_argument_type * 'a -> 'l generic_argument -type 'a generic_argument = argument_type * Obj.t type raw_generic_argument = rlevel generic_argument type glob_generic_argument = glevel generic_argument type typed_generic_argument = tlevel generic_argument -let rawwit t = t -let glbwit t = t -let topwit t = t +let rawwit t = Rawwit t +let glbwit t = Glbwit t +let topwit t = Topwit t -let wit_list t = ListArgType t +let wit_list t = ListArg t -let wit_opt t = OptArgType t +let wit_opt t = OptArg t -let wit_pair t1 t2 = PairArgType (t1,t2) +let wit_pair t1 t2 = PairArg (t1, t2) -let in_gen t o = (t,Obj.repr o) -let out_gen t (t',o) = if argument_type_eq t t' then Obj.magic o else failwith "out_gen" -let genarg_tag (s,_) = s +let in_gen t o = GenArg (t, o) -let has_type (t, v) u = argument_type_eq t u +let abstract_argument_type_eq : + type a b l. (a, l) abstract_argument_type -> (b, l) abstract_argument_type -> (a, b) CSig.eq option = + fun t1 t2 -> match t1, t2 with + | Rawwit t1, Rawwit t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Glbwit t1, Glbwit t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Topwit t1, Topwit t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + +let out_gen (type a) (type l) (t : (a, l) abstract_argument_type) (o : l generic_argument) : a = + let GenArg (t', v) = o in + match abstract_argument_type_eq t t' with + | None -> failwith "out_gen" + | Some Refl -> v + +let has_type (GenArg (t, v)) u = match abstract_argument_type_eq t u with +| None -> false +| Some _ -> true -let unquote x = x +let rec untype : type a b c. (a, b, c) genarg_type -> argument_type = function +| ExtraArg t -> ExtraArgType (ArgT.repr t) +| ListArg t -> ListArgType (untype t) +| OptArg t -> OptArgType (untype t) +| PairArg (t1, t2) -> PairArgType (untype t1, untype t2) + +let unquote : type l. (_, l) abstract_argument_type -> _ = function +| Rawwit t -> untype t +| Glbwit t -> untype t +| Topwit t -> untype t + +let genarg_tag (GenArg (t, _)) = unquote t -type ('a,'b) abstract_argument_type = argument_type type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type -let arg_list wit = ListArgType wit -let arg_opt wit = OptArgType wit +let arg_list : type l. (_, l) abstract_argument_type -> (_, l) abstract_argument_type = function +| Rawwit t -> Rawwit (ListArg t) +| Glbwit t -> Glbwit (ListArg t) +| Topwit t -> Topwit (ListArg t) -type ('a, 'b, 'c, 'l) cast = Obj.t +let arg_opt : type l. (_, l) abstract_argument_type -> (_, l) abstract_argument_type = function +| Rawwit t -> Rawwit (OptArg t) +| Glbwit t -> Glbwit (OptArg t) +| Topwit t -> Topwit (OptArg t) -let raw = Obj.obj -let glb = Obj.obj -let top = Obj.obj +type ('a, 'b, 'c, 'l) cast = +| Rcast : 'a -> ('a, 'b, 'c, rlevel) cast +| Gcast : 'b -> ('a, 'b, 'c, glevel) cast +| Tcast : 'c -> ('a, 'b, 'c, tlevel) cast + +let raw : ('a, 'b, 'c, rlevel) cast -> _ = function Rcast x -> x +let glb : ('a, 'b, 'c, glevel) cast -> _ = function Gcast x -> x +let top : ('a, 'b, 'c, tlevel) cast -> _ = function Tcast x -> x type ('r, 'l) unpacker = { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r } -let unpack pack (t, obj) = pack.unpacker t (Obj.obj obj) +let unpack (type l) (pack : (_, l) unpacker) (GenArg (t, obj) : l generic_argument) = match t with +| Rawwit t -> pack.unpacker t (Rcast obj) +| Glbwit t -> pack.unpacker t (Gcast obj) +| Topwit t -> pack.unpacker t (Tcast obj) (** Type transformers *) @@ -137,16 +227,20 @@ type ('r, 'l) list_unpacker = { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list, 'l) cast -> 'r } -let list_unpack pack (t, obj) = match t with -| ListArgType t -> pack.list_unpacker t (Obj.obj obj) +let list_unpack (type l) (pack : (_, l) list_unpacker) (GenArg (t, obj) : l generic_argument) = match t with +| Rawwit (ListArg t) -> pack.list_unpacker t (Rcast obj) +| Glbwit (ListArg t) -> pack.list_unpacker t (Gcast obj) +| Topwit (ListArg t) -> pack.list_unpacker t (Tcast obj) | _ -> failwith "out_gen" type ('r, 'l) opt_unpacker = { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option, 'l) cast -> 'r } -let opt_unpack pack (t, obj) = match t with -| OptArgType t -> pack.opt_unpacker t (Obj.obj obj) +let opt_unpack (type l) (pack : (_, l) opt_unpacker) (GenArg (t, obj) : l generic_argument) = match t with +| Rawwit (OptArg t) -> pack.opt_unpacker t (Rcast obj) +| Glbwit (OptArg t) -> pack.opt_unpacker t (Gcast obj) +| Topwit (OptArg t) -> pack.opt_unpacker t (Tcast obj) | _ -> failwith "out_gen" type ('r, 'l) pair_unpacker = @@ -154,52 +248,60 @@ type ('r, 'l) pair_unpacker = ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r } -let pair_unpack pack (t, obj) = match t with -| PairArgType (t1, t2) -> pack.pair_unpacker t1 t2 (Obj.obj obj) +let pair_unpack (type l) (pack : (_, l) pair_unpacker) (GenArg (t, obj) : l generic_argument) = match t with +| Rawwit (PairArg (t1, t2)) -> pack.pair_unpacker t1 t2 (Rcast obj) +| Glbwit (PairArg (t1, t2)) -> pack.pair_unpacker t1 t2 (Gcast obj) +| Topwit (PairArg (t1, t2)) -> pack.pair_unpacker t1 t2 (Tcast obj) | _ -> failwith "out_gen" (** Creating args *) -type load = { - nil : Obj.t option; - dyn : Obj.t Val.tag; +module type Param = sig type ('raw, 'glb, 'top) t end +module ArgMap(M : Param) = +struct + type _ pack = Pack : ('raw, 'glb, 'top) M.t -> ('raw * 'glb * 'top) pack + include ArgT.Map(struct type 'a t = 'a pack end) +end + +type ('raw, 'glb, 'top) load = { + nil : 'raw option; + dyn : 'top Val.tag; } -let (arg0_map : load String.Map.t ref) = ref String.Map.empty +module LoadMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) load end) -let cast_tag : 'a Val.tag -> 'b Val.tag = Obj.magic +let arg0_map = ref LoadMap.empty let create_arg opt ?dyn name = - if String.Map.mem name !arg0_map then + match ArgT.name name with + | Some _ -> Errors.anomaly (str "generic argument already declared: " ++ str name) - else - let dyn = match dyn with None -> Val.Base (Dyn.create name) | Some dyn -> cast_tag dyn in - let obj = { nil = Option.map Obj.repr opt; dyn; } in - let () = arg0_map := String.Map.add name obj !arg0_map in - ExtraArgType name + | None -> + let dyn = match dyn with None -> Val.Base (ValT.create name) | Some dyn -> dyn in + let obj = LoadMap.Pack { nil = opt; dyn; } in + let name = ArgT.create name in + let () = arg0_map := LoadMap.add name obj !arg0_map in + ExtraArg name let make0 = create_arg -let default_empty_value t = - let rec aux = function - | ListArgType _ -> Some (Obj.repr []) - | OptArgType _ -> Some (Obj.repr None) - | PairArgType(t1, t2) -> - (match aux t1, aux t2 with - | Some v1, Some v2 -> Some (Obj.repr (v1, v2)) - | _ -> None) - | ExtraArgType s -> - (String.Map.find s !arg0_map).nil - in - match aux t with - | Some v -> Some (Obj.obj v) - | None -> None +let rec default_empty_value : type a b c. (a, b, c) genarg_type -> a option = function +| ListArg _ -> Some [] +| OptArg _ -> Some None +| PairArg (t1, t2) -> + begin match default_empty_value t1, default_empty_value t2 with + | Some v1, Some v2 -> Some (v1, v2) + | _ -> None + end +| ExtraArg s -> + match LoadMap.find s !arg0_map with LoadMap.Pack obj -> obj.nil -let rec val_tag = function -| ExtraArgType s -> cast_tag (String.Map.find s !arg0_map).dyn -| ListArgType t -> cast_tag (Val.List (val_tag t)) -| OptArgType t -> cast_tag (Val.Opt (val_tag t)) -| PairArgType (t1, t2) -> cast_tag (Val.Pair (val_tag t1, val_tag t2)) +let rec val_tag : type a b c. (a, b, c) genarg_type -> c Val.tag = function +| ListArg t -> Val.List (val_tag t) +| OptArg t -> Val.Opt (val_tag t) +| PairArg (t1, t2) -> Val.Pair (val_tag t1, val_tag t2) +| ExtraArg s -> + match LoadMap.find s !arg0_map with LoadMap.Pack obj -> obj.dyn exception CastError of argument_type * Val.t @@ -210,39 +312,42 @@ let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> | Some Refl -> Some x let try_prj wit v = match prj (val_tag wit) v with -| None -> raise (CastError (wit, v)) +| None -> raise (CastError (untype wit, v)) | Some x -> x -let rec val_cast : type a. a typed_abstract_argument_type -> Val.t -> a = -fun wit v -> match unquote wit with -| ExtraArgType _ -> try_prj wit v -| ListArgType t -> +let rec val_cast : type a b c. (a, b, c) genarg_type -> Val.t -> c = +fun wit v -> match wit with +| ExtraArg _ -> try_prj wit v +| ListArg t -> let Val.Dyn (tag, v) = v in begin match tag with | Val.List tag -> let map x = val_cast t (Val.Dyn (tag, x)) in - Obj.magic (List.map map v) - | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + List.map map v + | _ -> raise (CastError (untype wit, Val.Dyn (tag, v))) end -| OptArgType t -> +| OptArg t -> let Val.Dyn (tag, v) = v in begin match tag with | Val.Opt tag -> let map x = val_cast t (Val.Dyn (tag, x)) in - Obj.magic (Option.map map v) - | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + Option.map map v + | _ -> raise (CastError (untype wit, Val.Dyn (tag, v))) end -| PairArgType (t1, t2) -> +| PairArg (t1, t2) -> let Val.Dyn (tag, v) = v in begin match tag with | Val.Pair (tag1, tag2) -> let (v1, v2) = v in let v1 = Val.Dyn (tag1, v1) in let v2 = Val.Dyn (tag2, v2) in - Obj.magic (val_cast t1 v1, val_cast t2 v2) - | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + (val_cast t1 v1, val_cast t2 v2) + | _ -> raise (CastError (untype wit, Val.Dyn (tag, v))) end +let val_tag = function Topwit t -> val_tag t +let val_cast = function Topwit t -> val_cast t + (** Registering genarg-manipulating functions *) module type GenObj = @@ -254,30 +359,31 @@ end module Register (M : GenObj) = struct - let arg0_map = - ref (String.Map.empty : (Obj.t, Obj.t, Obj.t) M.obj String.Map.t) + module GenMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) M.obj end) + let arg0_map = ref GenMap.empty let register0 arg f = match arg with - | ExtraArgType s -> - if String.Map.mem s !arg0_map then - let msg = str M.name ++ str " function already registered: " ++ str s in + | ExtraArg s -> + if GenMap.mem s !arg0_map then + let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) in Errors.anomaly msg else - arg0_map := String.Map.add s (Obj.magic f) !arg0_map + arg0_map := GenMap.add s (GenMap.Pack f) !arg0_map | _ -> assert false let get_obj0 name = - try String.Map.find name !arg0_map + try + let GenMap.Pack obj = GenMap.find name !arg0_map in obj with Not_found -> - match M.default (ExtraArgType name) with + match M.default (ExtraArg name) with | None -> - Errors.anomaly (str M.name ++ str " function not found: " ++ str name) + Errors.anomaly (str M.name ++ str " function not found: " ++ str (ArgT.repr name)) | Some obj -> obj (** For now, the following function is quite dummy and should only be applied to an extra argument type, otherwise, it will badly fail. *) let obj t = match t with - | ExtraArgType s -> Obj.magic (get_obj0 s) + | ExtraArg s -> get_obj0 s | _ -> assert false end @@ -285,12 +391,10 @@ end (** Hackish part *) let arg0_names = ref (String.Map.empty : string String.Map.t) -(** We use this table to associate a name to a given witness, to use it with - the extension mechanism. This is REALLY ad-hoc, but I do not know how to - do so nicely either. *) - + let register_name0 t name = match t with -| ExtraArgType s -> +| ExtraArg s -> + let s = ArgT.repr s in let () = assert (not (String.Map.mem s !arg0_names)) in arg0_names := String.Map.add s name !arg0_names | _ -> failwith "register_name0" -- cgit v1.2.3 From 15747cc2aaaeeb5d59ec90cda940c1dc6de01a6a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 01:34:58 +0100 Subject: Exporting Genarg implementation in the API. We can now use the expressivity of GADT to work around historical kludges of generic arguments. --- lib/genarg.mli | 38 ++++++++++++++++++++++++++++++++------ 1 file changed, 32 insertions(+), 6 deletions(-) diff --git a/lib/genarg.mli b/lib/genarg.mli index 8099c062ab..38dc0c684a 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -68,7 +68,21 @@ ExtraArgType of string '_a '_b (** {5 Generic types} *) -type ('raw, 'glob, 'top) genarg_type +module ArgT : +sig + type 'a tag + val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option + val repr : 'a tag -> string + type any = Any : 'a tag -> any + val name : string -> any option +end + +type (_, _, _) genarg_type = +| ExtraArg : ('a * 'b * 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type +| ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type +| OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type +| PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> + ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type (** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized one, and ['top] the internalized one. *) @@ -112,11 +126,14 @@ val create_arg : 'raw option -> ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'to out_gen is monomorphic over 'a, hence type-safe *) -type rlevel -type glevel -type tlevel +type rlevel = [ `rlevel ] +type glevel = [ `glevel ] +type tlevel = [ `tlevel ] -type ('a, 'co) abstract_argument_type +type (_, _) abstract_argument_type = +| Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type +| Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type +| Topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type (** Type at level ['co] represented by an OCaml value of type ['a]. *) type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type @@ -141,7 +158,7 @@ val topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type (** {5 Generic arguments} *) -type 'a generic_argument +type 'l generic_argument = GenArg : ('a, 'l) abstract_argument_type * 'a -> 'l generic_argument (** A inhabitant of ['level generic_argument] is a inhabitant of some type at level ['level], together with the representation of this type. *) @@ -220,7 +237,16 @@ type argument_type = exception CastError of argument_type * Val.t (** Exception raised by {!val_cast} *) +(** {6 Equalities} *) + val argument_type_eq : argument_type -> argument_type -> bool +val genarg_type_eq : + ('a1, 'b1, 'c1) genarg_type -> + ('a2, 'b2, 'c2) genarg_type -> + ('a1 * 'b1 * 'c1, 'a2 * 'b2 * 'c2) CSig.eq option +val abstract_argument_type_eq : + ('a, 'l) abstract_argument_type -> ('b, 'l) abstract_argument_type -> + ('a, 'b) CSig.eq option val pr_argument_type : argument_type -> Pp.std_ppcmds (** Print a human-readable representation for a given type. *) -- cgit v1.2.3 From 88a16f49efd315aa1413da67f6d321a5fe269772 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 01:46:02 +0100 Subject: Simplification and type-safety of Pcoq thanks to GADTs in Genarg. --- lib/genarg.ml | 10 ---------- lib/genarg.mli | 3 --- parsing/pcoq.ml | 12 ++++++++---- 3 files changed, 8 insertions(+), 17 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index 030797da9c..6c10dee2ae 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -194,16 +194,6 @@ type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type -let arg_list : type l. (_, l) abstract_argument_type -> (_, l) abstract_argument_type = function -| Rawwit t -> Rawwit (ListArg t) -| Glbwit t -> Glbwit (ListArg t) -| Topwit t -> Topwit (ListArg t) - -let arg_opt : type l. (_, l) abstract_argument_type -> (_, l) abstract_argument_type = function -| Rawwit t -> Rawwit (OptArg t) -| Glbwit t -> Glbwit (OptArg t) -| Topwit t -> Topwit (OptArg t) - type ('a, 'b, 'c, 'l) cast = | Rcast : 'a -> ('a, 'b, 'c, rlevel) cast | Gcast : 'b -> ('a, 'b, 'c, glevel) cast diff --git a/lib/genarg.mli b/lib/genarg.mli index 38dc0c684a..a1b74c6744 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -291,9 +291,6 @@ val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) gena val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type -val arg_list : ('a, 'l) abstract_argument_type -> ('a list, 'l) abstract_argument_type -val arg_opt : ('a, 'l) abstract_argument_type -> ('a option, 'l) abstract_argument_type - (** {5 Magic used by the parser} *) val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index d5acf59f6f..c87084f2cc 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -237,14 +237,15 @@ let new_entry etyp u s = let e = Gram.entry_create ename in Hashtbl.add utab s (TypedEntry (etyp, e)); e -let create_entry u s etyp = +let create_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in try let TypedEntry (typ, e) = Hashtbl.find utab s in - let u = Entry.univ_name u in - if not (argument_type_eq (unquote typ) (unquote etyp)) then + match abstract_argument_type_eq typ etyp with + | None -> + let u = Entry.univ_name u in failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - Obj.magic e + | Some Refl -> e with Not_found -> new_entry etyp u s @@ -809,6 +810,9 @@ let rec parse_user_entry s sep = let s = match s with "hyp" -> "var" | _ -> s in Uentry s +let arg_list = function Rawwit t -> Rawwit (ListArg t) +let arg_opt = function Rawwit t -> Rawwit (OptArg t) + let rec interp_entry_name up_level s sep = let rec eval = function | Ulist1 e -> -- cgit v1.2.3 From d3ee6b2fbcd0fbb666af7f1920446e809e8d6e1e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 01:58:05 +0100 Subject: Getting rid of the awkward unpack mechanism from Genarg. --- interp/genintern.ml | 14 +++--- lib/genarg.ml | 8 ---- lib/genarg.mli | 38 ---------------- printing/genprint.ml | 6 +-- printing/pptactic.ml | 125 +++++++++++++++++++++++---------------------------- tactics/geninterp.ml | 9 ++-- tactics/tacintern.ml | 40 +++++++---------- tactics/tacinterp.ml | 46 +++++++++---------- tactics/tacsubst.ml | 40 +++++++---------- 9 files changed, 122 insertions(+), 204 deletions(-) diff --git a/interp/genintern.ml b/interp/genintern.ml index 7795946d56..7a5f84704f 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -37,20 +37,16 @@ module Subst = Register (SubstObj) let intern = Intern.obj let register_intern0 = Intern.register0 -let generic_intern ist v = - let unpacker wit v = - let (ist, v) = intern wit ist (raw v) in - (ist, in_gen (glbwit wit) v) - in - unpack { unpacker; } v +let generic_intern ist (GenArg (Rawwit wit, v)) = + let (ist, v) = intern wit ist v in + (ist, in_gen (glbwit wit) v) (** Substitution functions *) let substitute = Subst.obj let register_subst0 = Subst.register0 -let generic_substitute subs v = - let unpacker wit v = in_gen (glbwit wit) (substitute wit subs (glb v)) in - unpack { unpacker; } v +let generic_substitute subs (GenArg (Glbwit wit, v)) = + in_gen (glbwit wit) (substitute wit subs v) let () = Hook.set Detyping.subst_genarg_hook generic_substitute diff --git a/lib/genarg.ml b/lib/genarg.ml index 6c10dee2ae..58d83ce7ae 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -203,14 +203,6 @@ let raw : ('a, 'b, 'c, rlevel) cast -> _ = function Rcast x -> x let glb : ('a, 'b, 'c, glevel) cast -> _ = function Gcast x -> x let top : ('a, 'b, 'c, tlevel) cast -> _ = function Tcast x -> x -type ('r, 'l) unpacker = - { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r } - -let unpack (type l) (pack : (_, l) unpacker) (GenArg (t, obj) : l generic_argument) = match t with -| Rawwit t -> pack.unpacker t (Rcast obj) -| Glbwit t -> pack.unpacker t (Gcast obj) -| Topwit t -> pack.unpacker t (Tcast obj) - (** Type transformers *) type ('r, 'l) list_unpacker = diff --git a/lib/genarg.mli b/lib/genarg.mli index a1b74c6744..8d1a439827 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -179,44 +179,6 @@ val has_type : 'co generic_argument -> ('a, 'co) abstract_argument_type -> bool (** [has_type v t] tells whether [v] has type [t]. If true, it ensures that [out_gen t v] will not raise a dynamic type exception. *) -(** {6 Destructors} *) - -type ('a, 'b, 'c, 'l) cast - -val raw : ('a, 'b, 'c, rlevel) cast -> 'a -val glb : ('a, 'b, 'c, glevel) cast -> 'b -val top : ('a, 'b, 'c, tlevel) cast -> 'c - -type ('r, 'l) unpacker = - { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r } - -val unpack : ('r, 'l) unpacker -> 'l generic_argument -> 'r -(** Existential-type destructors. *) - -(** {6 Manipulation of generic arguments} - -Those functions fail if they are applied to an argument which has not the right -dynamic type. *) - -type ('r, 'l) list_unpacker = - { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a list, 'b list, 'c list, 'l) cast -> 'r } - -val list_unpack : ('r, 'l) list_unpacker -> 'l generic_argument -> 'r - -type ('r, 'l) opt_unpacker = - { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a option, 'b option, 'c option, 'l) cast -> 'r } - -val opt_unpack : ('r, 'l) opt_unpacker -> 'l generic_argument -> 'r - -type ('r, 'l) pair_unpacker = - { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2. - ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> - (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r } - -val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r - (** {6 Dynamic toplevel values} *) val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag diff --git a/printing/genprint.ml b/printing/genprint.ml index ade69ef831..58c41e839e 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -40,6 +40,6 @@ let raw_print wit v = (Print.obj wit).raw v let glb_print wit v = (Print.obj wit).glb v let top_print wit v = (Print.obj wit).top v -let generic_raw_print v = unpack { unpacker = fun w v -> raw_print w (raw v); } v -let generic_glb_print v = unpack { unpacker = fun w v -> glb_print w (glb v); } v -let generic_top_print v = unpack { unpacker = fun w v -> top_print w (top v); } v +let generic_raw_print (GenArg (Rawwit w, v)) = raw_print w v +let generic_glb_print (GenArg (Glbwit w, v)) = glb_print w v +let generic_top_print (GenArg (Topwit w, v)) = top_print w v diff --git a/printing/pptactic.ml b/printing/pptactic.ml index e7443fd02e..53b0c091a5 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -265,84 +265,71 @@ module Make let with_evars ev s = if ev then "e" ^ s else s - let rec pr_raw_generic_rec prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = - match Genarg.genarg_tag x with - | ListArgType _ -> - let list_unpacker wit l = - let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in - pr_sequence map (raw l) - in - hov 0 (list_unpack { list_unpacker } x) - | OptArgType _ -> - let opt_unpacker wit o = match raw o with + let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in + let ans = pr_sequence map x in + hov 0 ans + | OptArg wit -> + let ans = match x with | None -> mt () | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in - hov 0 (opt_unpack { opt_unpacker } x) - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = raw o in - let p = in_gen (rawwit wit1) p in - let q = in_gen (rawwit wit2) q in - pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q] - in - hov 0 (pair_unpack { pair_unpacker } x) - | ExtraArgType s -> - try pi1 (String.Map.find s !genarg_pprule) prc prlc prtac x - with Not_found -> Genprint.generic_raw_print x - - - let rec pr_glb_generic_rec prc prlc prtac prpat x = - match Genarg.genarg_tag x with - | ListArgType _ -> - let list_unpacker wit l = - let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in - pr_sequence map (glb l) - in - hov 0 (list_unpack { list_unpacker } x) - | OptArgType _ -> - let opt_unpacker wit o = match glb o with + hov 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (rawwit wit1) p in + let q = in_gen (rawwit wit2) q in + hov 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q]) + | ExtraArg s -> + try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x) + with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x) + + + let rec pr_glb_generic_rec prc prlc prtac prpat (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in + let ans = pr_sequence map x in + hov 0 ans + | OptArg wit -> + let ans = match x with | None -> mt () | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in - hov 0 (opt_unpack { opt_unpacker } x) - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = glb o in - let p = in_gen (glbwit wit1) p in - let q = in_gen (glbwit wit2) q in - pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] - in - hov 0 (pair_unpack { pair_unpacker } x) - | ExtraArgType s -> - try pi2 (String.Map.find s !genarg_pprule) prc prlc prtac x - with Not_found -> Genprint.generic_glb_print x - - let rec pr_top_generic_rec prc prlc prtac prpat x = - match Genarg.genarg_tag x with - | ListArgType _ -> - let list_unpacker wit l = - let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in - pr_sequence map (top l) - in - hov 0 (list_unpack { list_unpacker } x) - | OptArgType _ -> - let opt_unpacker wit o = match top o with + hov 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (glbwit wit1) p in + let q = in_gen (glbwit wit2) q in + let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in + hov 0 ans + | ExtraArg s -> + try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x) + with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) x) + + let rec pr_top_generic_rec prc prlc prtac prpat (GenArg (Topwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in + let ans = pr_sequence map x in + hov 0 ans + | OptArg wit -> + let ans = match x with | None -> mt () | Some x -> pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in - hov 0 (opt_unpack { opt_unpacker } x) - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = top o in - let p = in_gen (topwit wit1) p in - let q = in_gen (topwit wit2) q in - pr_sequence (pr_top_generic_rec prc prlc prtac prpat) [p; q] - in - hov 0 (pair_unpack { pair_unpacker } x) - | ExtraArgType s -> - try pi3 (String.Map.find s !genarg_pprule) prc prlc prtac x - with Not_found -> Genprint.generic_top_print x + hov 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (topwit wit1) p in + let q = in_gen (topwit wit2) q in + let ans = pr_sequence (pr_top_generic_rec prc prlc prtac prpat) [p; q] in + hov 0 ans + | ExtraArg s -> + try pi3 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (topwit wit) x) + with Not_found -> Genprint.generic_top_print (in_gen (topwit wit) x) let rec tacarg_using_rule_token pr_gen = function | Egramml.GramTerminal s :: l, al -> keyword s :: tacarg_using_rule_token pr_gen (l,al) diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml index dff87d3a82..fd4f7315e3 100644 --- a/tactics/geninterp.ml +++ b/tactics/geninterp.ml @@ -29,10 +29,7 @@ module Interp = Register(InterpObj) let interp = Interp.obj let register_interp0 = Interp.register0 -let generic_interp ist v = +let generic_interp ist (GenArg (Glbwit wit, v)) = let open Ftactic.Notations in - let unpacker wit v = - interp wit ist (glb v) >>= fun ans -> - Ftactic.return (Val.Dyn (val_tag (topwit wit), ans)) - in - unpack { unpacker; } v + interp wit ist v >>= fun ans -> + Ftactic.return (Val.Dyn (val_tag (topwit wit), ans)) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 6f6c4a05a1..14e0fed31d 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -718,35 +718,29 @@ and intern_match_rule onlytac ist = function Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl) | [] -> [] -and intern_genarg ist x = - match genarg_tag x with - | ListArgType _ -> - let list_unpacker wit l = - let map x = - let ans = intern_genarg ist (in_gen (rawwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map (raw l)) +and intern_genarg ist (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = intern_genarg ist (in_gen (rawwit wit) x) in + out_gen (glbwit wit) ans in - list_unpack { list_unpacker } x - | OptArgType _ -> - let opt_unpacker wit o = match raw o with + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with | None -> in_gen (glbwit (wit_opt wit)) None | Some x -> let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in in_gen (glbwit (wit_opt wit)) (Some s) in - opt_unpack { opt_unpacker } x - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = raw o in - let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in - let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - in - pair_unpack { pair_unpacker } x - | ExtraArgType s -> - snd (Genintern.generic_intern ist x) + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in + let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) (** Other entry points *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 71a6e043b5..8a16ed3899 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1524,38 +1524,34 @@ and interp_genarg ist x : Val.t Ftactic.t = interp_genarg_var_list ist x else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then interp_genarg_constr_list ist x - else match tag with - | ListArgType _ -> - let list_unpacker wit l = - let map x = - interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> - Ftactic.return (Value.cast (topwit wit) x) - in - Ftactic.List.map map (glb l) >>= fun l -> - Ftactic.return (Value.of_list (val_tag wit) l) + else + let GenArg (Glbwit wit, x) = x in + match wit with + | ListArg wit -> + let map x = + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Value.cast (topwit wit) x) in - list_unpack { list_unpacker } x - | OptArgType _ -> - let opt_unpacker wit o = match glb o with + Ftactic.List.map map x >>= fun l -> + Ftactic.return (Value.of_list (val_tag wit) l) + | OptArg wit -> + let ans = match x with | None -> Ftactic.return (Value.of_option (val_tag wit) None) | Some x -> interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> let x = Value.cast (topwit wit) x in Ftactic.return (Value.of_option (val_tag wit) (Some x)) in - opt_unpack { opt_unpacker } x - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let (p, q) = glb o in - interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> - interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> - let p = Value.cast (topwit wit1) p in - let q = Value.cast (topwit wit2) q in - Ftactic.return (Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q))) - in - pair_unpack { pair_unpacker } x - | ExtraArgType _ -> - Geninterp.generic_interp ist x + ans + | PairArg (wit1, wit2) -> + let (p, q) = x in + interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> + interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> + let p = Value.cast (topwit wit1) p in + let q = Value.cast (topwit wit2) q in + Ftactic.return (Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q))) + | ExtraArg s -> + Geninterp.generic_interp ist (Genarg.in_gen (glbwit wit) x) (** returns [true] for genargs which have the same meaning independently of goals. *) diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 4f79115240..c74f6093a2 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -274,35 +274,29 @@ and subst_match_rule subst = function ::(subst_match_rule subst tl) | [] -> [] -and subst_genarg subst (x:glob_generic_argument) = - match genarg_tag x with - | ListArgType _ -> - let list_unpacker wit l = - let map x = - let ans = subst_genarg subst (in_gen (glbwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map (glb l)) +and subst_genarg subst (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = subst_genarg subst (in_gen (glbwit wit) x) in + out_gen (glbwit wit) ans in - list_unpack { list_unpacker } x - | OptArgType _ -> - let opt_unpacker wit o = match glb o with + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with | None -> in_gen (glbwit (wit_opt wit)) None | Some x -> let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in in_gen (glbwit (wit_opt wit)) (Some s) in - opt_unpack { opt_unpacker } x - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = glb o in - let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in - let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - in - pair_unpack { pair_unpacker } x - | ExtraArgType s -> - Genintern.generic_substitute subst x + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in + let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + Genintern.generic_substitute subst (in_gen (glbwit wit) x) (** Registering *) -- cgit v1.2.3 From 820a282fde5cb4233116ce2cda927fda2f36097d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 17 Jan 2016 02:56:14 +0100 Subject: Moving val_cast to Tacinterp. --- lib/genarg.ml | 43 ------------------------------------------- lib/genarg.mli | 5 ----- tactics/tacinterp.ml | 45 ++++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 42 insertions(+), 51 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index 58d83ce7ae..37b31a511b 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -285,50 +285,7 @@ let rec val_tag : type a b c. (a, b, c) genarg_type -> c Val.tag = function | ExtraArg s -> match LoadMap.find s !arg0_map with LoadMap.Pack obj -> obj.dyn -exception CastError of argument_type * Val.t - -let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> None - | Some Refl -> Some x - -let try_prj wit v = match prj (val_tag wit) v with -| None -> raise (CastError (untype wit, v)) -| Some x -> x - -let rec val_cast : type a b c. (a, b, c) genarg_type -> Val.t -> c = -fun wit v -> match wit with -| ExtraArg _ -> try_prj wit v -| ListArg t -> - let Val.Dyn (tag, v) = v in - begin match tag with - | Val.List tag -> - let map x = val_cast t (Val.Dyn (tag, x)) in - List.map map v - | _ -> raise (CastError (untype wit, Val.Dyn (tag, v))) - end -| OptArg t -> - let Val.Dyn (tag, v) = v in - begin match tag with - | Val.Opt tag -> - let map x = val_cast t (Val.Dyn (tag, x)) in - Option.map map v - | _ -> raise (CastError (untype wit, Val.Dyn (tag, v))) - end -| PairArg (t1, t2) -> - let Val.Dyn (tag, v) = v in - begin match tag with - | Val.Pair (tag1, tag2) -> - let (v1, v2) = v in - let v1 = Val.Dyn (tag1, v1) in - let v2 = Val.Dyn (tag2, v2) in - (val_cast t1 v1, val_cast t2 v2) - | _ -> raise (CastError (untype wit, Val.Dyn (tag, v))) - end - let val_tag = function Topwit t -> val_tag t -let val_cast = function Topwit t -> val_cast t (** Registering genarg-manipulating functions *) diff --git a/lib/genarg.mli b/lib/genarg.mli index 8d1a439827..024c7a456e 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -185,8 +185,6 @@ val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag (** Retrieve the dynamic type associated to a toplevel genarg. Only works for ground generic arguments. *) -val val_cast : 'a typed_abstract_argument_type -> Val.t -> 'a - (** {6 Type reification} *) type argument_type = @@ -196,9 +194,6 @@ type argument_type = | PairArgType of argument_type * argument_type | ExtraArgType of string -exception CastError of argument_type * Val.t -(** Exception raised by {!val_cast} *) - (** {6 Equalities} *) val argument_type_eq : argument_type -> argument_type -> bool diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 8a16ed3899..8db91c07f6 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -149,10 +149,49 @@ module Value = struct let Val.Dyn (tag, _) = v in let tag = Val.repr tag in errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ tag - ++ str " while type " ++ Genarg.pr_argument_type wit ++ str " was expected.") + ++ str " while type " ++ Genarg.pr_argument_type (unquote (rawwit wit)) ++ str " was expected.") - let cast wit v = - try val_cast wit v with CastError (wit, v) -> cast_error wit v + let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + + let try_prj wit v = match prj (val_tag wit) v with + | None -> cast_error wit v + | Some x -> x + + let rec val_cast : type a b c. (a, b, c) genarg_type -> Val.t -> c = + fun wit v -> match wit with + | ExtraArg _ -> try_prj wit v + | ListArg t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.List tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + List.map map v + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + | OptArg t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Opt tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + Option.map map v + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + | PairArg (t1, t2) -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Pair (tag1, tag2) -> + let (v1, v2) = v in + let v1 = Val.Dyn (tag1, v1) in + let v2 = Val.Dyn (tag2, v2) in + (val_cast t1 v1, val_cast t2 v2) + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + + let cast (Topwit wit) v = val_cast wit v end -- cgit v1.2.3 From 9e585d7479af0db837528a2fe2ce1690e22a36cb Mon Sep 17 00:00:00 2001 From: Jacques-Henri Jourdan Date: Sat, 16 Jan 2016 21:49:35 -0500 Subject: Universes algorithm : clarified comments --- kernel/uGraph.ml | 28 ++++++++++++++++------------ kernel/univ.ml | 4 ++-- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 6765f91ee1..00883ddd84 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -17,8 +17,8 @@ open Univ (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) (* Support for universe polymorphism by MS [2014] *) -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, - Pierre-Marie Pédrot, Jacques-Henri Jourdan *) +(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu + Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) let error_inconsistency o u v (p:explanation option) = raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) @@ -41,7 +41,7 @@ let error_inconsistency o u v (p:explanation option) = new approach to incremental cycle detection and related problems. arXiv preprint arXiv:1112.0784. - *) + *) open Universe @@ -144,7 +144,7 @@ let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ exception AlreadyDeclared - + (* Reindexes the given universe, using the next available index. *) let use_index g u = let u = repr g u in @@ -274,7 +274,11 @@ exception CycleDetected Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. *) + problems. arXiv preprint arXiv:1112.0784. + + The "STEP X" comments contained in this file refers to the + corresponding step numbers of the algorithm described in Section + 5.1 of this paper. *) (* [delta] is the timeout for backward search. It might be useful to tune a multiplicative constant. *) @@ -381,7 +385,7 @@ let get_new_edges g to_merge = let reorder g u v = - (* STEP 1: backward search in the k-level of u. *) + (* STEP 2: backward search in the k-level of u. *) let delta = get_delta g in (* [v_klvl] is the chosen future level for u, v and all @@ -398,14 +402,14 @@ let reorder g u v = [], v_klvl, g in let f_traversed, g = - (* STEP 2: forward search. Contrary to what is described in + (* STEP 3: forward search. Contrary to what is described in the paper, we do not test whether v_klvl = u.klvl nor we assign v_klvl to v.klvl. Indeed, the first call to forward_traverse will do all that. *) forward_traverse [] g v_klvl (repr g v) v in - (* STEP 3: merge nodes if needed. *) + (* STEP 4: merge nodes if needed. *) let to_merge, b_reindex, f_reindex = if (repr g u).klvl = v_klvl then begin @@ -459,7 +463,7 @@ let reorder g u v = in - (* STEP 4: reindex traversed nodes. *) + (* STEP 5: reindex traversed nodes. *) List.fold_left use_index g to_reindex (* Assumes [u] and [v] are already in the graph. *) @@ -467,10 +471,10 @@ let reorder g u v = let insert_edge strict ucan vcan g = try let u = ucan.univ and v = vcan.univ in - (* do we need to reorder nodes ? *) + (* STEP 1: do we need to reorder nodes ? *) let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in - (* insert the new edge in the graph. *) + (* STEP 6: insert the new edge in the graph. *) let u = repr g u in let v = repr g v in if u == v then @@ -500,7 +504,7 @@ let add_universe vlev strict g = try let _arcv = UMap.find vlev g.entries in raise AlreadyDeclared - with Not_found -> + with Not_found -> assert (g.index > min_int); let v = { univ = vlev; diff --git a/kernel/univ.ml b/kernel/univ.ml index fab0e6fb8d..ebe3db0a3f 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -12,8 +12,8 @@ (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) (* Support for universe polymorphism by MS [2014] *) -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, - Pierre-Marie Pédrot *) +(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu + Sozeau, Pierre-Marie Pédrot *) open Pp open Errors -- cgit v1.2.3 From cbef33066dd526516c03474ffb35457047093808 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 19 Jan 2016 14:09:55 -0500 Subject: Fix bug #4420: check_types was losing universe constraints. --- tactics/tactics.ml | 13 ++++++++----- test-suite/bugs/closed/4420.v | 19 +++++++++++++++++++ 2 files changed, 27 insertions(+), 5 deletions(-) create mode 100644 test-suite/bugs/closed/4420.v diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 131730ebc0..b57fd70ee1 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -634,24 +634,27 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in if deep then begin let t2 = Retyping.get_type_of env sigma origc in - let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in - if not (snd (infer_conv ~pb:Reduction.CUMUL env sigma t1 t2)) then + let sigma, t2 = Evarsolve.refresh_universes + ~onlyalg:true (Some false) env sigma t2 in + let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in + if not b then if isSort (whd_betadeltaiota env sigma t1) && isSort (whd_betadeltaiota env sigma t2) - then - mayneedglobalcheck := true + then (mayneedglobalcheck := true; sigma) else errorlabstrm "convert-check-hyp" (str "Types are incompatible.") + else sigma end else if not (isSort (whd_betadeltaiota env sigma t1)) then errorlabstrm "convert-check-hyp" (str "Not a type.") + else sigma (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = let sigma, t' = t sigma in - check_types env sigma mayneedglobalcheck deep t' c; + let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); sigma, t' diff --git a/test-suite/bugs/closed/4420.v b/test-suite/bugs/closed/4420.v new file mode 100644 index 0000000000..0e16cb2399 --- /dev/null +++ b/test-suite/bugs/closed/4420.v @@ -0,0 +1,19 @@ +Module foo. + Context (Char : Type). + Axiom foo : Type -> Type. + Goal foo Char = foo Char. + change foo with (fun x => foo x). + cbv beta. + reflexivity. + Defined. +End foo. + +Inductive foo (A : Type) : Prop := I. (*Top.1*) +Lemma bar : foo Type. (*Top.3*) +Proof. + Set Printing Universes. +change foo with (fun x : Type => foo x). (*Top.4*) +cbv beta. +apply I. (* I Type@{Top.3} : (fun x : Type@{Top.4} => foo x) Type@{Top.3} *) +Defined. + -- cgit v1.2.3 From 13ef3c9a4161db85f10c9c5305e44b8ca66f2eaf Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 19 Jan 2016 16:52:04 +0100 Subject: Fixing Not_found on unknown bullet behavior. --- proofs/proof_global.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index c32e02344d..46f0db5fe1 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -623,7 +623,10 @@ module Bullet = struct (!current_behavior).name end; optwrite = begin fun n -> - current_behavior := Hashtbl.find behaviors n + current_behavior := + try Hashtbl.find behaviors n + with Not_found -> + Errors.error ("Unknown bullet behavior: \"" ^ n ^ "\".") end } -- cgit v1.2.3 From 281e4cb8b04c7fd13ec6416e4dcd05ffa1f48761 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 19 Jan 2016 16:56:11 +0100 Subject: Clarifying the documentation of tactics "cbv" and "lazy". Following a discussion on coq-club on Jan 13, 2016. --- doc/refman/RefMan-tac.tex | 40 +++++++++++++++++++++++++--------------- 1 file changed, 25 insertions(+), 15 deletions(-) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index b3a730e675..9a365b8297 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3047,23 +3047,33 @@ variables bound by a let-in construction inside the term itself (use here the {\tt zeta} flag). In any cases, opaque constants are not unfolded (see Section~\ref{Opaque}). -The goal may be normalized with two strategies: {\em lazy} ({\tt lazy} -tactic), or {\em call-by-value} ({\tt cbv} tactic). The lazy strategy -is a call-by-need strategy, with sharing of reductions: the arguments of a -function call are partially evaluated only when necessary, and if an -argument is used several times then it is computed only once. This -reduction is efficient for reducing expressions with dead code. For -instance, the proofs of a proposition {\tt exists~$x$. $P(x)$} reduce to a -pair of a witness $t$, and a proof that $t$ satisfies the predicate -$P$. Most of the time, $t$ may be computed without computing the proof -of $P(t)$, thanks to the lazy strategy. +Normalization according to the flags is done by first evaluating the +head of the expression into a {\em weak-head} normal form, i.e. until +the evaluation is bloked by a variable (or an opaque constant, or an +axiom), as e.g. in {\tt x\;u$_1$\;...\;u$_n$}, or {\tt match x with + ... end}, or {\tt (fix f x \{struct x\} := ...) x}, or is a +constructed form (a $\lambda$-expression, a constructor, a cofixpoint, +an inductive type, a product type, a sort), or is a redex that the +flags prevent to reduce. Once a weak-head normal form is obtained, +subterms are recursively reduced using the same strategy. + +Reduction to weak-head normal form can be done using two strategies: +{\em lazy} ({\tt lazy} tactic), or {\em call-by-value} ({\tt cbv} +tactic). The lazy strategy is a call-by-need strategy, with sharing of +reductions: the arguments of a function call are weakly evaluated only +when necessary, and if an argument is used several times then it is +weakly computed only once. This reduction is efficient for reducing +expressions with dead code. For instance, the proofs of a proposition +{\tt exists~$x$. $P(x)$} reduce to a pair of a witness $t$, and a +proof that $t$ satisfies the predicate $P$. Most of the time, $t$ may +be computed without computing the proof of $P(t)$, thanks to the lazy +strategy. The call-by-value strategy is the one used in ML languages: the -arguments of a function call are evaluated first, using a weak -reduction (no reduction under the $\lambda$-abstractions). Despite the -lazy strategy always performs fewer reductions than the call-by-value -strategy, the latter is generally more efficient for evaluating purely -computational expressions (i.e. with few dead code). +arguments of a function call are systematically weakly evaluated +first. Despite the lazy strategy always performs fewer reductions than +the call-by-value strategy, the latter is generally more efficient for +evaluating purely computational expressions (i.e. with few dead code). \begin{Variants} \item {\tt compute} \tacindex{compute}\\ -- cgit v1.2.3 From 1af878e0dac2198ae487d0b37438520772f28350 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 19 Jan 2016 17:07:32 +0100 Subject: Documenting Set Bullet Behavior. This is useful for restoring bullets after e.g. loading ssreflect. Hoping Arnaud is ok in documenting it. --- doc/refman/RefMan-pro.tex | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index ed1b79e56e..c37367de5b 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -407,6 +407,19 @@ Proof. \end{ErrMsgs} +The bullet behavior can be controlled by the following commands. + +\begin{quote} +Set Bullet Behavior "None". +\end{quote} + +This makes bullets inactive. + +\begin{quote} +Set Bullet Behavior "Strict Subproofs". +\end{quote} + +This makes bullets active (this is the default behavior). \section{Requesting information} -- cgit v1.2.3 From af5eafaee218935c35f0bd906727d2d2370bd136 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 20 Jan 2016 15:57:24 +0100 Subject: Change $(...)$ to ltac:(...) in section 2.11. Fixes #4500. --- doc/refman/RefMan-ext.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index f2ab79dced..51e881bff4 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -2014,7 +2014,7 @@ variables, use Instead of letting the unification engine try to solve an existential variable by itself, one can also provide an explicit hole together with a tactic to solve -it. Using the syntax {\tt \textdollar(\expr)\textdollar}, the user can put a +it. Using the syntax {\tt ltac:(\expr)}, the user can put a tactic anywhere a term is expected. The order of resolution is not specified and is implementation-dependent. The inner tactic may use any variable defined in its scope, including repeated alternations between variables introduced by term -- cgit v1.2.3 From 86f5c0cbfa64c5d0949365369529c5b607878ef8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 20 Jan 2016 17:25:10 +0100 Subject: Update copyright headers. --- checker/check.ml | 2 +- checker/check_stat.ml | 2 +- checker/check_stat.mli | 2 +- checker/checker.ml | 2 +- checker/cic.mli | 2 +- checker/closure.ml | 2 +- checker/closure.mli | 2 +- checker/indtypes.ml | 2 +- checker/indtypes.mli | 2 +- checker/inductive.ml | 2 +- checker/inductive.mli | 2 +- checker/mod_checking.mli | 2 +- checker/modops.ml | 2 +- checker/modops.mli | 2 +- checker/print.ml | 2 +- checker/reduction.ml | 2 +- checker/reduction.mli | 2 +- checker/safe_typing.ml | 2 +- checker/safe_typing.mli | 2 +- checker/subtyping.ml | 2 +- checker/subtyping.mli | 2 +- checker/term.ml | 2 +- checker/type_errors.ml | 2 +- checker/type_errors.mli | 2 +- checker/typeops.ml | 2 +- checker/typeops.mli | 2 +- checker/univ.ml | 2 +- checker/univ.mli | 2 +- checker/validate.ml | 2 +- checker/values.ml | 2 +- checker/votour.ml | 2 +- config/coq_config.mli | 2 +- dev/db_printers.ml | 2 +- dev/header | 2 +- dev/top_printers.ml | 2 +- doc/common/styles/html/coqremote/cover.html | 2 +- doc/common/styles/html/simple/cover.html | 2 +- doc/common/title.tex | 2 +- grammar/argextend.ml4 | 2 +- grammar/q_constr.ml4 | 2 +- grammar/q_coqast.ml4 | 2 +- grammar/q_util.ml4 | 2 +- grammar/q_util.mli | 2 +- grammar/tacextend.ml4 | 2 +- grammar/vernacextend.ml4 | 2 +- ide/MacOS/Info.plist.template | 2 +- ide/config_lexer.mll | 2 +- ide/coq.ml | 2 +- ide/coq.mli | 2 +- ide/coqOps.ml | 2 +- ide/coqOps.mli | 2 +- ide/coq_commands.ml | 2 +- ide/coq_lex.mll | 2 +- ide/coqide.ml | 2 +- ide/coqide.mli | 2 +- ide/coqide_main.ml4 | 2 +- ide/fileOps.ml | 2 +- ide/fileOps.mli | 2 +- ide/gtk_parsing.ml | 2 +- ide/ide_slave.ml | 2 +- ide/ideutils.ml | 2 +- ide/ideutils.mli | 2 +- ide/interface.mli | 2 +- ide/nanoPG.ml | 2 +- ide/preferences.ml | 2 +- ide/preferences.mli | 2 +- ide/sentence.ml | 2 +- ide/sentence.mli | 2 +- ide/session.ml | 2 +- ide/session.mli | 2 +- ide/tags.ml | 2 +- ide/tags.mli | 2 +- ide/utf8_convert.mll | 2 +- ide/wg_Command.ml | 2 +- ide/wg_Command.mli | 2 +- ide/wg_Completion.ml | 2 +- ide/wg_Completion.mli | 2 +- ide/wg_Detachable.ml | 2 +- ide/wg_Detachable.mli | 2 +- ide/wg_Find.ml | 2 +- ide/wg_Find.mli | 2 +- ide/wg_MessageView.ml | 2 +- ide/wg_MessageView.mli | 2 +- ide/wg_Notebook.ml | 2 +- ide/wg_Notebook.mli | 2 +- ide/wg_ProofView.ml | 2 +- ide/wg_ProofView.mli | 2 +- ide/wg_ScriptView.ml | 2 +- ide/wg_ScriptView.mli | 2 +- ide/wg_Segment.ml | 2 +- ide/wg_Segment.mli | 2 +- ide/xmlprotocol.ml | 2 +- ide/xmlprotocol.mli | 2 +- interp/constrarg.ml | 2 +- interp/constrarg.mli | 2 +- interp/constrexpr_ops.ml | 2 +- interp/constrexpr_ops.mli | 2 +- interp/constrextern.ml | 2 +- interp/constrextern.mli | 2 +- interp/constrintern.ml | 2 +- interp/constrintern.mli | 2 +- interp/coqlib.ml | 2 +- interp/coqlib.mli | 2 +- interp/dumpglob.ml | 2 +- interp/dumpglob.mli | 2 +- interp/genintern.ml | 2 +- interp/genintern.mli | 2 +- interp/implicit_quantifiers.ml | 2 +- interp/implicit_quantifiers.mli | 2 +- interp/modintern.ml | 2 +- interp/modintern.mli | 2 +- interp/notation.ml | 2 +- interp/notation.mli | 2 +- interp/notation_ops.ml | 2 +- interp/notation_ops.mli | 2 +- interp/ppextend.ml | 2 +- interp/ppextend.mli | 2 +- interp/reserve.ml | 2 +- interp/reserve.mli | 2 +- interp/smartlocate.ml | 2 +- interp/smartlocate.mli | 2 +- interp/stdarg.ml | 2 +- interp/stdarg.mli | 2 +- interp/syntax_def.ml | 2 +- interp/syntax_def.mli | 2 +- interp/topconstr.ml | 2 +- interp/topconstr.mli | 2 +- intf/constrexpr.mli | 2 +- intf/decl_kinds.mli | 2 +- intf/evar_kinds.mli | 2 +- intf/extend.mli | 2 +- intf/genredexpr.mli | 2 +- intf/glob_term.mli | 2 +- intf/locus.mli | 2 +- intf/misctypes.mli | 2 +- intf/notation_term.mli | 2 +- intf/pattern.mli | 2 +- intf/tacexpr.mli | 2 +- intf/vernacexpr.mli | 2 +- kernel/cbytecodes.ml | 2 +- kernel/cbytecodes.mli | 2 +- kernel/cbytegen.ml | 2 +- kernel/cemitcodes.ml | 2 +- kernel/closure.ml | 2 +- kernel/closure.mli | 2 +- kernel/constr.ml | 2 +- kernel/constr.mli | 2 +- kernel/context.ml | 2 +- kernel/context.mli | 2 +- kernel/conv_oracle.ml | 2 +- kernel/conv_oracle.mli | 2 +- kernel/cooking.ml | 2 +- kernel/cooking.mli | 2 +- kernel/csymtable.ml | 2 +- kernel/csymtable.mli | 2 +- kernel/declarations.mli | 2 +- kernel/declareops.ml | 2 +- kernel/declareops.mli | 2 +- kernel/entries.mli | 2 +- kernel/environ.ml | 2 +- kernel/environ.mli | 2 +- kernel/esubst.ml | 2 +- kernel/esubst.mli | 2 +- kernel/evar.ml | 2 +- kernel/evar.mli | 2 +- kernel/fast_typeops.ml | 2 +- kernel/fast_typeops.mli | 2 +- kernel/indtypes.ml | 2 +- kernel/indtypes.mli | 2 +- kernel/inductive.ml | 2 +- kernel/inductive.mli | 2 +- kernel/mod_subst.ml | 2 +- kernel/mod_subst.mli | 2 +- kernel/mod_typing.ml | 2 +- kernel/mod_typing.mli | 2 +- kernel/modops.ml | 2 +- kernel/modops.mli | 2 +- kernel/names.ml | 2 +- kernel/names.mli | 2 +- kernel/nativecode.ml | 2 +- kernel/nativecode.mli | 2 +- kernel/nativeconv.ml | 2 +- kernel/nativeconv.mli | 2 +- kernel/nativeinstr.mli | 2 +- kernel/nativelambda.ml | 2 +- kernel/nativelambda.mli | 2 +- kernel/nativelib.ml | 2 +- kernel/nativelib.mli | 2 +- kernel/nativelibrary.ml | 2 +- kernel/nativelibrary.mli | 2 +- kernel/nativevalues.ml | 2 +- kernel/nativevalues.mli | 2 +- kernel/opaqueproof.ml | 2 +- kernel/opaqueproof.mli | 2 +- kernel/pre_env.ml | 2 +- kernel/pre_env.mli | 2 +- kernel/primitives.ml | 2 +- kernel/primitives.mli | 2 +- kernel/reduction.ml | 2 +- kernel/reduction.mli | 2 +- kernel/retroknowledge.ml | 2 +- kernel/retroknowledge.mli | 2 +- kernel/safe_typing.ml | 2 +- kernel/safe_typing.mli | 2 +- kernel/sorts.ml | 2 +- kernel/sorts.mli | 2 +- kernel/subtyping.ml | 2 +- kernel/subtyping.mli | 2 +- kernel/term.ml | 2 +- kernel/term.mli | 2 +- kernel/term_typing.ml | 2 +- kernel/term_typing.mli | 2 +- kernel/type_errors.ml | 2 +- kernel/type_errors.mli | 2 +- kernel/typeops.ml | 2 +- kernel/typeops.mli | 2 +- kernel/univ.ml | 2 +- kernel/univ.mli | 2 +- kernel/vars.ml | 2 +- kernel/vars.mli | 2 +- kernel/vconv.mli | 2 +- kernel/vm.ml | 2 +- lib/aux_file.ml | 2 +- lib/aux_file.mli | 2 +- lib/bigint.ml | 2 +- lib/bigint.mli | 2 +- lib/cMap.ml | 2 +- lib/cMap.mli | 2 +- lib/cSet.ml | 2 +- lib/cSet.mli | 2 +- lib/cString.ml | 2 +- lib/cString.mli | 2 +- lib/cThread.ml | 2 +- lib/cThread.mli | 2 +- lib/cUnix.ml | 2 +- lib/cUnix.mli | 2 +- lib/canary.ml | 2 +- lib/canary.mli | 2 +- lib/control.ml | 2 +- lib/control.mli | 2 +- lib/deque.ml | 2 +- lib/deque.mli | 2 +- lib/dyn.ml | 2 +- lib/dyn.mli | 2 +- lib/envars.ml | 2 +- lib/envars.mli | 2 +- lib/ephemeron.ml | 2 +- lib/ephemeron.mli | 2 +- lib/explore.ml | 2 +- lib/explore.mli | 2 +- lib/feedback.ml | 2 +- lib/feedback.mli | 2 +- lib/flags.ml | 2 +- lib/flags.mli | 2 +- lib/future.ml | 2 +- lib/future.mli | 2 +- lib/genarg.ml | 2 +- lib/genarg.mli | 2 +- lib/hMap.ml | 2 +- lib/hMap.mli | 2 +- lib/hashcons.ml | 2 +- lib/hashcons.mli | 2 +- lib/hashset.ml | 2 +- lib/hashset.mli | 2 +- lib/heap.ml | 2 +- lib/heap.mli | 2 +- lib/hook.ml | 2 +- lib/hook.mli | 2 +- lib/iStream.ml | 2 +- lib/iStream.mli | 2 +- lib/int.ml | 2 +- lib/int.mli | 2 +- lib/loc.ml | 2 +- lib/loc.mli | 2 +- lib/option.ml | 2 +- lib/option.mli | 2 +- lib/pp.ml | 2 +- lib/pp.mli | 2 +- lib/pp_control.ml | 2 +- lib/pp_control.mli | 2 +- lib/ppstyle.ml | 2 +- lib/ppstyle.mli | 2 +- lib/profile.ml | 2 +- lib/profile.mli | 2 +- lib/remoteCounter.ml | 2 +- lib/remoteCounter.mli | 2 +- lib/richpp.ml | 2 +- lib/richpp.mli | 2 +- lib/rtree.ml | 2 +- lib/rtree.mli | 2 +- lib/serialize.ml | 2 +- lib/serialize.mli | 2 +- lib/spawn.ml | 2 +- lib/spawn.mli | 2 +- lib/system.ml | 2 +- lib/system.mli | 2 +- lib/terminal.ml | 2 +- lib/terminal.mli | 2 +- lib/trie.ml | 2 +- lib/trie.mli | 2 +- lib/unicode.mli | 2 +- lib/unionfind.ml | 2 +- lib/unionfind.mli | 2 +- lib/util.mli | 2 +- lib/xml_datatype.mli | 2 +- lib/xml_printer.ml | 2 +- lib/xml_printer.mli | 2 +- library/declare.ml | 2 +- library/declare.mli | 2 +- library/declaremods.ml | 2 +- library/declaremods.mli | 2 +- library/decls.ml | 2 +- library/decls.mli | 2 +- library/dischargedhypsmap.ml | 2 +- library/dischargedhypsmap.mli | 2 +- library/global.ml | 2 +- library/global.mli | 2 +- library/globnames.ml | 2 +- library/globnames.mli | 2 +- library/goptions.ml | 2 +- library/goptions.mli | 2 +- library/heads.ml | 2 +- library/heads.mli | 2 +- library/impargs.ml | 2 +- library/impargs.mli | 2 +- library/keys.ml | 2 +- library/keys.mli | 2 +- library/kindops.ml | 2 +- library/kindops.mli | 2 +- library/lib.ml | 2 +- library/lib.mli | 2 +- library/libnames.ml | 2 +- library/libnames.mli | 2 +- library/libobject.ml | 2 +- library/libobject.mli | 2 +- library/library.ml | 2 +- library/library.mli | 2 +- library/loadpath.ml | 2 +- library/loadpath.mli | 2 +- library/nameops.ml | 2 +- library/nameops.mli | 2 +- library/nametab.ml | 2 +- library/nametab.mli | 2 +- library/states.ml | 2 +- library/states.mli | 2 +- library/summary.ml | 2 +- library/summary.mli | 2 +- library/universes.ml | 2 +- library/universes.mli | 2 +- parsing/compat.ml4 | 2 +- parsing/egramcoq.ml | 2 +- parsing/egramcoq.mli | 2 +- parsing/egramml.ml | 2 +- parsing/egramml.mli | 2 +- parsing/g_constr.ml4 | 2 +- parsing/g_ltac.ml4 | 2 +- parsing/g_prim.ml4 | 2 +- parsing/g_proofs.ml4 | 2 +- parsing/g_tactic.ml4 | 2 +- parsing/g_vernac.ml4 | 2 +- parsing/lexer.ml4 | 2 +- parsing/lexer.mli | 2 +- parsing/pcoq.ml4 | 2 +- parsing/pcoq.mli | 2 +- parsing/tok.ml | 2 +- parsing/tok.mli | 2 +- plugins/btauto/g_btauto.ml4 | 2 +- plugins/cc/ccalgo.ml | 2 +- plugins/cc/ccalgo.mli | 2 +- plugins/cc/ccproof.ml | 2 +- plugins/cc/ccproof.mli | 2 +- plugins/cc/cctac.ml | 2 +- plugins/cc/g_congruence.ml4 | 2 +- plugins/decl_mode/decl_expr.mli | 2 +- plugins/decl_mode/decl_interp.ml | 2 +- plugins/decl_mode/decl_interp.mli | 2 +- plugins/decl_mode/decl_mode.ml | 2 +- plugins/decl_mode/decl_mode.mli | 2 +- plugins/decl_mode/decl_proof_instr.ml | 2 +- plugins/decl_mode/decl_proof_instr.mli | 2 +- plugins/decl_mode/g_decl_mode.ml4 | 2 +- plugins/decl_mode/ppdecl_proof.ml | 2 +- plugins/derive/derive.ml | 2 +- plugins/derive/derive.mli | 2 +- plugins/derive/g_derive.ml4 | 2 +- plugins/extraction/ExtrOcamlBasic.v | 2 +- plugins/extraction/ExtrOcamlBigIntConv.v | 2 +- plugins/extraction/ExtrOcamlIntConv.v | 2 +- plugins/extraction/ExtrOcamlNatBigInt.v | 2 +- plugins/extraction/ExtrOcamlNatInt.v | 2 +- plugins/extraction/ExtrOcamlString.v | 2 +- plugins/extraction/ExtrOcamlZBigInt.v | 2 +- plugins/extraction/ExtrOcamlZInt.v | 2 +- plugins/extraction/big.ml | 2 +- plugins/extraction/common.ml | 2 +- plugins/extraction/common.mli | 2 +- plugins/extraction/extract_env.ml | 2 +- plugins/extraction/extract_env.mli | 2 +- plugins/extraction/extraction.ml | 2 +- plugins/extraction/extraction.mli | 2 +- plugins/extraction/g_extraction.ml4 | 2 +- plugins/extraction/haskell.ml | 2 +- plugins/extraction/haskell.mli | 2 +- plugins/extraction/miniml.mli | 2 +- plugins/extraction/mlutil.ml | 2 +- plugins/extraction/mlutil.mli | 2 +- plugins/extraction/modutil.ml | 2 +- plugins/extraction/modutil.mli | 2 +- plugins/extraction/ocaml.ml | 2 +- plugins/extraction/ocaml.mli | 2 +- plugins/extraction/scheme.ml | 2 +- plugins/extraction/scheme.mli | 2 +- plugins/extraction/table.ml | 2 +- plugins/extraction/table.mli | 2 +- plugins/firstorder/formula.ml | 2 +- plugins/firstorder/formula.mli | 2 +- plugins/firstorder/g_ground.ml4 | 2 +- plugins/firstorder/ground.ml | 2 +- plugins/firstorder/ground.mli | 2 +- plugins/firstorder/instances.ml | 2 +- plugins/firstorder/instances.mli | 2 +- plugins/firstorder/rules.ml | 2 +- plugins/firstorder/rules.mli | 2 +- plugins/firstorder/sequent.ml | 2 +- plugins/firstorder/sequent.mli | 2 +- plugins/firstorder/unify.ml | 2 +- plugins/firstorder/unify.mli | 2 +- plugins/fourier/Fourier.v | 2 +- plugins/fourier/Fourier_util.v | 2 +- plugins/fourier/fourier.ml | 2 +- plugins/fourier/fourierR.ml | 2 +- plugins/fourier/g_fourier.ml4 | 2 +- plugins/funind/Recdef.v | 2 +- plugins/funind/functional_principles_types.mli | 2 +- plugins/funind/g_indfun.ml4 | 2 +- plugins/funind/invfun.ml | 2 +- plugins/funind/merge.ml | 2 +- plugins/funind/recdef.ml | 2 +- plugins/micromega/Env.v | 2 +- plugins/micromega/EnvRing.v | 2 +- plugins/micromega/Lia.v | 2 +- plugins/micromega/MExtraction.v | 2 +- plugins/micromega/OrderedRing.v | 2 +- plugins/micromega/Psatz.v | 2 +- plugins/micromega/QMicromega.v | 2 +- plugins/micromega/RMicromega.v | 2 +- plugins/micromega/Refl.v | 2 +- plugins/micromega/RingMicromega.v | 2 +- plugins/micromega/Tauto.v | 2 +- plugins/micromega/VarMap.v | 2 +- plugins/micromega/ZCoeff.v | 2 +- plugins/micromega/ZMicromega.v | 2 +- plugins/micromega/certificate.ml | 2 +- plugins/micromega/coq_micromega.ml | 2 +- plugins/micromega/csdpcert.ml | 2 +- plugins/micromega/g_micromega.ml4 | 2 +- plugins/micromega/mutils.ml | 2 +- plugins/micromega/persistent_cache.ml | 2 +- plugins/micromega/polynomial.ml | 2 +- plugins/micromega/sos.mli | 2 +- plugins/micromega/sos_types.ml | 2 +- plugins/nsatz/Nsatz.v | 2 +- plugins/nsatz/ideal.ml | 2 +- plugins/nsatz/nsatz.ml4 | 2 +- plugins/nsatz/polynom.ml | 2 +- plugins/nsatz/polynom.mli | 2 +- plugins/omega/Omega.v | 2 +- plugins/omega/OmegaPlugin.v | 2 +- plugins/omega/OmegaTactic.v | 2 +- plugins/omega/PreOmega.v | 2 +- plugins/omega/coq_omega.ml | 2 +- plugins/omega/g_omega.ml4 | 2 +- plugins/omega/omega.ml | 2 +- plugins/quote/Quote.v | 2 +- plugins/quote/g_quote.ml4 | 2 +- plugins/quote/quote.ml | 2 +- plugins/rtauto/Bintree.v | 2 +- plugins/rtauto/Rtauto.v | 2 +- plugins/rtauto/g_rtauto.ml4 | 2 +- plugins/rtauto/proof_search.ml | 2 +- plugins/rtauto/proof_search.mli | 2 +- plugins/rtauto/refl_tauto.ml | 2 +- plugins/rtauto/refl_tauto.mli | 2 +- plugins/setoid_ring/ArithRing.v | 2 +- plugins/setoid_ring/BinList.v | 2 +- plugins/setoid_ring/Cring.v | 2 +- plugins/setoid_ring/Field.v | 2 +- plugins/setoid_ring/Field_tac.v | 2 +- plugins/setoid_ring/Field_theory.v | 2 +- plugins/setoid_ring/InitialRing.v | 2 +- plugins/setoid_ring/NArithRing.v | 2 +- plugins/setoid_ring/Ncring.v | 2 +- plugins/setoid_ring/Ncring_initial.v | 2 +- plugins/setoid_ring/Ncring_polynom.v | 2 +- plugins/setoid_ring/Ncring_tac.v | 2 +- plugins/setoid_ring/Ring.v | 2 +- plugins/setoid_ring/Ring_base.v | 2 +- plugins/setoid_ring/Ring_polynom.v | 2 +- plugins/setoid_ring/Ring_theory.v | 2 +- plugins/setoid_ring/ZArithRing.v | 2 +- plugins/setoid_ring/newring.ml4 | 2 +- plugins/syntax/nat_syntax.ml | 2 +- plugins/syntax/numbers_syntax.ml | 2 +- plugins/syntax/r_syntax.ml | 2 +- plugins/syntax/z_syntax.ml | 2 +- pretyping/arguments_renaming.ml | 2 +- pretyping/arguments_renaming.mli | 2 +- pretyping/cases.ml | 2 +- pretyping/cases.mli | 2 +- pretyping/cbv.ml | 2 +- pretyping/cbv.mli | 2 +- pretyping/classops.ml | 2 +- pretyping/classops.mli | 2 +- pretyping/coercion.ml | 2 +- pretyping/coercion.mli | 2 +- pretyping/constr_matching.ml | 2 +- pretyping/constr_matching.mli | 2 +- pretyping/detyping.ml | 2 +- pretyping/detyping.mli | 2 +- pretyping/evarconv.ml | 2 +- pretyping/evarconv.mli | 2 +- pretyping/evarsolve.ml | 2 +- pretyping/evarsolve.mli | 2 +- pretyping/evarutil.ml | 2 +- pretyping/evarutil.mli | 2 +- pretyping/evd.ml | 2 +- pretyping/evd.mli | 2 +- pretyping/find_subterm.ml | 2 +- pretyping/find_subterm.mli | 2 +- pretyping/glob_ops.ml | 2 +- pretyping/glob_ops.mli | 2 +- pretyping/indrec.ml | 2 +- pretyping/indrec.mli | 2 +- pretyping/inductiveops.ml | 2 +- pretyping/inductiveops.mli | 2 +- pretyping/locusops.ml | 2 +- pretyping/locusops.mli | 2 +- pretyping/miscops.ml | 2 +- pretyping/miscops.mli | 2 +- pretyping/namegen.ml | 2 +- pretyping/namegen.mli | 2 +- pretyping/nativenorm.ml | 2 +- pretyping/nativenorm.mli | 2 +- pretyping/patternops.ml | 2 +- pretyping/patternops.mli | 2 +- pretyping/pretype_errors.ml | 2 +- pretyping/pretype_errors.mli | 2 +- pretyping/pretyping.ml | 2 +- pretyping/pretyping.mli | 2 +- pretyping/program.ml | 2 +- pretyping/program.mli | 2 +- pretyping/recordops.ml | 2 +- pretyping/recordops.mli | 2 +- pretyping/redops.ml | 2 +- pretyping/redops.mli | 2 +- pretyping/reductionops.ml | 2 +- pretyping/reductionops.mli | 2 +- pretyping/retyping.ml | 2 +- pretyping/retyping.mli | 2 +- pretyping/tacred.ml | 2 +- pretyping/tacred.mli | 2 +- pretyping/termops.ml | 2 +- pretyping/termops.mli | 2 +- pretyping/typeclasses.ml | 2 +- pretyping/typeclasses.mli | 2 +- pretyping/typeclasses_errors.ml | 2 +- pretyping/typeclasses_errors.mli | 2 +- pretyping/typing.ml | 2 +- pretyping/typing.mli | 2 +- pretyping/unification.ml | 2 +- pretyping/unification.mli | 2 +- pretyping/vnorm.ml | 2 +- pretyping/vnorm.mli | 2 +- printing/genprint.ml | 2 +- printing/genprint.mli | 2 +- printing/miscprint.ml | 2 +- printing/miscprint.mli | 2 +- printing/ppannotation.ml | 2 +- printing/ppannotation.mli | 2 +- printing/ppconstr.ml | 2 +- printing/ppconstr.mli | 2 +- printing/ppconstrsig.mli | 2 +- printing/pptactic.ml | 2 +- printing/pptactic.mli | 2 +- printing/pptacticsig.mli | 2 +- printing/pputils.ml | 2 +- printing/pputils.mli | 2 +- printing/ppvernac.ml | 2 +- printing/ppvernac.mli | 2 +- printing/ppvernacsig.mli | 2 +- printing/prettyp.ml | 2 +- printing/prettyp.mli | 2 +- printing/printer.ml | 2 +- printing/printer.mli | 2 +- printing/printmod.ml | 2 +- printing/printmod.mli | 2 +- printing/printmodsig.mli | 2 +- printing/richprinter.mli | 2 +- proofs/clenv.ml | 2 +- proofs/clenv.mli | 2 +- proofs/clenvtac.ml | 2 +- proofs/clenvtac.mli | 2 +- proofs/evar_refiner.ml | 2 +- proofs/evar_refiner.mli | 2 +- proofs/goal.ml | 2 +- proofs/goal.mli | 2 +- proofs/logic.ml | 2 +- proofs/logic.mli | 2 +- proofs/logic_monad.ml | 2 +- proofs/logic_monad.mli | 2 +- proofs/pfedit.ml | 2 +- proofs/pfedit.mli | 2 +- proofs/proof.ml | 2 +- proofs/proof.mli | 2 +- proofs/proof_global.ml | 2 +- proofs/proof_global.mli | 2 +- proofs/proof_type.ml | 2 +- proofs/proof_type.mli | 2 +- proofs/proof_using.ml | 2 +- proofs/proof_using.mli | 2 +- proofs/proofview.ml | 2 +- proofs/proofview.mli | 2 +- proofs/proofview_monad.ml | 2 +- proofs/proofview_monad.mli | 2 +- proofs/redexpr.ml | 2 +- proofs/redexpr.mli | 2 +- proofs/refiner.ml | 2 +- proofs/refiner.mli | 2 +- proofs/tacmach.ml | 2 +- proofs/tacmach.mli | 2 +- proofs/tactic_debug.ml | 2 +- proofs/tactic_debug.mli | 2 +- stm/asyncTaskQueue.ml | 2 +- stm/asyncTaskQueue.mli | 2 +- stm/coqworkmgrApi.ml | 2 +- stm/coqworkmgrApi.mli | 2 +- stm/dag.ml | 2 +- stm/dag.mli | 2 +- stm/lemmas.ml | 2 +- stm/lemmas.mli | 2 +- stm/proofworkertop.ml | 2 +- stm/queryworkertop.ml | 2 +- stm/spawned.ml | 2 +- stm/spawned.mli | 2 +- stm/stm.ml | 2 +- stm/tQueue.ml | 2 +- stm/tQueue.mli | 2 +- stm/tacworkertop.ml | 2 +- stm/texmacspp.ml | 2 +- stm/texmacspp.mli | 2 +- stm/vcs.ml | 2 +- stm/vcs.mli | 2 +- stm/vernac_classifier.ml | 2 +- stm/vernac_classifier.mli | 2 +- stm/vio_checking.ml | 2 +- stm/vio_checking.mli | 2 +- stm/workerPool.ml | 2 +- stm/workerPool.mli | 2 +- tactics/auto.ml | 2 +- tactics/auto.mli | 2 +- tactics/autorewrite.ml | 2 +- tactics/autorewrite.mli | 2 +- tactics/btermdn.ml | 2 +- tactics/btermdn.mli | 2 +- tactics/class_tactics.ml | 2 +- tactics/class_tactics.mli | 2 +- tactics/contradiction.ml | 2 +- tactics/contradiction.mli | 2 +- tactics/coretactics.ml4 | 2 +- tactics/dnet.ml | 2 +- tactics/dnet.mli | 2 +- tactics/eauto.ml4 | 2 +- tactics/eauto.mli | 2 +- tactics/elim.ml | 2 +- tactics/elim.mli | 2 +- tactics/elimschemes.ml | 2 +- tactics/elimschemes.mli | 2 +- tactics/eqdecide.ml | 2 +- tactics/eqdecide.mli | 2 +- tactics/eqschemes.ml | 2 +- tactics/eqschemes.mli | 2 +- tactics/equality.ml | 2 +- tactics/equality.mli | 2 +- tactics/evar_tactics.ml | 2 +- tactics/evar_tactics.mli | 2 +- tactics/extraargs.ml4 | 2 +- tactics/extraargs.mli | 2 +- tactics/extratactics.ml4 | 2 +- tactics/extratactics.mli | 2 +- tactics/ftactic.ml | 2 +- tactics/ftactic.mli | 2 +- tactics/g_class.ml4 | 2 +- tactics/g_eqdecide.ml4 | 2 +- tactics/g_rewrite.ml4 | 2 +- tactics/geninterp.ml | 2 +- tactics/geninterp.mli | 2 +- tactics/hints.ml | 2 +- tactics/hints.mli | 2 +- tactics/hipattern.ml4 | 2 +- tactics/hipattern.mli | 2 +- tactics/inv.ml | 2 +- tactics/inv.mli | 2 +- tactics/leminv.ml | 2 +- tactics/leminv.mli | 2 +- tactics/rewrite.ml | 2 +- tactics/rewrite.mli | 2 +- tactics/taccoerce.ml | 2 +- tactics/taccoerce.mli | 2 +- tactics/tacenv.ml | 2 +- tactics/tacenv.mli | 2 +- tactics/tacintern.ml | 2 +- tactics/tacintern.mli | 2 +- tactics/tacinterp.ml | 2 +- tactics/tacinterp.mli | 2 +- tactics/tacsubst.ml | 2 +- tactics/tacsubst.mli | 2 +- tactics/tactic_matching.ml | 2 +- tactics/tactic_option.ml | 2 +- tactics/tactic_option.mli | 2 +- tactics/tacticals.ml | 2 +- tactics/tacticals.mli | 2 +- tactics/tactics.ml | 2 +- tactics/tactics.mli | 2 +- tactics/tauto.ml4 | 2 +- tactics/term_dnet.ml | 2 +- tactics/term_dnet.mli | 2 +- test-suite/bench/lists-100.v | 2 +- test-suite/bench/lists_100.v | 2 +- test-suite/failure/Tauto.v | 2 +- test-suite/failure/clash_cons.v | 2 +- test-suite/failure/fixpoint1.v | 2 +- test-suite/failure/guard.v | 2 +- test-suite/failure/illtype1.v | 2 +- test-suite/failure/positivity.v | 2 +- test-suite/failure/redef.v | 2 +- test-suite/failure/search.v | 2 +- test-suite/ideal-features/Apply.v | 2 +- test-suite/misc/berardi_test.v | 2 +- test-suite/success/Check.v | 2 +- test-suite/success/Field.v | 2 +- test-suite/success/Tauto.v | 2 +- test-suite/success/TestRefine.v | 2 +- test-suite/success/eauto.v | 2 +- test-suite/success/eqdecide.v | 2 +- test-suite/success/extraction.v | 2 +- test-suite/success/inds_type_sec.v | 2 +- test-suite/success/induct.v | 2 +- test-suite/success/mutual_ind.v | 2 +- test-suite/success/unfold.v | 2 +- test-suite/typeclasses/NewSetoid.v | 2 +- theories/Arith/Arith.v | 2 +- theories/Arith/Arith_base.v | 2 +- theories/Arith/Between.v | 2 +- theories/Arith/Bool_nat.v | 2 +- theories/Arith/Compare.v | 2 +- theories/Arith/Compare_dec.v | 2 +- theories/Arith/Div2.v | 2 +- theories/Arith/EqNat.v | 2 +- theories/Arith/Euclid.v | 2 +- theories/Arith/Even.v | 2 +- theories/Arith/Factorial.v | 2 +- theories/Arith/Gt.v | 2 +- theories/Arith/Le.v | 2 +- theories/Arith/Lt.v | 2 +- theories/Arith/Max.v | 2 +- theories/Arith/Min.v | 2 +- theories/Arith/Minus.v | 2 +- theories/Arith/Mult.v | 2 +- theories/Arith/PeanoNat.v | 2 +- theories/Arith/Peano_dec.v | 2 +- theories/Arith/Wf_nat.v | 2 +- theories/Bool/Bool.v | 2 +- theories/Bool/BoolEq.v | 2 +- theories/Bool/Bvector.v | 2 +- theories/Bool/DecBool.v | 2 +- theories/Bool/IfProp.v | 2 +- theories/Bool/Sumbool.v | 2 +- theories/Bool/Zerob.v | 2 +- theories/Classes/CEquivalence.v | 2 +- theories/Classes/CMorphisms.v | 2 +- theories/Classes/CRelationClasses.v | 2 +- theories/Classes/DecidableClass.v | 2 +- theories/Classes/EquivDec.v | 2 +- theories/Classes/Equivalence.v | 2 +- theories/Classes/Init.v | 2 +- theories/Classes/Morphisms.v | 2 +- theories/Classes/Morphisms_Prop.v | 2 +- theories/Classes/Morphisms_Relations.v | 2 +- theories/Classes/RelationClasses.v | 2 +- theories/Classes/SetoidClass.v | 2 +- theories/Classes/SetoidDec.v | 2 +- theories/Classes/SetoidTactics.v | 2 +- theories/Compat/AdmitAxiom.v | 2 +- theories/Compat/Coq84.v | 2 +- theories/Compat/Coq85.v | 2 +- theories/Init/Datatypes.v | 2 +- theories/Init/Logic.v | 2 +- theories/Init/Logic_Type.v | 2 +- theories/Init/Nat.v | 2 +- theories/Init/Notations.v | 2 +- theories/Init/Peano.v | 2 +- theories/Init/Prelude.v | 2 +- theories/Init/Specif.v | 2 +- theories/Init/Tactics.v | 2 +- theories/Init/Wf.v | 2 +- theories/Lists/List.v | 2 +- theories/Lists/ListDec.v | 2 +- theories/Lists/ListSet.v | 2 +- theories/Lists/ListTactics.v | 2 +- theories/Lists/StreamMemo.v | 2 +- theories/Lists/Streams.v | 2 +- theories/Logic/Berardi.v | 2 +- theories/Logic/ChoiceFacts.v | 2 +- theories/Logic/Classical.v | 2 +- theories/Logic/ClassicalChoice.v | 2 +- theories/Logic/ClassicalDescription.v | 2 +- theories/Logic/ClassicalEpsilon.v | 2 +- theories/Logic/ClassicalFacts.v | 2 +- theories/Logic/ClassicalUniqueChoice.v | 2 +- theories/Logic/Classical_Pred_Type.v | 2 +- theories/Logic/Classical_Prop.v | 2 +- theories/Logic/ConstructiveEpsilon.v | 2 +- theories/Logic/Decidable.v | 2 +- theories/Logic/Description.v | 2 +- theories/Logic/Diaconescu.v | 2 +- theories/Logic/Epsilon.v | 2 +- theories/Logic/Eqdep.v | 2 +- theories/Logic/EqdepFacts.v | 2 +- theories/Logic/Eqdep_dec.v | 2 +- theories/Logic/ExtensionalityFacts.v | 2 +- theories/Logic/FinFun.v | 2 +- theories/Logic/FunctionalExtensionality.v | 2 +- theories/Logic/Hurkens.v | 2 +- theories/Logic/IndefiniteDescription.v | 2 +- theories/Logic/JMeq.v | 2 +- theories/Logic/ProofIrrelevance.v | 2 +- theories/Logic/ProofIrrelevanceFacts.v | 2 +- theories/Logic/RelationalChoice.v | 2 +- theories/Logic/SetIsType.v | 2 +- theories/Logic/WKL.v | 2 +- theories/Logic/WeakFan.v | 2 +- theories/NArith/BinNat.v | 2 +- theories/NArith/BinNatDef.v | 2 +- theories/NArith/NArith.v | 2 +- theories/NArith/Ndec.v | 2 +- theories/NArith/Ndigits.v | 2 +- theories/NArith/Ndist.v | 2 +- theories/NArith/Ndiv_def.v | 2 +- theories/NArith/Ngcd_def.v | 2 +- theories/NArith/Nnat.v | 2 +- theories/NArith/Nsqrt_def.v | 2 +- theories/Numbers/BigNumPrelude.v | 2 +- theories/Numbers/BinNums.v | 2 +- theories/Numbers/Cyclic/Abstract/CyclicAxioms.v | 2 +- theories/Numbers/Cyclic/Abstract/NZCyclic.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v | 2 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v | 2 +- theories/Numbers/Cyclic/Int31/Cyclic31.v | 2 +- theories/Numbers/Cyclic/Int31/Int31.v | 2 +- theories/Numbers/Cyclic/Int31/Ring31.v | 2 +- theories/Numbers/Cyclic/ZModulo/ZModulo.v | 2 +- theories/Numbers/Integer/Abstract/ZAdd.v | 2 +- theories/Numbers/Integer/Abstract/ZAddOrder.v | 2 +- theories/Numbers/Integer/Abstract/ZAxioms.v | 2 +- theories/Numbers/Integer/Abstract/ZBase.v | 2 +- theories/Numbers/Integer/Abstract/ZBits.v | 2 +- theories/Numbers/Integer/Abstract/ZDivEucl.v | 2 +- theories/Numbers/Integer/Abstract/ZDivFloor.v | 2 +- theories/Numbers/Integer/Abstract/ZDivTrunc.v | 2 +- theories/Numbers/Integer/Abstract/ZGcd.v | 2 +- theories/Numbers/Integer/Abstract/ZLcm.v | 2 +- theories/Numbers/Integer/Abstract/ZLt.v | 2 +- theories/Numbers/Integer/Abstract/ZMaxMin.v | 2 +- theories/Numbers/Integer/Abstract/ZMul.v | 2 +- theories/Numbers/Integer/Abstract/ZMulOrder.v | 2 +- theories/Numbers/Integer/Abstract/ZParity.v | 2 +- theories/Numbers/Integer/Abstract/ZPow.v | 2 +- theories/Numbers/Integer/Abstract/ZProperties.v | 2 +- theories/Numbers/Integer/Abstract/ZSgnAbs.v | 2 +- theories/Numbers/Integer/BigZ/BigZ.v | 2 +- theories/Numbers/Integer/BigZ/ZMake.v | 2 +- theories/Numbers/Integer/Binary/ZBinary.v | 2 +- theories/Numbers/Integer/NatPairs/ZNatPairs.v | 2 +- theories/Numbers/Integer/SpecViaZ/ZSig.v | 2 +- theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v | 2 +- theories/Numbers/NaryFunctions.v | 2 +- theories/Numbers/NatInt/NZAdd.v | 2 +- theories/Numbers/NatInt/NZAddOrder.v | 2 +- theories/Numbers/NatInt/NZAxioms.v | 2 +- theories/Numbers/NatInt/NZBase.v | 2 +- theories/Numbers/NatInt/NZBits.v | 2 +- theories/Numbers/NatInt/NZDiv.v | 2 +- theories/Numbers/NatInt/NZDomain.v | 2 +- theories/Numbers/NatInt/NZGcd.v | 2 +- theories/Numbers/NatInt/NZLog.v | 2 +- theories/Numbers/NatInt/NZMul.v | 2 +- theories/Numbers/NatInt/NZMulOrder.v | 2 +- theories/Numbers/NatInt/NZOrder.v | 2 +- theories/Numbers/NatInt/NZParity.v | 2 +- theories/Numbers/NatInt/NZPow.v | 2 +- theories/Numbers/NatInt/NZProperties.v | 2 +- theories/Numbers/NatInt/NZSqrt.v | 2 +- theories/Numbers/Natural/Abstract/NAdd.v | 2 +- theories/Numbers/Natural/Abstract/NAddOrder.v | 2 +- theories/Numbers/Natural/Abstract/NAxioms.v | 2 +- theories/Numbers/Natural/Abstract/NBase.v | 2 +- theories/Numbers/Natural/Abstract/NBits.v | 2 +- theories/Numbers/Natural/Abstract/NDefOps.v | 2 +- theories/Numbers/Natural/Abstract/NDiv.v | 2 +- theories/Numbers/Natural/Abstract/NGcd.v | 2 +- theories/Numbers/Natural/Abstract/NIso.v | 2 +- theories/Numbers/Natural/Abstract/NLcm.v | 2 +- theories/Numbers/Natural/Abstract/NLog.v | 2 +- theories/Numbers/Natural/Abstract/NMaxMin.v | 2 +- theories/Numbers/Natural/Abstract/NMulOrder.v | 2 +- theories/Numbers/Natural/Abstract/NOrder.v | 2 +- theories/Numbers/Natural/Abstract/NParity.v | 2 +- theories/Numbers/Natural/Abstract/NPow.v | 2 +- theories/Numbers/Natural/Abstract/NProperties.v | 2 +- theories/Numbers/Natural/Abstract/NSqrt.v | 2 +- theories/Numbers/Natural/Abstract/NStrongRec.v | 2 +- theories/Numbers/Natural/Abstract/NSub.v | 2 +- theories/Numbers/Natural/BigN/BigN.v | 2 +- theories/Numbers/Natural/BigN/NMake.v | 2 +- theories/Numbers/Natural/BigN/NMake_gen.ml | 2 +- theories/Numbers/Natural/BigN/Nbasic.v | 2 +- theories/Numbers/Natural/Binary/NBinary.v | 2 +- theories/Numbers/Natural/Peano/NPeano.v | 2 +- theories/Numbers/Natural/SpecViaZ/NSig.v | 2 +- theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v | 2 +- theories/Numbers/NumPrelude.v | 2 +- theories/Numbers/Rational/BigQ/BigQ.v | 2 +- theories/Numbers/Rational/BigQ/QMake.v | 2 +- theories/Numbers/Rational/SpecViaQ/QSig.v | 2 +- theories/PArith/BinPos.v | 2 +- theories/PArith/BinPosDef.v | 2 +- theories/PArith/PArith.v | 2 +- theories/PArith/POrderedType.v | 2 +- theories/PArith/Pnat.v | 2 +- theories/Program/Basics.v | 2 +- theories/Program/Combinators.v | 2 +- theories/Program/Equality.v | 2 +- theories/Program/Program.v | 2 +- theories/Program/Subset.v | 2 +- theories/Program/Syntax.v | 2 +- theories/Program/Tactics.v | 2 +- theories/Program/Utils.v | 2 +- theories/Program/Wf.v | 2 +- theories/QArith/QArith.v | 2 +- theories/QArith/QArith_base.v | 2 +- theories/QArith/QOrderedType.v | 2 +- theories/QArith/Qabs.v | 2 +- theories/QArith/Qcanon.v | 2 +- theories/QArith/Qfield.v | 2 +- theories/QArith/Qminmax.v | 2 +- theories/QArith/Qpower.v | 2 +- theories/QArith/Qreals.v | 2 +- theories/QArith/Qreduction.v | 2 +- theories/QArith/Qring.v | 2 +- theories/QArith/Qround.v | 2 +- theories/Reals/Alembert.v | 2 +- theories/Reals/AltSeries.v | 2 +- theories/Reals/ArithProp.v | 2 +- theories/Reals/Binomial.v | 2 +- theories/Reals/Cauchy_prod.v | 2 +- theories/Reals/Cos_plus.v | 2 +- theories/Reals/Cos_rel.v | 2 +- theories/Reals/DiscrR.v | 2 +- theories/Reals/Exp_prop.v | 2 +- theories/Reals/Integration.v | 2 +- theories/Reals/MVT.v | 2 +- theories/Reals/Machin.v | 2 +- theories/Reals/NewtonInt.v | 2 +- theories/Reals/PSeries_reg.v | 2 +- theories/Reals/PartSum.v | 2 +- theories/Reals/RIneq.v | 2 +- theories/Reals/RList.v | 2 +- theories/Reals/ROrderedType.v | 2 +- theories/Reals/R_Ifp.v | 2 +- theories/Reals/R_sqr.v | 2 +- theories/Reals/R_sqrt.v | 2 +- theories/Reals/Ranalysis.v | 2 +- theories/Reals/Ranalysis1.v | 2 +- theories/Reals/Ranalysis2.v | 2 +- theories/Reals/Ranalysis3.v | 2 +- theories/Reals/Ranalysis4.v | 2 +- theories/Reals/Ranalysis5.v | 2 +- theories/Reals/Ranalysis_reg.v | 2 +- theories/Reals/Ratan.v | 2 +- theories/Reals/Raxioms.v | 2 +- theories/Reals/Rbase.v | 2 +- theories/Reals/Rbasic_fun.v | 2 +- theories/Reals/Rcomplete.v | 2 +- theories/Reals/Rdefinitions.v | 2 +- theories/Reals/Rderiv.v | 2 +- theories/Reals/Reals.v | 2 +- theories/Reals/Rfunctions.v | 2 +- theories/Reals/Rgeom.v | 2 +- theories/Reals/RiemannInt.v | 2 +- theories/Reals/RiemannInt_SF.v | 2 +- theories/Reals/Rlimit.v | 2 +- theories/Reals/Rlogic.v | 2 +- theories/Reals/Rminmax.v | 2 +- theories/Reals/Rpow_def.v | 2 +- theories/Reals/Rpower.v | 2 +- theories/Reals/Rprod.v | 2 +- theories/Reals/Rseries.v | 2 +- theories/Reals/Rsigma.v | 2 +- theories/Reals/Rsqrt_def.v | 2 +- theories/Reals/Rtopology.v | 2 +- theories/Reals/Rtrigo.v | 2 +- theories/Reals/Rtrigo1.v | 2 +- theories/Reals/Rtrigo_alt.v | 2 +- theories/Reals/Rtrigo_calc.v | 2 +- theories/Reals/Rtrigo_def.v | 2 +- theories/Reals/Rtrigo_fun.v | 2 +- theories/Reals/Rtrigo_reg.v | 2 +- theories/Reals/SeqProp.v | 2 +- theories/Reals/SeqSeries.v | 2 +- theories/Reals/SplitAbsolu.v | 2 +- theories/Reals/SplitRmult.v | 2 +- theories/Reals/Sqrt_reg.v | 2 +- theories/Relations/Operators_Properties.v | 2 +- theories/Relations/Relation_Definitions.v | 2 +- theories/Relations/Relation_Operators.v | 2 +- theories/Relations/Relations.v | 2 +- theories/Setoids/Setoid.v | 2 +- theories/Sets/Classical_sets.v | 2 +- theories/Sets/Constructive_sets.v | 2 +- theories/Sets/Cpo.v | 2 +- theories/Sets/Ensembles.v | 2 +- theories/Sets/Finite_sets.v | 2 +- theories/Sets/Finite_sets_facts.v | 2 +- theories/Sets/Image.v | 2 +- theories/Sets/Infinite_sets.v | 2 +- theories/Sets/Integers.v | 2 +- theories/Sets/Multiset.v | 2 +- theories/Sets/Partial_Order.v | 2 +- theories/Sets/Permut.v | 2 +- theories/Sets/Powerset.v | 2 +- theories/Sets/Powerset_Classical_facts.v | 2 +- theories/Sets/Powerset_facts.v | 2 +- theories/Sets/Relations_1.v | 2 +- theories/Sets/Relations_1_facts.v | 2 +- theories/Sets/Relations_2.v | 2 +- theories/Sets/Relations_2_facts.v | 2 +- theories/Sets/Relations_3.v | 2 +- theories/Sets/Relations_3_facts.v | 2 +- theories/Sets/Uniset.v | 2 +- theories/Sorting/Heap.v | 2 +- theories/Sorting/Mergesort.v | 2 +- theories/Sorting/PermutEq.v | 2 +- theories/Sorting/PermutSetoid.v | 2 +- theories/Sorting/Permutation.v | 2 +- theories/Sorting/Sorted.v | 2 +- theories/Sorting/Sorting.v | 2 +- theories/Strings/Ascii.v | 2 +- theories/Strings/String.v | 2 +- theories/Unicode/Utf8.v | 2 +- theories/Unicode/Utf8_core.v | 2 +- theories/Wellfounded/Disjoint_Union.v | 2 +- theories/Wellfounded/Inclusion.v | 2 +- theories/Wellfounded/Inverse_Image.v | 2 +- theories/Wellfounded/Lexicographic_Exponentiation.v | 2 +- theories/Wellfounded/Lexicographic_Product.v | 2 +- theories/Wellfounded/Transitive_Closure.v | 2 +- theories/Wellfounded/Union.v | 2 +- theories/Wellfounded/Well_Ordering.v | 2 +- theories/Wellfounded/Wellfounded.v | 2 +- theories/ZArith/BinInt.v | 2 +- theories/ZArith/BinIntDef.v | 2 +- theories/ZArith/Wf_Z.v | 2 +- theories/ZArith/ZArith.v | 2 +- theories/ZArith/ZArith_base.v | 2 +- theories/ZArith/ZArith_dec.v | 2 +- theories/ZArith/Zabs.v | 2 +- theories/ZArith/Zbool.v | 2 +- theories/ZArith/Zcompare.v | 2 +- theories/ZArith/Zcomplements.v | 2 +- theories/ZArith/Zdigits.v | 2 +- theories/ZArith/Zdiv.v | 2 +- theories/ZArith/Zeuclid.v | 2 +- theories/ZArith/Zeven.v | 2 +- theories/ZArith/Zgcd_alt.v | 2 +- theories/ZArith/Zhints.v | 2 +- theories/ZArith/Zlogarithm.v | 2 +- theories/ZArith/Zmax.v | 2 +- theories/ZArith/Zmin.v | 2 +- theories/ZArith/Zminmax.v | 2 +- theories/ZArith/Zmisc.v | 2 +- theories/ZArith/Znat.v | 2 +- theories/ZArith/Znumtheory.v | 2 +- theories/ZArith/Zorder.v | 2 +- theories/ZArith/Zpow_alt.v | 2 +- theories/ZArith/Zpow_def.v | 2 +- theories/ZArith/Zpow_facts.v | 2 +- theories/ZArith/Zpower.v | 2 +- theories/ZArith/Zquot.v | 2 +- theories/ZArith/Zsqrt_compat.v | 2 +- theories/ZArith/Zwf.v | 2 +- theories/ZArith/auxiliary.v | 2 +- tools/compat5.ml | 2 +- tools/compat5.mlp | 2 +- tools/compat5b.ml | 2 +- tools/compat5b.mlp | 2 +- tools/coq_makefile.ml | 2 +- tools/coq_tex.ml | 2 +- tools/coqc.ml | 2 +- tools/coqdep.ml | 2 +- tools/coqdep_boot.ml | 2 +- tools/coqdep_common.ml | 2 +- tools/coqdep_common.mli | 2 +- tools/coqdep_lexer.mli | 2 +- tools/coqdep_lexer.mll | 2 +- tools/coqdoc/alpha.ml | 2 +- tools/coqdoc/alpha.mli | 2 +- tools/coqdoc/cdglobals.ml | 2 +- tools/coqdoc/cpretty.mli | 2 +- tools/coqdoc/cpretty.mll | 2 +- tools/coqdoc/index.ml | 2 +- tools/coqdoc/index.mli | 2 +- tools/coqdoc/main.ml | 2 +- tools/coqdoc/output.ml | 2 +- tools/coqdoc/output.mli | 2 +- tools/coqdoc/tokens.ml | 2 +- tools/coqdoc/tokens.mli | 2 +- tools/coqmktop.ml | 2 +- tools/coqwc.mll | 2 +- tools/coqworkmgr.ml | 2 +- tools/fake_ide.ml | 2 +- tools/gallina.ml | 2 +- tools/gallina_lexer.mll | 2 +- toplevel/assumptions.ml | 2 +- toplevel/assumptions.mli | 2 +- toplevel/auto_ind_decl.ml | 2 +- toplevel/auto_ind_decl.mli | 2 +- toplevel/cerrors.ml | 2 +- toplevel/cerrors.mli | 2 +- toplevel/class.ml | 2 +- toplevel/class.mli | 2 +- toplevel/classes.ml | 2 +- toplevel/classes.mli | 2 +- toplevel/command.ml | 2 +- toplevel/command.mli | 2 +- toplevel/coqinit.ml | 2 +- toplevel/coqinit.mli | 2 +- toplevel/coqloop.ml | 2 +- toplevel/coqloop.mli | 2 +- toplevel/coqtop.ml | 2 +- toplevel/coqtop.mli | 2 +- toplevel/discharge.ml | 2 +- toplevel/discharge.mli | 2 +- toplevel/g_obligations.ml4 | 2 +- toplevel/himsg.ml | 2 +- toplevel/himsg.mli | 2 +- toplevel/ind_tables.ml | 2 +- toplevel/ind_tables.mli | 2 +- toplevel/indschemes.ml | 2 +- toplevel/indschemes.mli | 2 +- toplevel/locality.ml | 2 +- toplevel/locality.mli | 2 +- toplevel/metasyntax.ml | 2 +- toplevel/metasyntax.mli | 2 +- toplevel/mltop.ml | 2 +- toplevel/mltop.mli | 2 +- toplevel/obligations.mli | 2 +- toplevel/record.ml | 2 +- toplevel/record.mli | 2 +- toplevel/search.ml | 2 +- toplevel/search.mli | 2 +- toplevel/usage.ml | 2 +- toplevel/usage.mli | 2 +- toplevel/vernac.ml | 2 +- toplevel/vernac.mli | 2 +- toplevel/vernacentries.ml | 2 +- toplevel/vernacentries.mli | 2 +- toplevel/vernacinterp.ml | 2 +- toplevel/vernacinterp.mli | 2 +- 1185 files changed, 1185 insertions(+), 1185 deletions(-) diff --git a/checker/check.ml b/checker/check.ml index 21c8f1c5bb..3a5c91217d 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* V8.2 © INRIA 2008-2011
  • V8.3 © INRIA 2010-2011
  • V8.4 © INRIA 2012-2014
    • -
  • V8.5 © INRIA 2015
    • +
  • V8.5 © INRIA 2015-2016

    • This research was partly supported by IST diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 1641a1ed37..328bd68daf 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -38,7 +38,7 @@

  • V8.2 © INRIA 2008-2011
  • V8.3 © INRIA 2010-2011
  • V8.4 © INRIA 2012-2014
    • -
  • V8.5 © INRIA 2015
    • +
  • V8.5 © INRIA 2015-2016

    • This research was partly supported by IST diff --git a/doc/common/title.tex b/doc/common/title.tex index 4716c3156a..0e072b6b65 100644 --- a/doc/common/title.tex +++ b/doc/common/title.tex @@ -45,7 +45,7 @@ V\coqversion, \today %END LATEX \copyright INRIA 1999-2004 ({\Coq} versions 7.x) -\copyright INRIA 2004-2015 ({\Coq} versions 8.x) +\copyright INRIA 2004-2016 ({\Coq} versions 8.x) #3 \end{flushleft} diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index fe0959ddbc..8def9537cb 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* CFBundleGetInfoString Coq_vVERSION NSHumanReadableCopyright - Copyright 1999-2015, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS + Copyright 1999-2016, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS CFBundleHelpBookFolder share/doc/coq/html/ CFAppleHelpAnchor diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 3671535680..ac9cc57bc0 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* . - reflexivity. - exact I. Qed. + +(* Fixing a bug when destructing a type with let-ins in the constructor *) + +Inductive I := C : let x:=1 in x=1 -> I. +Goal I -> True. +intros [x H]. (* Was failing in 8.5 *) +Abort. -- cgit v1.2.3 From 3ad653b53ccbf2feb7807b4618dc9a455e9df877 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 20 Jan 2016 22:41:43 +0100 Subject: Code simplification in elim.ml. --- tactics/elim.ml | 21 ++++++--------------- 1 file changed, 6 insertions(+), 15 deletions(-) diff --git a/tactics/elim.ml b/tactics/elim.ml index 182240b554..0954f3ddf2 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -17,28 +17,19 @@ open Tacticals.New open Tactics open Proofview.Notations +(* Supposed to be called without as clause *) let introElimAssumsThen tac ba = - let nassums = - List.fold_left - (fun acc b -> if b then acc+2 else acc+1) - 0 ba.Tacticals.branchsign - in - let introElimAssums = tclDO nassums intro in + assert (ba.Tacticals.branchnames == []); + let introElimAssums = tclDO ba.Tacticals.nassums intro in (tclTHEN introElimAssums (elim_on_ba tac ba)) +(* Supposed to be called with a non-recursive scheme *) let introCaseAssumsThen tac ba = - let case_thin_sign = - List.flatten - (List.map (function b -> if b then [false;true] else [false]) - ba.Tacticals.branchsign) - in - let n1 = List.length case_thin_sign in + let n1 = List.length ba.Tacticals.branchsign in let n2 = List.length ba.Tacticals.branchnames in let (l1,l2),l3 = if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, [] - else - (ba.Tacticals.branchnames, []), - if n1 > n2 then snd (List.chop n2 case_thin_sign) else [] in + else (ba.Tacticals.branchnames, []), List.make (n1-n2) false in let introCaseAssums = tclTHEN (intro_patterns l1) (intros_clearing l3) in (tclTHEN introCaseAssums (case_on_ba (tac l2) ba)) -- cgit v1.2.3 From 4b075af747f65bcd73ff1c78417cf77edf6fbd76 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 21 Jan 2016 01:13:56 +0100 Subject: Fixing some problems with double induction. Basically, the hypotheses were treated in an incorrect order, with a hack for sometimes put them again in the right order, resulting in failures and redundant hypotheses. Status unclear, because this new version is incompatible except in simple cases like a double induction on two "nat". Fixing the bug incidentally simplify the code, relying on the deprecation since 8.4 to allow not to ensure a compatibility (beyond the simple situation of a double induction on simple datatypes). See file induct.v for effect of changes. --- CHANGES | 4 ++++ tactics/elim.ml | 3 +-- tactics/tacticals.ml | 48 +++++---------------------------------------- test-suite/success/induct.v | 43 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 53 insertions(+), 45 deletions(-) diff --git a/CHANGES b/CHANGES index a9fbfe29d0..cda16d3804 100644 --- a/CHANGES +++ b/CHANGES @@ -6,6 +6,10 @@ Tactics - Flag "Bracketing Last Introduction Pattern" is now on by default. - New flag "Shrink Abstract" that minimalizes proofs generated by the abstract tactical w.r.t. variables appearing in the body of the proof. +- Serious bugs are fixed in tactic "double induction" (source of + incompatibilities as soon as the inductive types have dependencies in + the type of their constructors; "double induction" remains however + deprecated). Program diff --git a/tactics/elim.ml b/tactics/elim.ml index 0954f3ddf2..99236e7707 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -145,8 +145,7 @@ let induction_trailer abs_i abs_j bargs = in let ids = List.rev (ids_of_named_context hyps) in (tclTHENLIST - [bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids)); - simple_elimination (mkVar id)]) + [revert ids; simple_elimination (mkVar id)]) end } )) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 750ec8fb1e..061c05b9b2 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -239,52 +239,14 @@ let gl_make_case_nodep ind gl = (Sigma.to_evar_map sigma, r) let make_elim_branch_assumptions ba gl = - let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc = - match lb,lc with - | ([], _) -> - { ba = ba; - assums = assums} - | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) -> - makerec (recarg::indarg::assums, - idrec::cargs, - idrec::recargs, - constargs, - idind::indargs) tl idtl - | ((false::tl), ((id,_,_ as constarg)::idtl)) -> - makerec (constarg::assums, - id::cargs, - id::constargs, - recargs, - indargs) tl idtl - | (_, _) -> anomaly (Pp.str "make_elim_branch_assumptions") - in - makerec ([],[],[],[],[]) ba.branchsign - (try List.firstn ba.nassums (pf_hyps gl) - with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions")) + let assums = + try List.rev (List.firstn ba.nassums (pf_hyps gl)) + with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions") in + { ba = ba; assums = assums } let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl -let make_case_branch_assumptions ba gl = - let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 = - match p_0,p_1 with - | ([], _) -> - { ba = ba; - assums = assums} - | ((true::tl), ((idrec,_,_ as recarg)::idtl)) -> - makerec (recarg::assums, - idrec::cargs, - idrec::recargs, - constargs) tl idtl - | ((false::tl), ((id,_,_ as constarg)::idtl)) -> - makerec (constarg::assums, - id::cargs, - recargs, - id::constargs) tl idtl - | (_, _) -> anomaly (Pp.str "make_case_branch_assumptions") - in - makerec ([],[],[],[]) ba.branchsign - (try List.firstn ba.nassums (pf_hyps gl) - with Failure _ -> anomaly (Pp.str "make_case_branch_assumptions")) +let make_case_branch_assumptions = make_elim_branch_assumptions let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 7ae60d9892..9413b8dae9 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -151,3 +151,46 @@ intros x H1 H. induction H. change (0 = z -> True) in IHrepr''. Abort. + +(* Test double induction *) + +(* This was failing in 8.5 and before because of a bug in the order of + hypotheses *) + +Inductive I2 : Type := + C2 : forall x:nat, x=x -> I2. +Goal forall a b:I2, a = b. +double induction a b. +Abort. + +(* This was leaving useless hypotheses in 8.5 and before because of + the same bug. This is a change of compatibility. *) + +Inductive I3 : Prop := + C3 : forall x:nat, x=x -> I3. +Goal forall a b:I3, a = b. +double induction a b. +Fail clear H. (* H should have been erased *) +Abort. + +(* This one had quantification in reverse order in 8.5 and before *) +(* This is a change of compatibility. *) + +Goal forall m n, le m n -> le n m -> n=m. +intros m n. double induction 1 2. +3:destruct 1. (* Should be "S m0 <= m0" *) +Abort. + +(* Idem *) + +Goal forall m n p q, le m n -> le p q -> n+p=m+q. +intros *. double induction 1 2. +3:clear H2. (* H2 should have been erased *) +Abort. + +(* This is unchanged *) + +Goal forall m n:nat, n=m. +double induction m n. +Abort. + -- cgit v1.2.3 From 9c2662eecc398f38be3b6280a8f760cc439bc31c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 21 Jan 2016 01:43:10 +0100 Subject: Stronger invariants on the use of the introduction pattern (pat1,...,patn). The length of the pattern should now be exactly the number of assumptions and definitions introduced by the destruction or induction, including the induction hypotheses in case of an induction. Like for pattern-matching, the local definitions in the argument of the constructor can be skipped in which case a name is automatically created for these. --- CHANGES | 3 + intf/misctypes.mli | 5 +- lib/cList.ml | 7 ++ lib/cList.mli | 3 + parsing/g_tactic.ml4 | 15 ++-- printing/miscprint.ml | 4 +- tactics/inv.ml | 8 +- tactics/tacintern.ml | 7 +- tactics/tacinterp.ml | 13 +++- tactics/tacsubst.ml | 8 +- tactics/tacticals.ml | 89 +++++++++++++++------- tactics/tacticals.mli | 18 +++-- tactics/tactics.ml | 41 +++++----- test-suite/success/intros.v | 23 ++++++ theories/Sorting/Permutation.v | 2 +- .../Wellfounded/Lexicographic_Exponentiation.v | 6 +- toplevel/auto_ind_decl.ml | 6 +- 17 files changed, 177 insertions(+), 81 deletions(-) diff --git a/CHANGES b/CHANGES index cda16d3804..e80a3b4547 100644 --- a/CHANGES +++ b/CHANGES @@ -10,6 +10,9 @@ Tactics incompatibilities as soon as the inductive types have dependencies in the type of their constructors; "double induction" remains however deprecated). +- In introduction patterns of the form (pat1,...,patn), n should match + the exact number of hypotheses introduced (except for local definitions + for which pattern can be omitted, as in regular pattern-matching). Program diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 65c7dccf2a..889dc54448 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -16,6 +16,8 @@ type patvar = Id.t (** Introduction patterns *) +type tuple_flag = bool (* tells pattern list should be list of fixed length *) + type 'constr intro_pattern_expr = | IntroForthcoming of bool | IntroNaming of intro_pattern_naming_expr @@ -31,7 +33,8 @@ and 'constr intro_pattern_action_expr = | IntroApplyOn of 'constr * (Loc.t * 'constr intro_pattern_expr) | IntroRewrite of bool and 'constr or_and_intro_pattern_expr = - (Loc.t * 'constr intro_pattern_expr) list list + | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list + | IntroAndPattern of (Loc.t * 'constr intro_pattern_expr) list (** Move destination for hypothesis *) diff --git a/lib/cList.ml b/lib/cList.ml index bd3e09b5b2..ba592d13f3 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -48,6 +48,7 @@ sig val filteri : (int -> 'a -> bool) -> 'a list -> 'a list val smartfilter : ('a -> bool) -> 'a list -> 'a list + val extend : bool list -> 'a -> 'a list -> 'a list val count : ('a -> bool) -> 'a list -> int val index : 'a eq -> 'a -> 'a list -> int val index0 : 'a eq -> 'a -> 'a list -> int @@ -376,6 +377,12 @@ let rec smartfilter f l = match l with else h :: tl' else tl' +let rec extend l a l' = match l,l' with + | true::l, b::l' -> b :: extend l a l' + | false::l, l' -> a :: extend l a l' + | [], [] -> [] + | _ -> invalid_arg "extend" + let count f l = let rec aux acc = function | [] -> acc diff --git a/lib/cList.mli b/lib/cList.mli index 1487f67a37..9c7b815c15 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -94,6 +94,9 @@ sig (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i [f ai = true], then [smartfilter f l == l] *) + val extend : bool list -> 'a -> 'a list -> 'a list +(** [extend l a [a1..an]] assumes that the number of [true] in [l] is [n]; + it extends [a1..an] by inserting [a] at the position of [false] in [l] *) val count : ('a -> bool) -> 'a list -> int val index : 'a eq -> 'a -> 'a list -> int diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index a7b05dd5eb..77d74892d0 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -285,18 +285,19 @@ GEXTEND Gram [ [ l = LIST1 nonsimple_intropattern -> l ]] ; or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc - | "()" -> [[]] - | "("; si = simple_intropattern; ")" -> [[si]] + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc + | "()" -> IntroAndPattern [] + | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> [si::tc] + tc = LIST1 simple_intropattern SEP "," ; ")" -> + IntroAndPattern (si::tc) | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function - | ([]|[_]|[_;_]) as l -> [l] - | t::q -> [[t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (pairify q)))]] - in pairify (si::tc) ] ] + | ([]|[_]|[_;_]) as l -> l + | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] + in IntroAndPattern (pairify (si::tc)) ] ] ; equality_intropattern: [ [ "->" -> IntroRewrite true diff --git a/printing/miscprint.ml b/printing/miscprint.ml index d09af6d2ac..be3e62574a 100644 --- a/printing/miscprint.ml +++ b/printing/miscprint.ml @@ -33,9 +33,9 @@ and pr_intro_pattern_action prc = function | IntroRewrite false -> str "<-" and pr_or_and_intro_pattern prc = function - | [pl] -> + | IntroAndPattern pl -> str "(" ++ hv 0 (prlist_with_sep pr_comma (pr_intro_pattern prc) pl) ++ str ")" - | pll -> + | IntroOrPattern pll -> str "[" ++ hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc (pr_intro_pattern prc)) pll) ++ str "]" diff --git a/tactics/inv.ml b/tactics/inv.ml index 3574990f6c..01124e867c 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -296,17 +296,17 @@ let get_names (allow_conj,issimple) (loc, pat as x) = match pat with error "Discarding pattern not allowed for inversion equations." | IntroAction (IntroRewrite _) -> error "Rewriting pattern not allowed for inversion equations." - | IntroAction (IntroOrAndPattern [[]]) when allow_conj -> (None, []) - | IntroAction (IntroOrAndPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l]) + | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) + | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l))) when allow_conj -> (Some id,l) - | IntroAction (IntroOrAndPattern [_]) -> + | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then error"Conjunctive patterns not allowed for simple inversion equations." else error"Nested conjunctive patterns not allowed for inversion equations." | IntroAction (IntroInjection l) -> error "Injection patterns not allowed for inversion equations." - | IntroAction (IntroOrAndPattern l) -> + | IntroAction (IntroOrAndPattern (IntroOrPattern _)) -> error "Disjunctive patterns not allowed for inversion equations." | IntroAction (IntroApplyOn (c,pat)) -> error "Apply patterns not allowed for inversion equations." diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 14e0fed31d..f92213da81 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -258,8 +258,11 @@ and intern_intro_pattern_action lf ist = function | IntroApplyOn (c,pat) -> IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) -and intern_or_and_intro_pattern lf ist = - List.map (List.map (intern_intro_pattern lf ist)) +and intern_or_and_intro_pattern lf ist = function + | IntroAndPattern l -> + IntroAndPattern (List.map (intern_intro_pattern lf ist) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) let intern_or_and_intro_pattern_loc lf ist = function | ArgVar (_,id) as x -> diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 8db91c07f6..a6991691fb 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -511,7 +511,9 @@ let extract_ltac_constr_values ist env = (* Extract the identifier list from lfun: join all branches (what to do else?)*) let rec intropattern_ids (loc,pat) = match pat with | IntroNaming (IntroIdentifier id) -> [id] - | IntroAction (IntroOrAndPattern ll) -> + | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> List.flatten (List.map intropattern_ids (List.flatten ll)) | IntroAction (IntroInjection l) -> List.flatten (List.map intropattern_ids l) @@ -940,8 +942,13 @@ and interp_intro_pattern_action ist env sigma = function sigma, IntroApplyOn (c,ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x -and interp_or_and_intro_pattern ist env sigma = - List.fold_map (interp_intro_pattern_list_as_list ist env) sigma +and interp_or_and_intro_pattern ist env sigma = function + | IntroAndPattern l -> + let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in + sigma, IntroAndPattern l + | IntroOrPattern ll -> + let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in + sigma, IntroOrPattern ll and interp_intro_pattern_list_as_list ist env sigma = function | [loc,IntroNaming (IntroIdentifier id)] as l -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index c74f6093a2..e09360a6a6 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -54,10 +54,16 @@ and subst_intro_pattern_action subst = function | IntroApplyOn (t,pat) -> IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) | IntroOrAndPattern l -> - IntroOrAndPattern (List.map (List.map (subst_intro_pattern subst)) l) + IntroOrAndPattern (subst_intro_or_and_pattern subst l) | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) | IntroWildcard | IntroRewrite _ as x -> x +and subst_intro_or_and_pattern subst = function + | IntroAndPattern l -> + IntroAndPattern (List.map (subst_intro_pattern subst) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) + let subst_induction_arg subst = function | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) | clear,ElimOnAnonHyp n as x -> x diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 061c05b9b2..4029d1fcca 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -147,51 +147,85 @@ type branch_args = { largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) pred : constr; (* the predicate we used *) - nassums : int; (* the number of assumptions to be introduced *) + nassums : int; (* number of assumptions/letin to be introduced *) branchsign : bool list; (* the signature of the branch. - true=recursive argument, false=constant *) + true=assumption, false=let-in *) branchnames : Tacexpr.intro_patterns} type branch_assumptions = { ba : branch_args; (* the branch args *) assums : Context.Named.t} (* the list of assumptions introduced *) +open Misctypes + let fix_empty_or_and_pattern nv l = (* 1- The syntax does not distinguish between "[ ]" for one clause with no names and "[ ]" for no clause at all *) (* 2- More generally, we admit "[ ]" for any disjunctive pattern of arbitrary length *) match l with - | [[]] -> List.make nv [] + | IntroOrPattern [[]] -> IntroOrPattern (List.make nv []) | _ -> l -let check_or_and_pattern_size loc names n = - if not (Int.equal (List.length names) n) then - if Int.equal n 1 then - user_err_loc (loc,"",str "Expects a conjunctive pattern.") - else - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n - ++ str " branches.") - -let compute_induction_names n = function +let check_or_and_pattern_size loc names branchsigns = + let n = Array.length branchsigns in + let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in + let err1 p1 p2 = + user_err_loc (loc,"",str "Expects " ++ msg p1 p2 ++ str ".") in + let errn n = + user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + ++ str " branches.") in + let err1' p1 p2 = + user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + match names with + | IntroAndPattern l -> + if not (Int.equal n 1) then errn n; + let p1 = List.count (fun x -> x) branchsigns.(0) in + let p2 = List.length branchsigns.(0) in + let p = List.length l in + if not (Int.equal p p1 || Int.equal p p2) || + not (List.for_all (function _,IntroNaming _ | _,IntroAction _ -> true | _,IntroForthcoming _ -> false) l) then err1 p1 p2; + if Int.equal p p1 then + IntroAndPattern + (List.extend branchsigns.(0) (Loc.ghost,IntroNaming IntroAnonymous) l) + else + names + | IntroOrPattern ll -> + if not (Int.equal n (List.length ll)) then + if Int.equal n 1 then + let p1 = List.count (fun x -> x) branchsigns.(0) in + let p2 = List.length branchsigns.(0) in + err1' p1 p2 else errn n; + names + +let get_and_check_or_and_pattern loc names branchsigns = + let names = check_or_and_pattern_size loc names branchsigns in + match names with + | IntroAndPattern l -> [|l|] + | IntroOrPattern l -> Array.of_list l + +let compute_induction_names branchletsigns = function | None -> - Array.make n [] + Array.make (Array.length branchletsigns) [] | Some (loc,names) -> - let names = fix_empty_or_and_pattern n names in - check_or_and_pattern_size loc names n; - Array.of_list names + let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in + get_and_check_or_and_pattern loc names branchletsigns -let compute_construtor_signatures isrec ((_,k as ity),u) = +(* Compute the let-in signature of case analysis or standard induction scheme *) +let compute_constructor_signatures isrec ((_,k as ity),u) = let rec analrec c recargs = match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> - let b = match Declareops.dest_recarg recarg with - | Norec | Imbr _ -> false - | Mrec (_,j) -> isrec && Int.equal j k - in b :: (analrec c rest) - | LetIn (_,_,_,c), rest -> false :: (analrec c rest) + let rest = analrec c rest in + begin match Declareops.dest_recarg recarg with + | Norec | Imbr _ -> true :: rest + | Mrec (_,j) -> + if isrec && Int.equal j k then true :: true :: rest + else true :: rest + end + | LetIn (_,_,_,c), rest -> false :: analrec c rest | _, [] -> [] - | _ -> anomaly (Pp.str "compute_construtor_signatures") + | _ -> anomaly (Pp.str "compute_constructor_signatures") in let (mib,mip) = Global.lookup_inductive ity in let n = mib.mind_nparams in @@ -596,8 +630,8 @@ module New = struct (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in - let branchsigns = compute_construtor_signatures isrec ind in - let brnames = compute_induction_names (Array.length branchsigns) allnames in + let branchsigns = compute_constructor_signatures isrec ind in + let brnames = compute_induction_names branchsigns allnames in let flags = Unification.elim_flags () in let elimclause' = match predicate with @@ -609,10 +643,7 @@ module New = struct let (hd,largs) = decompose_app clenv'.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); - nassums = - List.fold_left - (fun acc b -> if b then acc+2 else acc+1) - 0 branchsigns.(i); + nassums = List.length branchsigns.(i); branchnum = i+1; ity = ind; largs = List.map (clenv_nf_meta clenv') largs; diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 147f1f0f20..4f6f87f698 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -102,28 +102,32 @@ type branch_args = { largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) pred : constr; (** the predicate we used *) - nassums : int; (** the number of assumptions to be introduced *) + nassums : int; (** number of assumptions/letin to be introduced *) branchsign : bool list; (** the signature of the branch. - true=recursive argument, false=constant *) + true=assumption, false=let-in *) branchnames : intro_patterns} type branch_assumptions = { ba : branch_args; (** the branch args *) assums : Context.Named.t} (** the list of assumptions introduced *) -(** [check_disjunctive_pattern_size loc pats n] returns an appropriate - error message if |pats| <> n *) -val check_or_and_pattern_size : - Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> int -> unit +(** [check_disjunctive_pattern_size loc pats n] returns an appropriate + error message if |pats| <> n; extends them if no pattern is given + for let-ins in the case of a conjunctive pattern *) +val get_and_check_or_and_pattern : + Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> + bool list array -> intro_patterns array (** Tolerate "[]" to mean a disjunctive pattern of any length *) val fix_empty_or_and_pattern : int -> delayed_open_constr or_and_intro_pattern_expr -> delayed_open_constr or_and_intro_pattern_expr +val compute_constructor_signatures : rec_flag -> pinductive -> bool list array + (** Useful for [as intro_pattern] modifier *) val compute_induction_names : - int -> or_and_intro_pattern option -> intro_patterns array + bool list array -> or_and_intro_pattern option -> intro_patterns array val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f0f46c14db..796cea98f8 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2089,14 +2089,15 @@ let intro_or_and_pattern loc bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in - let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in - let nv = constructors_nrealdecls ind in - let ll = fix_empty_or_and_pattern (Array.length nv) ll in - check_or_and_pattern_size loc ll (Array.length nv); + let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in + let branchsigns = compute_constructor_signatures false ind in + let nv_with_let = Array.map List.length branchsigns in + let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in + let ll = get_and_check_or_and_pattern loc ll branchsigns in Tacticals.New.tclTHENLASTn (Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id]))) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) - nv (Array.of_list ll)) + nv_with_let ll) end } let rewrite_hyp assert_style l2r id = @@ -2137,7 +2138,8 @@ let prepare_naming loc = function let rec explicit_intro_names = function | (_, IntroForthcoming _) :: l -> explicit_intro_names l | (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l -| (_, IntroAction (IntroOrAndPattern ll)) :: l' -> +| (_, IntroAction (IntroOrAndPattern l)) :: l' -> + let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | (_, IntroAction (IntroInjection l)) :: l' -> explicit_intro_names (l@l') @@ -2842,8 +2844,8 @@ let induct_discharge dests avoid' tac (avoid,ra) names = let avoid = avoid @ avoid' in let rec peel_tac ra dests names thin = match ra with - | (RecArg,deprec,recvarname) :: - (IndArg,depind,hyprecname) :: ra' -> + | (RecArg,_,deprec,recvarname) :: + (IndArg,_,depind,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> @@ -2860,7 +2862,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = peel_tac ra' (update_dest dests ids') names thin) end }) end } - | (IndArg,dep,hyprecname) :: ra' -> + | (IndArg,_,dep,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = @@ -2868,7 +2870,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = dest_intro_patterns avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) end } - | (RecArg,dep,recvarname) :: ra' -> + | (RecArg,_,dep,recvarname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in @@ -2876,7 +2878,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = dest_intro_patterns avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } - | (OtherArg,dep,_) :: ra' -> + | (OtherArg,_,dep,_) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in @@ -3682,9 +3684,9 @@ let compute_scheme_signature scheme names_info ind_type_guess = let rec check_branch p c = match kind_of_term c with | Prod (_,t,c) -> - (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c + (is_pred p t, true, dependent (mkRel 1) c) :: check_branch (p+1) c | LetIn (_,_,_,c) -> - (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c + (OtherArg, false, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c == IndArg -> [] | _ -> raise Exit in @@ -3694,12 +3696,12 @@ let compute_scheme_signature scheme names_info ind_type_guess = (try let lchck_brch = check_branch p t in let n = List.fold_left - (fun n (b,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in + (fun n (b,_,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in let namesign = - List.map (fun (b,dep) -> - (b, dep, if b == IndArg then hyprecname else recvarname)) + List.map (fun (b,is_assum,dep) -> + (b,is_assum,dep,if b == IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit-> error_ind_scheme "the branches of") @@ -3744,7 +3746,7 @@ let given_elim hyp0 (elimc,lbind as e) gl = Tacmach.New.project gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess type scheme_signature = - (Id.t list * (elim_arg_kind * bool * Id.t) list) array + (Id.t list * (elim_arg_kind * bool * bool * Id.t) list) array type eliminator_source = | ElimUsing of (eliminator * types) * scheme_signature @@ -3865,7 +3867,10 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = List.fold_left (fun a (id,b,_) -> if Option.is_empty b then (mkVar id)::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in - let names = compute_induction_names (Array.length indsign) names in + let branchletsigns = + let f (_,is_not_let,_,_) = is_not_let in + Array.map (fun (_,l) -> List.map f l) indsign in + let names = compute_induction_names branchletsigns names in let tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index af5f994010..ee69df9774 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -105,3 +105,26 @@ Inductive I := C : let x:=1 in x=1 -> I. Goal I -> True. intros [x H]. (* Was failing in 8.5 *) Abort. + +(* Ensuring that the (pat1,...,patn) intropatterns has the expected size, up + to skipping let-ins *) + +Goal I -> 1=1. +intros (H). (* This skips x *) +exact H. +Qed. + +Goal I -> 1=1. +Fail intros (x,H,H'). +Fail intros [|]. +intros (x,H). +exact H. +Qed. + +Goal Acc le 0 -> True. +Fail induction 1 as (n,H). (* Induction hypothesis is missing *) +induction 1 as (n,H,IH). +exact Logic.I. +Qed. + + diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index fcb4e7876d..ba7da256dc 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -321,7 +321,7 @@ Proof. induction H; intros; try (injection Heqm; intros; subst; clear Heqm); discriminate || (try tauto). apply Permutation_length_1_inv in H as ->; left; auto. - apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as (); + apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as []; auto. Qed. diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index b8b9e929c2..e05dab7a4a 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -75,7 +75,7 @@ Section Wf_Lexicographic_Exponentiation. Proof. intros. inversion H. - - apply app_cons_not_nil in H1 as (). + - apply app_cons_not_nil in H1 as []. - assert (x ++ [a] = [x0]) by auto with sets. apply app_eq_unit in H0 as [(->, _)| (_, [=])]. auto using d_nil. @@ -98,7 +98,7 @@ Section Wf_Lexicographic_Exponentiation. destruct (app_inj_tail (l ++ [y]) ([] ++ [b]) _ _ H0) as ((?, <-)%app_inj_tail, <-). inversion H1; subst; [ apply rt_step; assumption | apply rt_refl ]. - inversion H0. - + apply app_cons_not_nil in H3 as (). + + apply app_cons_not_nil in H3 as []. + rewrite app_comm_cons in H0, H1. apply desc_prefix in H0. pose proof (H x0 b H0). apply rt_trans with (y := x0); auto with sets. @@ -145,7 +145,7 @@ Section Wf_Lexicographic_Exponentiation. pose proof H0 as H0'. apply app_inj_tail in H0' as (_, ->). rewrite app_assoc_reverse in H0. - apply Hind in H0 as (). + apply Hind in H0 as []. split. assumption. apply d_conc; auto with sets. diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 56106928e5..2f206bfc84 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -85,7 +85,7 @@ let destruct_on c = destruct false None c None None let destruct_on_using c id = destruct false None c - (Some (dl,[[dl,IntroNaming IntroAnonymous]; + (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous]; [dl,IntroNaming (IntroIdentifier id)]])) None @@ -589,8 +589,8 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Simple.apply_in freshz (andb_prop()); Proofview.Goal.nf_enter { enter = begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in - (destruct_on_as (mkVar freshz) - [[dl,IntroNaming (IntroIdentifier fresht); + destruct_on_as (mkVar freshz) + (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht); dl,IntroNaming (IntroIdentifier freshz)]]) end } ]); -- cgit v1.2.3 From aa1913411547eeed464b024f1cf54113be26e929 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 21 Jan 2016 22:17:36 +0100 Subject: Compile OS X binaries without native_compute support. --- dev/make-macos-dmg.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/make-macos-dmg.sh b/dev/make-macos-dmg.sh index 70889badc1..20b7b5b531 100755 --- a/dev/make-macos-dmg.sh +++ b/dev/make-macos-dmg.sh @@ -8,7 +8,7 @@ eval `opam config env` make distclean OUTDIR=$PWD/_install DMGDIR=$PWD/_dmg -./configure -debug -prefix $OUTDIR +./configure -debug -prefix $OUTDIR -native-compiler no VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app -- cgit v1.2.3 From 176d8e004153e65688dc8ef4f22f7939fd6101b1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 21 Jan 2016 18:45:36 +0100 Subject: New step on recent 9c2662eecc398f3 (strong invariants on tuple pattern). - Fixing dead code, doc. - Relaxing constraints on using an as-tuple in inversion. --- intf/misctypes.mli | 2 -- tactics/inv.ml | 4 ++-- tactics/tacticals.ml | 38 ++++++++++++++++++++++++-------------- tactics/tacticals.mli | 6 +++--- 4 files changed, 29 insertions(+), 21 deletions(-) diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 3c6d59ff0c..1452bbc347 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -16,8 +16,6 @@ type patvar = Id.t (** Introduction patterns *) -type tuple_flag = bool (* tells pattern list should be list of fixed length *) - type 'constr intro_pattern_expr = | IntroForthcoming of bool | IntroNaming of intro_pattern_naming_expr diff --git a/tactics/inv.ml b/tactics/inv.ml index 8030fc32ee..ded1e8076d 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -296,8 +296,8 @@ let get_names (allow_conj,issimple) (loc, pat as x) = match pat with error "Discarding pattern not allowed for inversion equations." | IntroAction (IntroRewrite _) -> error "Rewriting pattern not allowed for inversion equations." - | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) - | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l))) + | IntroAction (IntroOrAndPattern (IntroAndPattern [] | IntroOrPattern [[]])) when allow_conj -> (None, []) + | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ])) when allow_conj -> (Some id,l) | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index bacd8a607a..d79de4913c 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -167,7 +167,7 @@ let fix_empty_or_and_pattern nv l = | IntroOrPattern [[]] -> IntroOrPattern (List.make nv []) | _ -> l -let check_or_and_pattern_size loc names branchsigns = +let check_or_and_pattern_size check_and loc names branchsigns = let n = Array.length branchsigns in let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in let err1 p1 p2 = @@ -177,17 +177,23 @@ let check_or_and_pattern_size loc names branchsigns = ++ str " branches.") in let err1' p1 p2 = user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + let errforthcoming loc = + user_err_loc (loc,"",strbrk "Unexpected non atomic pattern.") in match names with | IntroAndPattern l -> if not (Int.equal n 1) then errn n; - let p1 = List.count (fun x -> x) branchsigns.(0) in - let p2 = List.length branchsigns.(0) in - let p = List.length l in - if not (Int.equal p p1 || Int.equal p p2) || - not (List.for_all (function _,IntroNaming _ | _,IntroAction _ -> true | _,IntroForthcoming _ -> false) l) then err1 p1 p2; - if Int.equal p p1 then - IntroAndPattern - (List.extend branchsigns.(0) (Loc.ghost,IntroNaming IntroAnonymous) l) + let l' = List.filter (function _,IntroForthcoming _ -> true | _,IntroNaming _ | _,IntroAction _ -> false) l in + if l' != [] then errforthcoming (fst (List.hd l')); + if check_and then + let p1 = List.count (fun x -> x) branchsigns.(0) in + let p2 = List.length branchsigns.(0) in + let p = List.length l in + if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2; + if Int.equal p p1 then + IntroAndPattern + (List.extend branchsigns.(0) (Loc.ghost,IntroNaming IntroAnonymous) l) + else + names else names | IntroOrPattern ll -> @@ -198,18 +204,22 @@ let check_or_and_pattern_size loc names branchsigns = err1' p1 p2 else errn n; names -let get_and_check_or_and_pattern loc names branchsigns = - let names = check_or_and_pattern_size loc names branchsigns in +let get_and_check_or_and_pattern_gen check_and loc names branchsigns = + let names = check_or_and_pattern_size check_and loc names branchsigns in match names with | IntroAndPattern l -> [|l|] | IntroOrPattern l -> Array.of_list l -let compute_induction_names branchletsigns = function +let get_and_check_or_and_pattern = get_and_check_or_and_pattern_gen true + +let compute_induction_names_gen check_and branchletsigns = function | None -> Array.make (Array.length branchletsigns) [] | Some (loc,names) -> let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in - get_and_check_or_and_pattern loc names branchletsigns + get_and_check_or_and_pattern_gen check_and loc names branchletsigns + +let compute_induction_names = compute_induction_names_gen true (* Compute the let-in signature of case analysis or standard induction scheme *) let compute_constructor_signatures isrec ((_,k as ity),u) = @@ -631,7 +641,7 @@ module New = struct in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in let branchsigns = compute_constructor_signatures isrec ind in - let brnames = compute_induction_names branchsigns allnames in + let brnames = compute_induction_names_gen false branchsigns allnames in let flags = Unification.elim_flags () in let elimclause' = match predicate with diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 4b70536113..ffcc71b458 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -111,10 +111,10 @@ type branch_assumptions = { ba : branch_args; (** the branch args *) assums : Context.Named.t} (** the list of assumptions introduced *) -(** [check_disjunctive_pattern_size loc pats n] returns an appropriate - error message if |pats| <> n; extends them if no pattern is given +(** [get_and_check_or_and_pattern loc pats branchsign] returns an appropriate + error message if |pats| <> |branchsign|; extends them if no pattern is given for let-ins in the case of a conjunctive pattern *) -val get_and_check_or_and_pattern : +val get_and_check_or_and_pattern : Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> bool list array -> intro_patterns array -- cgit v1.2.3 From f65f8d5a4d9ba437fa2d8af03e2781d841e53007 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 21 Jan 2016 09:21:23 +0100 Subject: Restore warnings produced by the interpretation of the command line (e.g. with deprecated options such as -byte, etc.) since I guess this is what we expect. Was probably lost in 81eb133d64ac81cb. --- lib/flags.mli | 1 + toplevel/coqtop.ml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/flags.mli b/lib/flags.mli index ab06eda306..69caad5b62 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -90,6 +90,7 @@ val is_universe_polymorphism : unit -> bool val make_polymorphic_flag : bool -> unit val use_polymorphic_flag : unit -> bool +val warn : bool ref val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index afd4ef40e8..cfedff0809 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -35,7 +35,7 @@ let print_header () = ppnl (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); pp_flush () -let warning s = msg_warning (strbrk s) +let warning s = with_option Flags.warn msg_warning (strbrk s) let toploop = ref None -- cgit v1.2.3 From 4953a129858a231e64dec636a3bc15a54a0e771c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 22 Jan 2016 01:36:43 +0100 Subject: Fixing a use of "clear" on an non-existing hypothesis in intro-patterns. It was not detected because of a "bug" in clear checking the existence of the hypothesis only at interpretation time (not at execution time). --- tactics/tactics.ml | 34 +++++++++++++++++++++------------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b88ec69e62..aeb3726a0c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2103,34 +2103,45 @@ let intro_or_and_pattern loc bracketed ll thin tac id = nv_with_let ll) end } -let rewrite_hyp assert_style l2r id = +let rewrite_hyp_then assert_style thin l2r id tac = let rew_on l2r = Hook.get forward_general_rewrite_clause l2r false (mkVar id,NoBindings) in let subst_on l2r x rhs = Hook.get forward_subst_one true x (id,rhs,l2r) in - let clear_var_and_eq c = tclTHEN (clear [id]) (clear [destVar c]) in + let clear_var_and_eq id' = clear [id';id] in + let early_clear id' thin = + List.filter (fun (_,id) -> not (Id.equal id id')) thin in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_betadeltaiota = Tacmach.New.pf_apply whd_betadeltaiota gl in let t = whd_betadeltaiota (type_of (mkVar id)) in - match match_with_equality_type t with + let eqtac, thin = match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then - subst_on l2r (destVar lhs) rhs + let id' = destVar lhs in + subst_on l2r id' rhs, early_clear id' thin else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then - subst_on l2r (destVar rhs) lhs + let id' = destVar rhs in + subst_on l2r id' lhs, early_clear id' thin else - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) + Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + thin | Some (hdcncl,[c]) -> let l2r = not l2r in (* equality of the form eq_true *) if isVar c then + let id' = destVar c in Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) - (Proofview.V82.tactic (clear_var_and_eq c)) + (Proofview.V82.tactic (clear_var_and_eq id')), + early_clear id' thin else - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) + Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + thin | _ -> - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) + Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + thin in + (* Skip the side conditions of the rewriting step *) + Tacticals.New.tclTHENFIRST eqtac (tac thin) end } let prepare_naming loc = function @@ -2256,10 +2267,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with | IntroInjection l' -> intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> - Tacticals.New.tclTHENFIRST - (* Skip the side conditions of the rewriting step *) - (rewrite_hyp style l2r id) - (tac thin None []) + rewrite_hyp_then style thin l2r id (fun thin -> tac thin None []) | IntroApplyOn (f,(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc (IntroIdentifier id) destopt pat in -- cgit v1.2.3 From ccdc62a6b4722c38f2b37cbf21b14e5094255390 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 21 Jan 2016 18:05:55 -0500 Subject: Fix bug #4506. Using betadeltaiota_nolet might produce terms of the form (let x := t in u) a that should be reduced. Maybe a different decomposition/reduction primitive should be used instead. --- pretyping/indrec.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index d5f6e9b301..0588dcc87f 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -155,7 +155,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = | Prod (n,t,c) -> let d = (n,None,t) in make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) - | LetIn (n,b,t,c) -> + | LetIn (n,b,t,c) when List.is_empty largs -> let d = (n,Some b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) | Ind (_,_) -> @@ -166,7 +166,10 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|] else base - | _ -> assert false + | _ -> + let t' = whd_betadeltaiota env sigma p in + if Term.eq_constr p' t' then assert false + else prec env i sign t' in prec env 0 [] in @@ -230,14 +233,17 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = | Prod (n,t,c) -> let d = (n,None,t) in mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) - | LetIn (n,b,t,c) -> + | LetIn (n,b,t,c) when List.is_empty largs -> let d = (n,Some b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in applist(lift i fk,realargs@[arg]) - | _ -> assert false + | _ -> + let t' = whd_betadeltaiota env sigma p in + if Term.eq_constr t' p' then assert false + else prec env i hyps t' in prec env 0 [] in -- cgit v1.2.3 From 5cbcc8fd761df0779f6202fef935f07cfef8a228 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 23 Jan 2016 15:17:29 -0500 Subject: Implement support for universe binder lists in Instance and Program Fixpoint/Definition. --- interp/dumpglob.ml | 2 +- intf/constrexpr.mli | 2 +- parsing/g_vernac.ml4 | 8 ++++---- parsing/pcoq.ml4 | 1 + parsing/pcoq.mli | 1 + printing/ppvernac.ml | 5 +++-- tactics/rewrite.ml | 4 ++-- toplevel/classes.ml | 29 +++++++++++++++++------------ toplevel/classes.mli | 3 ++- toplevel/command.ml | 29 ++++++++++++++++------------- toplevel/obligations.ml | 26 +++++++++++++++++--------- toplevel/obligations.mli | 2 ++ 12 files changed, 67 insertions(+), 45 deletions(-) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 0d9d021c68..44a62ef379 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -248,7 +248,7 @@ let dump_def ty loc secpath id = let dump_definition (loc, id) sec s = dump_def s loc (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) -let dump_constraint ((loc, n), _, _) sec ty = +let dump_constraint (((loc, n),_), _, _) sec ty = match n with | Names.Name id -> dump_definition (loc, id) sec ty | Names.Anonymous -> () diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index dcdbd47f68..a53238dfd8 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -121,7 +121,7 @@ and constr_notation_substitution = constr_expr list list * (** for recursive notations *) local_binder list list (** for binders subexpressions *) -type typeclass_constraint = Name.t located * binding_kind * constr_expr +type typeclass_constraint = (Name.t located * Id.t located list option) * binding_kind * constr_expr and typeclass_context = typeclass_constraint list diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 839f768b98..f3766a7d79 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -192,7 +192,7 @@ let test_plurial_form_types = function (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition; + record_field decl_notation rec_definition pidentref; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -783,10 +783,10 @@ GEXTEND Gram | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: - [ [ name = identref; sup = OPT binders -> - (let (loc,id) = name in (loc, Name id)), + [ [ name = pidentref; sup = OPT binders -> + (let ((loc,id),l) = name in ((loc, Name id),l)), (Option.default [] sup) - | -> (!@loc, Anonymous), [] ] ] + | -> ((!@loc, Anonymous), None), [] ] ] ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 32dbeaa4dd..28dc74e81b 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -315,6 +315,7 @@ module Prim = let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" + let pidentref = Gram.entry_create "Prim.pidentref" let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 24b58775a2..54e6423877 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -163,6 +163,7 @@ module Prim : val ident : Id.t Gram.entry val name : Name.t located Gram.entry val identref : Id.t located Gram.entry + val pidentref : (Id.t located * (Id.t located list) option) Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index d2f59e7b8d..38add9d2c8 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -925,8 +925,9 @@ module Make hov 1 ( (if abst then keyword "Declare" ++ spc () else mt ()) ++ keyword "Instance" ++ - (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | - Anonymous -> mt ()) ++ + (match instid with + | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc () + | (_, Anonymous), _ -> mt ()) ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ pr_constr cl ++ pr_priority pri ++ diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 74bb6d5976..83742bfbdd 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1703,7 +1703,7 @@ let rec strategy_of_ast = function let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) let declare_an_instance n s args = - ((Loc.ghost,Name n), Explicit, + (((Loc.ghost,Name n),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), args)) @@ -1919,7 +1919,7 @@ let add_morphism glob binders m s n = let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = - ((Loc.ghost,Name instance_id), Explicit, + (((Loc.ghost,Name instance_id),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 3a0b5f24f7..f73dd5a2e6 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -101,19 +101,21 @@ let instance_hook k pri global imps ?hook cst = Typeclasses.declare_instance pri (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k pri global imps ?hook id poly uctx term termtype = +let declare_instance_constant k pri global imps ?hook id pl poly evm term termtype = let kind = IsDefinition Instance in - let uctx = + let evm = let levels = Univ.LSet.union (Universes.universes_of_constr termtype) (Universes.universes_of_constr term) in - Universes.restrict_universe_context uctx levels + Evd.restrict_universe_context evm levels in + let pl, uctx = Evd.universe_context ?names:pl evm in let entry = - Declare.definition_entry ~types:termtype ~poly ~univs:(Univ.ContextSet.to_context uctx) term + Declare.definition_entry ~types:termtype ~poly ~univs:uctx term in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; + Universes.register_universe_binders (ConstRef kn) pl; instance_hook k pri global imps ?hook (ConstRef kn); id @@ -121,7 +123,9 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in - let evars = ref (Evd.from_env env) in + let ((loc, instid), pl) = instid in + let uctx = Evd.make_evar_universe_context env pl in + let evars = ref (Evd.from_ctx uctx) in let tclass, ids = match bk with | Implicit -> @@ -158,7 +162,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro cl, u, c', ctx', ctx, len, imps, args in let id = - match snd instid with + match instid with Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then @@ -185,11 +189,13 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro nf t in Evarutil.check_evars env Evd.empty !evars termtype; - let pl, ctx = Evd.universe_context !evars in + let pl, ctx = Evd.universe_context ?names:pl !evars in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) - in instance_hook k None global imps ?hook (ConstRef cst); id + in + Universes.register_universe_binders (ConstRef cst) pl; + instance_hook k None global imps ?hook (ConstRef cst); id end else ( let props = @@ -282,9 +288,8 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro in let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then - let ctx = Evd.universe_context_set evm in - declare_instance_constant k pri global imps ?hook id - poly ctx (Option.get term) termtype + declare_instance_constant k pri global imps ?hook id pl + poly evm (Option.get term) termtype else if !refine_instance || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then @@ -304,7 +309,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context evm in ignore (Obligations.add_definition id ?term:constr - typ ctx ~kind:(Global,poly,Instance) ~hook obls); + ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls); id else (Flags.silently diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 24c51b31a3..d600b3104f 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -31,8 +31,9 @@ val declare_instance_constant : Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) + Id.t Loc.located list option -> bool -> (* polymorphic *) - Univ.universe_context_set -> (* Universes *) + Evd.evar_map -> (* Universes *) Constr.t -> (** body *) Term.types -> (** type *) Names.Id.t diff --git a/toplevel/command.ml b/toplevel/command.ml index 5d2a7638a0..8f7c389975 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -177,7 +177,9 @@ let _ = Obligations.declare_definition_ref := (fun i k c imps hook -> declare_definition i k c [] imps hook) let do_definition ident k pl bl red_option c ctypopt hook = - let (ce, evd, pl, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in + let (ce, evd, pl', imps as def) = + interp_definition pl bl (pi2 k) red_option c ctypopt + in if Flags.is_program_mode () then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in @@ -194,9 +196,9 @@ let do_definition ident k pl bl red_option c ctypopt hook = let ctx = Evd.evar_universe_context evd in let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in ignore(Obligations.add_definition - ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) + ident ~term:c cty ctx ?pl ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in - ignore(declare_definition ident k ce pl imps + ignore(declare_definition ident k ce pl' imps (Lemmas.mk_hook (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) @@ -905,10 +907,11 @@ let nf_evar_context sigma ctx = List.map (fun (n, b, t) -> (n, Option.map (Evarutil.nf_evar sigma) b, Evarutil.nf_evar sigma t)) ctx -let build_wellfounded (recname,n,bl,arityc,body) r measure notation = +let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in - let evdref = ref (Evd.from_env env) in + let ctx = Evd.make_evar_universe_context env pl in + let evdref = ref (Evd.from_ctx ctx) in let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in @@ -1014,9 +1017,9 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let hook l gr _ = let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in - let pl, univs = Evd.universe_context !evdref in + let pl, univs = Evd.universe_context ?names:pl !evdref in (*FIXME poly? *) - let ce = definition_entry ~types:ty ~univs (Evarutil.nf_evar !evdref body) in + let ce = definition_entry ~poly ~types:ty ~univs (Evarutil.nf_evar !evdref body) in (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -1040,7 +1043,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp in let ctx = Evd.evar_universe_context !evdref in - ignore(Obligations.add_definition recname ~term:evars_def + ignore(Obligations.add_definition recname ~term:evars_def ?pl evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = @@ -1261,22 +1264,22 @@ let do_program_recursive local p fixkind fixl ntns = | Obligations.IsFixpoint _ -> (local, p, Fixpoint) | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) in - Obligations.add_mutual_definitions defs ~kind ctx ntns fixkind + Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with - | [(n, CWfRec r)], [((((_,id),_),_,bl,typ,def),ntn)] -> + | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] -> let recarg = match n with | Some n -> mkIdentC (snd n) | None -> errorlabstrm "do_program_fixpoint" (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, n, bl, typ, out_def def) r recarg ntn + in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn - | [(n, CMeasureRec (m, r))], [((((_,id),_),_,bl,typ,def),ntn)] -> - build_wellfounded (id, n, bl, typ, out_def def) + | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> + build_wellfounded (id, pl, n, bl, typ, out_def def) poly (Option.default (CRef (lt_ref,None)) r) m ntn | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 314789ced6..7e0d30a63e 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -311,6 +311,7 @@ type program_info_aux = { prg_body: constr; prg_type: constr; prg_ctx: Evd.evar_universe_context; + prg_pl: Id.t Loc.located list option; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -510,15 +511,21 @@ let declare_definition prg = (Evd.evar_universe_context_subst prg.prg_ctx) in let opaque = prg.prg_opaque in let fix_exn = Stm.get_fix_exn () in + let pl, ctx = + Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in let ce = definition_entry ~fix_exn ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) in - progmap_remove prg; + let () = progmap_remove prg in + let cst = !declare_definition_ref prg.prg_name - prg.prg_kind ce prg.prg_implicits - (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) + prg.prg_kind ce prg.prg_implicits + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) + in + Universes.register_universe_binders cst pl; + cst open Pp @@ -644,7 +651,8 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls impls kind reduce hook = +let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind + notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -664,7 +672,7 @@ let init_prog_info ?(opaque = false) sign n b t ctx deps fixkind notations obls obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; - prg_ctx = ctx; + prg_ctx = ctx; prg_pl = pl; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; @@ -995,11 +1003,11 @@ let show_term n = Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) -let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic +let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info sign ~opaque n term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -1014,13 +1022,13 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) +let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let sign = Decls.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info sign ~opaque n (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n (Ephemeron.create prg)) l; let _defined = diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index b2320a578a..e257da0161 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -64,6 +64,7 @@ val get_proofs_transparency : unit -> bool val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> Evd.evar_universe_context -> + ?pl:(Id.t Loc.located list) -> (* Universe binders *) ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> @@ -81,6 +82,7 @@ val add_mutual_definitions : (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> Evd.evar_universe_context -> + ?pl:(Id.t Loc.located list) -> (* Universe binders *) ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> -- cgit v1.2.3 From 6a046f8d3e33701d70e2a391741e65564cc0554d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 23 Jan 2016 15:55:43 -0500 Subject: Fix bug #4519: oops, global shadowed local universe level bindings. --- pretyping/pretyping.ml | 10 +++++----- test-suite/bugs/closed/4519.v | 21 +++++++++++++++++++++ 2 files changed, 26 insertions(+), 5 deletions(-) create mode 100644 test-suite/bugs/closed/4519.v diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ac0104d9f8..b33084a423 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -138,12 +138,12 @@ let interp_universe_level_name evd (loc,s) = in evd, level else try - let id = - try Id.of_string s with _ -> raise Not_found in - evd, Idmap.find id names + let level = Evd.universe_of_name evd s in + evd, level with Not_found -> - try let level = Evd.universe_of_name evd s in - evd, level + try + let id = try Id.of_string s with _ -> raise Not_found in + evd, Idmap.find id names with Not_found -> if not (is_strict_universe_declarations ()) then new_univ_level_variable ~name:s univ_rigid evd diff --git a/test-suite/bugs/closed/4519.v b/test-suite/bugs/closed/4519.v new file mode 100644 index 0000000000..ccbc47d20f --- /dev/null +++ b/test-suite/bugs/closed/4519.v @@ -0,0 +1,21 @@ +Set Universe Polymorphism. +Section foo. + Universe i. + Context (foo : Type@{i}) (bar : Type@{i}). + Definition qux@{i} (baz : Type@{i}) := foo -> bar. +End foo. +Set Printing Universes. +Print qux. (* qux@{Top.42 Top.43} = +fun foo bar _ : Type@{Top.42} => foo -> bar + : Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} +(* Top.42 Top.43 |= *) +(* This is wrong; the first two types are equal, but the last one is not *) + +qux is universe polymorphic +Argument scopes are [type_scope type_scope type_scope] + *) +Check qux nat nat nat : Set. +Check qux nat nat Set : Set. (* Error: +The term "qux@{Top.50 Top.51} ?T ?T0 Set" has type "Type@{Top.50}" while it is +expected to have type "Set" +(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *) \ No newline at end of file -- cgit v1.2.3 From b582db2ecbb3f7f1315fedc50b0009f62f5c59ad Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 23 Jan 2016 17:28:34 -0500 Subject: Fix bug #4503: mixing universe polymorphic and monomorphic variables and definitions in sections is unsupported. --- library/declare.ml | 4 ++-- library/lib.ml | 22 ++++++++++++++------- library/lib.mli | 5 +++-- test-suite/bugs/closed/4503.v | 37 +++++++++++++++++++++++++++++++++++ test-suite/bugs/closed/HoTT_coq_002.v | 2 +- test-suite/bugs/closed/HoTT_coq_020.v | 4 ++-- theories/Logic/Hurkens.v | 3 ++- 7 files changed, 62 insertions(+), 15 deletions(-) create mode 100644 test-suite/bugs/closed/4503.v diff --git a/library/declare.ml b/library/declare.ml index 5f6f0fe45e..c9d5fdbe2f 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -158,7 +158,7 @@ let cache_constant ((sp,kn), obj) = assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); let cst = Global.lookup_constant kn' in - add_section_constant (cst.const_proj <> None) kn' cst.const_hyps; + add_section_constant cst.const_polymorphic kn' cst.const_hyps; Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps; add_constant_kind (constant_of_kn kn) obj.cst_kind @@ -325,7 +325,7 @@ let cache_inductive ((sp,kn),(dhyps,mie)) = let kn' = Global.add_mind dir id mie in assert (eq_mind kn' (mind_of_kn kn)); let mind = Global.lookup_mind kn' in - add_section_kn kn' mind.mind_hyps; + add_section_kn mind.mind_polymorphic kn' mind.mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names diff --git a/library/lib.ml b/library/lib.ml index ff89291679..e4617cafb6 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -408,17 +408,24 @@ let add_section () = sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty), (Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab +let check_same_poly p vars = + let pred = function Context _ -> p = false | Variable (_, _, poly, _) -> p != poly in + if List.exists pred vars then + error "Cannot mix universe polymorphic and monomorphic declarations in sections." + let add_section_variable id impl poly ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> - sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl + check_same_poly poly vars; + sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl let add_section_context ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> - sectab := (Context ctx :: vars,repl,abs)::sl + check_same_poly true vars; + sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = let rec aux = function @@ -443,10 +450,11 @@ let instance_from_variable_context sign = let named_of_variable_context ctx = List.map (fun (id,_,b,t) -> (id,b,t)) ctx -let add_section_replacement f g hyps = +let add_section_replacement f g poly hyps = match !sectab with | [] -> () | (vars,exps,abs)::sl -> + let () = check_same_poly poly vars in let sechyps,ctx = extract_hyps (vars,hyps) in let ctx = Univ.ContextSet.to_context ctx in let subst, ctx = Univ.abstract_universes true ctx in @@ -454,13 +462,13 @@ let add_section_replacement f g hyps = sectab := (vars,f (Univ.UContext.instance ctx,args) exps, g (sechyps,subst,ctx) abs)::sl -let add_section_kn kn = +let add_section_kn poly kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in - add_section_replacement f f + add_section_replacement f f poly -let add_section_constant is_projection kn = +let add_section_constant poly kn = let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f f + add_section_replacement f f poly let replacement_context () = pi2 (List.hd !sectab) diff --git a/library/lib.mli b/library/lib.mli index 29fc7cd24b..513c48549e 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -178,9 +178,10 @@ val is_in_section : Globnames.global_reference -> bool val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit val add_section_context : Univ.universe_context_set -> unit -val add_section_constant : bool (* is_projection *) -> +val add_section_constant : Decl_kinds.polymorphic -> Names.constant -> Context.named_context -> unit -val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit +val add_section_kn : Decl_kinds.polymorphic -> + Names.mutual_inductive -> Context.named_context -> unit val replacement_context : unit -> Opaqueproof.work_list (** {6 Discharge: decrease the section level if in the current section } *) diff --git a/test-suite/bugs/closed/4503.v b/test-suite/bugs/closed/4503.v new file mode 100644 index 0000000000..f54d6433d8 --- /dev/null +++ b/test-suite/bugs/closed/4503.v @@ -0,0 +1,37 @@ +Require Coq.Classes.RelationClasses. + +Class PreOrder (A : Type) (r : A -> A -> Type) : Type := +{ refl : forall x, r x x }. + +(* FAILURE 1 *) + +Section foo. + Polymorphic Universes A. + Polymorphic Context {A : Type@{A}} {rA : A -> A -> Prop} {PO : PreOrder A rA}. + + Fail Definition foo := PO. +End foo. + + +Module ILogic. + +Set Universe Polymorphism. + +(* Logical connectives *) +Class ILogic@{L} (A : Type@{L}) : Type := mkILogic +{ + lentails: A -> A -> Prop; + lentailsPre:> RelationClasses.PreOrder lentails +}. + + +End ILogic. + +Set Printing Universes. + +(* There is stil a problem if the class is universe polymorphic *) +Section Embed_ILogic_Pre. + Polymorphic Universes A T. + Fail Context {A : Type@{A}} {ILA: ILogic.ILogic@{A} A}. + +End Embed_ILogic_Pre. \ No newline at end of file diff --git a/test-suite/bugs/closed/HoTT_coq_002.v b/test-suite/bugs/closed/HoTT_coq_002.v index ba69f6b158..dba4d5998f 100644 --- a/test-suite/bugs/closed/HoTT_coq_002.v +++ b/test-suite/bugs/closed/HoTT_coq_002.v @@ -9,7 +9,7 @@ Section SpecializedFunctor. (* Variable objC : Type. *) Context `(C : SpecializedCategory objC). - Polymorphic Record SpecializedFunctor := { + Record SpecializedFunctor := { ObjectOf' : objC -> Type; ObjectC : Object C }. diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v index 4938b80f9b..008fb72c4e 100644 --- a/test-suite/bugs/closed/HoTT_coq_020.v +++ b/test-suite/bugs/closed/HoTT_coq_020.v @@ -59,8 +59,8 @@ Polymorphic Definition FunctorFrom0 objC (C : Category objC) : Functor Cat0 C := Build_Functor Cat0 C (fun x => match x with end). Section Law0. - Variable objC : Type. - Variable C : Category objC. + Polymorphic Variable objC : Type. + Polymorphic Variable C : Category objC. Set Printing All. Set Printing Universes. diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index 8ded74763e..841f843c07 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -631,6 +631,8 @@ End NoRetractFromTypeToProp. Module TypeNeqSmallType. +Unset Universe Polymorphism. + Section Paradox. (** ** Universe [U] is equal to one of its elements. *) @@ -655,7 +657,6 @@ Proof. reflexivity. Qed. - Theorem paradox : False. Proof. Generic.paradox p. -- cgit v1.2.3 From 4b1103dc38754917e12bf04feca446e02cf55f07 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 12:17:21 +0100 Subject: Fixing bug #4511: evar tactic can create non-typed evars. --- tactics/evar_tactics.ml | 3 +++ test-suite/bugs/closed/4511.v | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 test-suite/bugs/closed/4511.v diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 202aca0de1..2887fc2284 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -71,6 +71,9 @@ let let_evar name typ = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in + let sigma = ref sigma in + let _ = Typing.sort_of env sigma typ in + let sigma = !sigma in let id = match name with | Names.Anonymous -> let id = Namegen.id_of_name_using_hdchar env typ name in diff --git a/test-suite/bugs/closed/4511.v b/test-suite/bugs/closed/4511.v new file mode 100644 index 0000000000..0cdb3aee4f --- /dev/null +++ b/test-suite/bugs/closed/4511.v @@ -0,0 +1,3 @@ +Goal True. +Fail evar I. + -- cgit v1.2.3 From cb30837323aa462df24ad6668790f67b9bf20b5d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 12:35:49 +0100 Subject: Fixing bug #4495: Failed assertion in metasyntax.ml. We simply handle the "break" in error messages. Not sure it is the proper bugfix though, we may want to be able to add breaks in such recursive notations. --- test-suite/bugs/closed/4495.v | 1 + toplevel/metasyntax.ml | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4495.v diff --git a/test-suite/bugs/closed/4495.v b/test-suite/bugs/closed/4495.v new file mode 100644 index 0000000000..8b032db5f5 --- /dev/null +++ b/test-suite/bugs/closed/4495.v @@ -0,0 +1 @@ +Fail Notation "'forall' x .. y ',' P " := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder). diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index ae82b64e87..231b22e255 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -540,10 +540,15 @@ let add_break_if_none n = function | l -> UnpCut (PpBrk(n,0)) :: l let check_open_binder isopen sl m = + let pr_token = function + | Terminal s -> str s + | Break n -> str "␣" + | _ -> assert false + in if isopen && not (List.is_empty sl) then errorlabstrm "" (str "as " ++ pr_id m ++ str " is a non-closed binder, no such \"" ++ - prlist_with_sep spc (function Terminal s -> str s | _ -> assert false) sl + prlist_with_sep spc pr_token sl ++ strbrk "\" is allowed to occur.") (* Heuristics for building default printing rules *) -- cgit v1.2.3 From e7852396a452f446135183ec3e1743b731d781c0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 14:18:40 +0100 Subject: Adding a test for bug #4378. --- test-suite/bugs/closed/4378.v | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 test-suite/bugs/closed/4378.v diff --git a/test-suite/bugs/closed/4378.v b/test-suite/bugs/closed/4378.v new file mode 100644 index 0000000000..9d59165562 --- /dev/null +++ b/test-suite/bugs/closed/4378.v @@ -0,0 +1,9 @@ +Tactic Notation "epose" open_constr(a) := + let a' := fresh in + pose a as a'. +Tactic Notation "epose2" open_constr(a) tactic3(tac) := + let a' := fresh in + pose a as a'. +Goal True. + epose _. Undo. + epose2 _ idtac. -- cgit v1.2.3 From 030ef2f015e5c592ea7599f0f98a715873c1e4d0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 15:15:16 +0100 Subject: Fixing bug #3826: "Incompatible module types" is uninformative. --- toplevel/himsg.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 7ddfd46cd1..89c33cb6fe 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -890,7 +890,17 @@ let explain_is_a_functor () = str "Illegal use of a functor." let explain_incompatible_module_types mexpr1 mexpr2 = - str "Incompatible module types." + let open Declarations in + let rec get_arg = function + | NoFunctor _ -> 0 + | MoreFunctor (_, _, ty) -> succ (get_arg ty) + in + let len1 = get_arg mexpr1.mod_type in + let len2 = get_arg mexpr2.mod_type in + if len1 <> len2 then + str "Incompatible module types: module expects " ++ int len2 ++ + str " arguments, found " ++ int len1 ++ str "." + else str "Incompatible module types." let explain_not_equal_module_paths mp1 mp2 = str "Non equal modules." -- cgit v1.2.3 From f17096fa9eff103f40e6d381ebeb4313002fa378 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 16:25:38 +0100 Subject: Fixing bug #4373: coqdep does not know about .vio files. --- tools/coqdep_common.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 58c8e884cc..a90264e261 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -504,15 +504,15 @@ let add_caml_known phys_dir _ f = | _ -> () let add_coqlib_known recur phys_dir log_dir f = - match get_extension f [".vo"] with - | (basename,".vo") -> + match get_extension f [".vo"; ".vio"] with + | (basename, (".vo" | ".vio")) -> let name = log_dir@[basename] in let paths = if recur then suffixes name else [name] in List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () let add_known recur phys_dir log_dir f = - match get_extension f [".v";".vo"] with + match get_extension f [".v"; ".vo"; ".vio"] with | (basename,".v") -> let name = log_dir@[basename] in let file = phys_dir//basename in @@ -521,7 +521,7 @@ let add_known recur phys_dir log_dir f = let paths = List.tl (suffixes name) in let iter n = safe_hash_add compare_file clash_v vKnown (n, (file, false)) in List.iter iter paths - | (basename,".vo") when not(!option_boot) -> + | (basename, (".vo" | ".vio")) when not(!option_boot) -> let name = log_dir@[basename] in let paths = if recur then suffixes name else [name] in List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths -- cgit v1.2.3 From 5361b02a96704a226b713b6040b67ca01de808fa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 18:00:34 +0100 Subject: Tentative fix for bug #4522: Incorrect "Warning..." on windows. --- tools/coq_makefile.ml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 478cf8875a..c4b7618270 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -99,7 +99,13 @@ let string_prefix a b = let is_prefix dir1 dir2 = let l1 = String.length dir1 in let l2 = String.length dir2 in - dir1 = dir2 || (l1 < l2 && String.sub dir2 0 l1 = dir1 && dir2.[l1] = '/') + let sep = Filename.dir_sep in + if dir1 = dir2 then true + else if l1 + String.length sep <= l2 then + let dir1' = String.sub dir2 0 l1 in + let sep' = String.sub dir2 l1 (String.length sep) in + dir1' = dir1 && sep' = sep + else false let physical_dir_of_logical_dir ldir = let le = String.length ldir - 1 in -- cgit v1.2.3 From 40cc1067dc5353d43ea2f6643cd8ca954e3e8afa Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 26 Jan 2016 17:22:08 +0100 Subject: Fixing bde12b70 about reporting ill-formed constructor. For instance, in Inductive I : nat -> nat -> Prop := C : forall z, let '(x,y) := z in x + y = 0. the computation of the number of arguments to I was made wrong in bde12b70. --- kernel/indtypes.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index f9c2a7b0d5..49e8583158 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -336,7 +336,7 @@ let typecheck_inductive env mie = type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int - | LocalNotConstructor of rel_context * constr list + | LocalNotConstructor of rel_context * int | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -355,11 +355,10 @@ let explain_ind_err id ntyp env nbpar c err = | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) - | LocalNotConstructor (paramsctxt,args)-> + | LocalNotConstructor (paramsctxt,nargs)-> let nparams = rel_context_nhyps paramsctxt in raise (InductiveError - (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams, - List.length args - nparams))) + (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams,nargs))) | LocalNonPar (n,i,l) -> raise (InductiveError (NonPar (env,c',n,mkRel i, mkRel (l+nbpar)))) @@ -548,7 +547,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname begin match hd with | Rel j when Int.equal j (n + ntypes - i - 1) -> check_correct_par ienv hyps (ntypes - i) largs - | _ -> raise (IllFormedInd (LocalNotConstructor(hyps,largs))) + | _ -> raise (IllFormedInd (LocalNotConstructor(hyps,nargs))) end else if not (List.for_all (noccur_between n ntypes) largs) -- cgit v1.2.3 From 22a2cc1897f0d9f568ebfb807673e84f6ada491a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 27 Jan 2016 09:36:47 +0100 Subject: Fix bug #4537: Coq 8.5 is slower in typeclass resolution. The performance enhancement introduced by a895b2c0 for non-polymorphic hints was actually causing a huge regression in the polymorphic case (and was marked as such). We fix this by only substituting the metas from the evarmap instead of the whole evarmap. --- pretyping/evd.ml | 4 ++++ pretyping/evd.mli | 1 + tactics/auto.ml | 13 ++++++++----- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 01083142b7..5441145189 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -1467,6 +1467,10 @@ let map_metas_fvalue f evd = in set_metas evd (Metamap.smartmap map evd.metas) +let map_metas f evd = + let map cl = map_clb f cl in + set_metas evd (Metamap.smartmap map evd.metas) + let meta_opt_fvalue evd mv = match Metamap.find mv evd.metas with | Clval(_,b,_) -> Some b diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 0b4f185368..9cfca02ed8 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -455,6 +455,7 @@ val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map val undefined_metas : evar_map -> metavariable list val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map +val map_metas : (constr -> constr) -> evar_map -> evar_map type metabinding = metavariable * constr * instance_status diff --git a/tactics/auto.ml b/tactics/auto.ml index 2d92387c03..647ff97148 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -85,11 +85,14 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in let map c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - let clenv = { clenv with evd = evd ; env = Proofview.Goal.env gl } in - (** FIXME: We're being inefficient here because we substitute the whole - evar map instead of just its metas, which are the only ones - mentioning the old universes. *) - Clenv.map_clenv map clenv, map c + (** Only metas are mentioning the old universes. *) + let clenv = { + templval = Evd.map_fl map clenv.templval; + templtyp = Evd.map_fl map clenv.templtyp; + evd = Evd.map_metas map evd; + env = Proofview.Goal.env gl; + } in + clenv, map c else let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in { clenv with evd = evd ; env = Proofview.Goal.env gl }, c -- cgit v1.2.3 From e93b9402823cbb9d4713974c51b89d77a7f83b95 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 1 Feb 2016 18:34:48 +0100 Subject: Infering atomic ML entries from their grammar. --- grammar/tacextend.ml4 | 48 +------------------------------------------ toplevel/metasyntax.ml | 54 +++++++++++++++++++++++++++++++++++++++++++------ toplevel/metasyntax.mli | 4 +--- 3 files changed, 50 insertions(+), 56 deletions(-) diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index cca734720f..ef7cdbfa3a 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -86,14 +86,6 @@ let make_prod_item = function let mlexpr_of_clause cl = mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl -let rec make_tags loc = function - | [] -> <:expr< [] >> - | ExtNonTerminal (t, _, p) :: l -> - let l = make_tags loc l in - let t = mlexpr_of_argtype loc t in - <:expr< [ $t$ :: $l$ ] >> - | _::l -> make_tags loc l - let make_one_printing_rule (pt,_,e) = let level = mlexpr_of_int 0 in (* only level 0 supported here *) let loc = MLast.loc_of_expr e in @@ -103,41 +95,6 @@ let make_one_printing_rule (pt,_,e) = let make_printing_rule r = mlexpr_of_list make_one_printing_rule r -let make_empty_check = function -| ExtNonTerminal (t, e, _)-> - let is_extra = match t with ExtraArgType _ -> true | _ -> false in - if is_possibly_empty e || is_extra then - (* This possibly parses epsilon *) - let wit = make_wit loc t in - let rawwit = make_rawwit loc t in - <:expr< - match Genarg.default_empty_value $wit$ with - [ None -> raise Exit - | Some v -> - Tacintern.intern_genarg Tacintern.fully_empty_glob_sign - (Genarg.in_gen $rawwit$ v) ] >> - else - (* This does not parse epsilon (this Exit is static time) *) - raise Exit -| ExtTerminal _ -> - (* Idem *) - raise Exit - -let rec possibly_atomic loc = function -| [] -> [] -| ((ExtNonTerminal _ :: _ | []), _, _) :: rem -> - (** This is not parsed by the TACTIC EXTEND rules *) - assert false -| (ExtTerminal s :: prods, _, _) :: rem -> - let entry = - try - let l = List.map make_empty_check prods in - let l = mlexpr_of_list (fun x -> x) l in - (s, <:expr< try Some $l$ with [ Exit -> None ] >>) - with Exit -> (s, <:expr< None >>) - in - entry :: possibly_atomic loc rem - (** Special treatment of constr entries *) let is_constr_gram = function | ExtTerminal _ -> false @@ -193,10 +150,7 @@ let declare_tactic loc s c cl = match cl with let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let pp = make_printing_rule cl in let gl = mlexpr_of_clause cl in - let atom = - mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x)) - (possibly_atomic loc cl) in - let obj = <:expr< fun () -> Metasyntax.add_ml_tactic_notation $se$ $gl$ $atom$ >> in + let obj = <:expr< fun () -> Metasyntax.add_ml_tactic_notation $se$ $gl$ >> in declare_str_items loc [ <:str_item< do { try do { diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 5a47fc0ea1..0d002aa8e9 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -149,8 +149,6 @@ let add_tactic_notation (local,n,prods,e) = (**********************************************************************) (* ML Tactic entries *) -type atomic_entry = string * Genarg.glob_generic_argument list option - type ml_tactic_grammar_obj = { mltacobj_name : Tacexpr.ml_tactic_name; (** ML-side unique name *) @@ -158,12 +156,56 @@ type ml_tactic_grammar_obj = { (** Grammar rules generating the ML tactic. *) } +exception NonEmptyArgument + +let default_empty_value wit = match Genarg.default_empty_value wit with +| None -> raise NonEmptyArgument +| Some v -> v + +let rec empty_value : type a b c s. (a, b, c) Genarg.genarg_type -> (s, a) entry_key -> a = +fun wit key -> match key with +| Alist1 key -> + begin match wit with + | Genarg.ListArg wit -> [empty_value wit key] + | Genarg.ExtraArg _ -> default_empty_value wit + end +| Alist1sep (key, _) -> + begin match wit with + | Genarg.ListArg wit -> [empty_value wit key] + | Genarg.ExtraArg _ -> default_empty_value wit + end +| Alist0 _ -> [] +| Alist0sep (_, _) -> [] +| Amodifiers _ -> [] +| Aopt _ -> None +| Aentry _ -> default_empty_value wit +| Aentryl (_, _) -> default_empty_value wit + +| Atoken _ -> raise NonEmptyArgument +| Aself -> raise NonEmptyArgument +| Anext -> raise NonEmptyArgument + (** ML tactic notations whose use can be restricted to an identifier are added as true Ltac entries. *) let extend_atomic_tactic name entries = - let add_atomic i (id, args) = match args with + let map_prod prods = + let (hd, rem) = match prods with + | GramTerminal s :: rem -> (s, rem) + | _ -> assert false (** Not handled by the ML extension syntax *) + in + let empty_value = function + | GramTerminal s -> raise NonEmptyArgument + | GramNonTerminal (_, typ, e) -> + let Genarg.Rawwit wit = typ in + let def = Genarg.in_gen typ (empty_value wit e) in + Tacintern.intern_genarg Tacintern.fully_empty_glob_sign def + in + try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None + in + let entries = List.map map_prod entries in + let add_atomic i args = match args with | None -> () - | Some args -> + | Some (id, args) -> let open Tacexpr in let args = List.map (fun a -> TacGeneric a) args in let entry = { mltac_name = name; mltac_index = i } in @@ -186,13 +228,13 @@ let inMLTacticGrammar : ml_tactic_grammar_obj -> obj = subst_function = (fun (_, o) -> o); } -let add_ml_tactic_notation name prods atomic = +let add_ml_tactic_notation name prods = let obj = { mltacobj_name = name; mltacobj_prod = prods; } in Lib.add_anonymous_leaf (inMLTacticGrammar obj); - extend_atomic_tactic name atomic + extend_atomic_tactic name prods (**********************************************************************) (* Printing grammar entries *) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 826886f678..5d01405b27 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -21,10 +21,8 @@ val add_tactic_notation : locality_flag * int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit -type atomic_entry = string * Genarg.glob_generic_argument list option - val add_ml_tactic_notation : ml_tactic_name -> - Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> atomic_entry list -> unit + Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit (** Adding a (constr) notation in the environment*) -- cgit v1.2.3 From 292e205138ca11c3dce37d48cb34ef4172f6fa06 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 2 Feb 2016 10:28:16 +0100 Subject: Removing a source of type-unsafeness in Pcoq. --- parsing/egramcoq.ml | 18 +++++++++--------- parsing/pcoq.mli | 3 --- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index e9c3a7073d..465073b7aa 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -387,16 +387,16 @@ let create_ltac_quotation name cast wit e = let () = ltac_quotations := String.Set.add name !ltac_quotations in (* let level = Some "1" in *) let level = None in - let assoc = Some (of_coq_assoc Extend.RightA) in - let rule = [ - gram_token_of_string name; - gram_token_of_string ":"; - symbol_of_prod_entry_key (Aentry (name_of_entry e)); - ] in + let assoc = Some Extend.RightA in + let rule = + Next (Next (Next (Stop, + Atoken (Lexer.terminal name)), + Atoken (Lexer.terminal ":")), + Aentry (name_of_entry e)) + in let action v _ _ loc = - let loc = !@loc in let arg = TacGeneric (Genarg.in_gen (Genarg.rawwit wit) (cast (loc, v))) in TacArg (loc, arg) in - let gram = (level, assoc, [rule, Gram.action action]) in - maybe_uncurry (Gram.extend Tactic.tactic_expr) (None, [gram]) + let gram = (level, assoc, [Rule (rule, action)]) in + Pcoq.grammar_extend Tactic.tactic_expr None (None, [gram]) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 9b3a96975f..b26c3044bd 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -274,9 +274,6 @@ val name_of_entry : 'a Gram.entry -> 'a Entry.t (** Binding general entry keys to symbols *) -val symbol_of_prod_entry_key : - ('self, 'a) entry_key -> Gram.symbol - type 's entry_name = EntryName : 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name -- cgit v1.2.3 From 7eeec8f82d96a71929289b0b9401a1b96e1d3dda Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 10:26:28 +0100 Subject: More compact representation for evar resolvability flag. This patch was proposed by JH in bug report #4547. --- pretyping/typeclasses.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 3be98a1ae2..bb475cc554 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -495,15 +495,18 @@ let is_instance = function let resolvable = Store.field () let set_resolvable s b = - Store.set s resolvable b + if b then Store.remove s resolvable + else Store.set s resolvable () let is_resolvable evi = assert (match evi.evar_body with Evar_empty -> true | _ -> false); - Option.default true (Store.get evi.evar_extra resolvable) + Option.is_empty (Store.get evi.evar_extra resolvable) let mark_resolvability_undef b evi = - let t = Store.set evi.evar_extra resolvable b in - { evi with evar_extra = t } + if is_resolvable evi = b then evi + else + let t = set_resolvable evi.evar_extra b in + { evi with evar_extra = t } let mark_resolvability b evi = assert (match evi.evar_body with Evar_empty -> true | _ -> false); -- cgit v1.2.3 From 0ee0b7d2f2365da6e63bc2e94d66f9c5fe1ebe6a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 11:28:34 +0100 Subject: Opacifying the type of evar naming structure in Evd. --- pretyping/evd.ml | 124 +++++++++++++++++++++++++++++++++---------------------- 1 file changed, 74 insertions(+), 50 deletions(-) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 5441145189..8be09a7821 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -575,34 +575,28 @@ type evar_constraint = conv_pb * Environ.env * constr * constr module EvMap = Evar.Map -type evar_map = { - (** Existential variables *) - defn_evars : evar_info EvMap.t; - undf_evars : evar_info EvMap.t; - evar_names : Id.t EvMap.t * existential_key Idmap.t; - (** Universes *) - universes : evar_universe_context; - (** Conversion problems *) - conv_pbs : evar_constraint list; - last_mods : Evar.Set.t; - (** Metas *) - metas : clbinding Metamap.t; - (** Interactive proofs *) - effects : Safe_typing.private_constants; - future_goals : Evar.t list; (** list of newly created evars, to be - eventually turned into goals if not solved.*) - principal_future_goal : Evar.t option; (** if [Some e], [e] must be - contained - [future_goals]. The evar - [e] will inherit - properties (now: the - name) of the evar which - will be instantiated with - a term containing [e]. *) - extras : Store.t; -} +module EvNames : +sig -(*** Lifting primitive from Evar.Map. ***) +open Misctypes + +type t + +val empty : t +val add_name_newly_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t +val add_name_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t +val remove_name_defined : Evar.t -> t -> t +val rename : Evar.t -> Id.t -> t -> t +val reassign_name_defined : Evar.t -> Evar.t -> t -> t +val ident : Evar.t -> t -> Id.t +val key : Id.t -> t -> Evar.t + +end = +struct + +type t = Id.t EvMap.t * existential_key Idmap.t + +let empty = (EvMap.empty, Idmap.empty) let add_name_newly_undefined naming evk evi (evtoid,idtoev) = let id = match naming with @@ -630,29 +624,65 @@ let remove_name_defined evk (evtoid,idtoev) = let id = EvMap.find evk evtoid in (EvMap.remove evk evtoid, Idmap.remove id idtoev) -let remove_name_possibly_already_defined evk evar_names = - try remove_name_defined evk evar_names - with Not_found -> evar_names - -let rename evk id evd = - let (evtoid,idtoev) = evd.evar_names in +let rename evk id (evtoid, idtoev) = let id' = EvMap.find evk evtoid in if Idmap.mem id idtoev then anomaly (str "Evar name already in use"); - { evd with evar_names = - (EvMap.add evk id evtoid (* overwrite old name *), - Idmap.add id evk (Idmap.remove id' idtoev)) } + (EvMap.add evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev)) let reassign_name_defined evk evk' (evtoid,idtoev) = let id = EvMap.find evk evtoid in (EvMap.add evk' id (EvMap.remove evk evtoid), Idmap.add id evk' (Idmap.remove id idtoev)) +let ident evk (evtoid, _) = + try EvMap.find evk evtoid + with Not_found -> + (* Unnamed (non-dependent) evar *) + add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk)) + +let key id (_, idtoev) = + Idmap.find id idtoev + +end + +type evar_map = { + (** Existential variables *) + defn_evars : evar_info EvMap.t; + undf_evars : evar_info EvMap.t; + evar_names : EvNames.t; + (** Universes *) + universes : evar_universe_context; + (** Conversion problems *) + conv_pbs : evar_constraint list; + last_mods : Evar.Set.t; + (** Metas *) + metas : clbinding Metamap.t; + (** Interactive proofs *) + effects : Safe_typing.private_constants; + future_goals : Evar.t list; (** list of newly created evars, to be + eventually turned into goals if not solved.*) + principal_future_goal : Evar.t option; (** if [Some e], [e] must be + contained + [future_goals]. The evar + [e] will inherit + properties (now: the + name) of the evar which + will be instantiated with + a term containing [e]. *) + extras : Store.t; +} + +(*** Lifting primitive from Evar.Map. ***) + +let rename evk id evd = + { evd with evar_names = EvNames.rename evk id evd.evar_names } + let add d e i = match i.evar_body with | Evar_empty -> - let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in + let evar_names = EvNames.add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in { d with undf_evars = EvMap.add e i d.undf_evars; evar_names } | Evar_defined _ -> - let evar_names = remove_name_possibly_already_defined e d.evar_names in + let evar_names = try EvNames.remove_name_defined e d.evar_names with Not_found -> d.evar_names in { d with defn_evars = EvMap.add e i d.defn_evars; evar_names } let remove d e = @@ -783,7 +813,7 @@ let empty = { last_mods = Evar.Set.empty; metas = Metamap.empty; effects = Safe_typing.empty_private_constants; - evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *) + evar_names = EvNames.empty; (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; extras = Store.empty; @@ -819,14 +849,8 @@ let add_conv_pb ?(tail=false) pb d = let evar_source evk d = (find d evk).evar_source -let evar_ident evk evd = - try EvMap.find evk (fst evd.evar_names) - with Not_found -> - (* Unnamed (non-dependent) evar *) - add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk)) - -let evar_key id evd = - Idmap.find id (snd evd.evar_names) +let evar_ident evk evd = EvNames.ident evk evd.evar_names +let evar_key id evd = EvNames.key id evd.evar_names let define_aux def undef evk body = let oldinfo = @@ -848,7 +872,7 @@ let define evk body evd = | [] -> evd.last_mods | _ -> Evar.Set.add evk evd.last_mods in - let evar_names = remove_name_defined evk evd.evar_names in + let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole)) @@ -868,7 +892,7 @@ let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evar_candidates = candidates; evar_extra = store; } in - let evar_names = add_name_newly_undefined naming evk evar_info evd.evar_names in + let evar_names = EvNames.add_name_newly_undefined naming evk evar_info evd.evar_names in { evd with undf_evars = EvMap.add evk evar_info evd.undf_evars; evar_names } let restrict evk evk' filter ?candidates evd = @@ -877,7 +901,7 @@ let restrict evk evk' filter ?candidates evd = { evar_info with evar_filter = filter; evar_candidates = candidates; evar_extra = Store.empty } in - let evar_names = reassign_name_defined evk evk' evd.evar_names in + let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in let id_inst = Array.map_of_list (fun (id,_,_) -> mkVar id) ctxt in let body = mkEvar(evk',id_inst) in -- cgit v1.2.3 From e9675e068f9e0e92bab05c030fb4722b146123b8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 16:20:46 +0100 Subject: Adding a "get" primitive to map signature. It is similar to find but raises an assertion failure instead of a Not_found when the element is not encountered. Using it will give stronger invariants. --- lib/cMap.ml | 2 ++ lib/cMap.mli | 3 +++ lib/hMap.ml | 2 ++ 3 files changed, 7 insertions(+) diff --git a/lib/cMap.ml b/lib/cMap.ml index d1a32b7aa5..4b058380c6 100644 --- a/lib/cMap.ml +++ b/lib/cMap.ml @@ -25,6 +25,7 @@ module type ExtS = sig include CSig.MapS module Set : CSig.SetS with type elt = key + val get : key -> 'a t -> 'a val update : key -> 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t val domain : 'a t -> Set.t @@ -207,4 +208,5 @@ module Make(M : Map.OrderedType) = struct include Map.Make(M) include MapExt(M) + let get k m = try find k m with Not_found -> assert false end diff --git a/lib/cMap.mli b/lib/cMap.mli index 464dc503be..3ef7fa2c8a 100644 --- a/lib/cMap.mli +++ b/lib/cMap.mli @@ -31,6 +31,9 @@ sig module Set : CSig.SetS with type elt = key (** Sets used by the domain function *) + val get : key -> 'a t -> 'a + (** Same as {!find} but fails an assertion instead of raising [Not_found] *) + val update : key -> 'a -> 'a t -> 'a t (** Same as [add], but expects the key to be present, and thus faster. @raise Not_found when the key is unbound in the map. *) diff --git a/lib/hMap.ml b/lib/hMap.ml index 220adc28f3..778c366fd5 100644 --- a/lib/hMap.ml +++ b/lib/hMap.ml @@ -286,6 +286,8 @@ struct let m = Int.Map.find h s in Map.find k m + let get k s = try find k s with Not_found -> assert false + let split k s = assert false (** Cannot be implemented efficiently *) let map f s = -- cgit v1.2.3 From 62c141be71dd3c542824c19429eac0fdd686c9cb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 18:39:15 +0100 Subject: Optimizing the computation of frozen evars. --- pretyping/unification.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index f97f6fbc57..6cb1bc7028 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1450,9 +1450,7 @@ let default_matching_core_flags sigma = check_applied_meta_types = true; use_pattern_unification = false; use_meta_bound_pattern_unification = false; - frozen_evars = - fold_undefined (fun evk _ evars -> Evar.Set.add evk evars) - sigma Evar.Set.empty; + frozen_evars = Evar.Map.domain (Evd.undefined_map sigma); restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = false; -- cgit v1.2.3 From 5d9eaa378277ed96456fec5a2037a8da4f38c8e0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 20:07:33 +0100 Subject: Optimizing the universes_of_constr_function. Instead of relying on a costly set union, we take advantage of the fact that instances are small compared to the set of universes. --- library/universes.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/universes.ml b/library/universes.ml index 7972c478ad..3bebdafc78 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -959,10 +959,10 @@ let universes_of_constr c = let rec aux s c = match kind_of_term c with | Const (_, u) | Ind (_, u) | Construct (_, u) -> - LSet.union (Instance.levels u) s + LSet.fold LSet.add (Instance.levels u) s | Sort u when not (Sorts.is_small u) -> let u = univ_of_sort u in - LSet.union (Universe.levels u) s + LSet.fold LSet.add (Universe.levels u) s | _ -> fold_constr aux s c in aux LSet.empty c -- cgit v1.2.3 From 68db732f12980e592c610085192d93457f312607 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 8 Feb 2016 11:19:09 +0100 Subject: Improving error message with missing patterns in the presence of multiple patterns. --- toplevel/himsg.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 89c33cb6fe..c0a99fe75c 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -1207,7 +1207,7 @@ let explain_unused_clause env pats = let explain_non_exhaustive env pats = str "Non exhaustive pattern-matching: no clause found for " ++ str (String.plural (List.length pats) "pattern") ++ - spc () ++ hov 0 (pr_sequence pr_cases_pattern pats) + spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) let explain_cannot_infer_predicate env sigma typs = let env = make_all_name_different env in -- cgit v1.2.3 From 34ef02fac1110673ae74c41c185c228ff7876de2 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Fri, 29 Jan 2016 10:13:12 +0100 Subject: CLEANUP: Context.{Rel,Named}.Declaration.t Originally, rel-context was represented as: Context.rel_context = Names.Name.t * Constr.t option * Constr.t Now it is represented as: Context.Rel.t = LocalAssum of Names.Name.t * Constr.t | LocalDef of Names.Name.t * Constr.t * Constr.t Originally, named-context was represented as: Context.named_context = Names.Id.t * Constr.t option * Constr.t Now it is represented as: Context.Named.t = LocalAssum of Names.Id.t * Constr.t | LocalDef of Names.Id.t * Constr.t * Constr.t Motivation: (1) In "tactics/hipattern.ml4" file we define "test_strict_disjunction" function which looked like this: let test_strict_disjunction n lc = Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc Suppose that you do not know about rel-context and named-context. (that is the case of people who just started to read the source code) Merlin would tell you that the type of the value you are destructing by "match" is: 'a * 'b option * Constr.t (* worst-case scenario *) or Named.Name.t * Constr.t option * Constr.t (* best-case scenario (?) *) To me, this is akin to wearing an opaque veil. It is hard to figure out the meaning of the values you are looking at. In particular, it is hard to discover the connection between the value we are destructing above and the datatypes and functions defined in the "kernel/context.ml" file. In this case, the connection is there, but it is not visible (between the function above and the "Context" module). ------------------------------------------------------------------------ Now consider, what happens when the reader see the same function presented in the following form: let test_strict_disjunction n lc = Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc If the reader haven't seen "LocalAssum" before, (s)he can use Merlin to jump to the corresponding definition and learn more. In this case, the connection is there, and it is directly visible (between the function above and the "Context" module). (2) Also, if we already have the concepts such as: - local declaration - local assumption - local definition and we describe these notions meticulously in the Reference Manual, then it is a real pity not to reinforce the connection of the actual code with the abstract description we published. --- checker/cic.mli | 3 +- checker/closure.ml | 8 +- checker/declarations.ml | 13 +- checker/environ.ml | 2 +- checker/indtypes.ml | 20 +- checker/inductive.ml | 48 ++-- checker/reduction.ml | 10 +- checker/term.ml | 47 ++-- checker/term.mli | 2 +- checker/typeops.ml | 16 +- checker/values.ml | 6 +- dev/doc/changes.txt | 31 ++- engine/evd.ml | 27 +- engine/namegen.ml | 15 +- engine/termops.ml | 199 ++++++++------ engine/termops.mli | 2 +- ide/ide_slave.ml | 11 +- interp/constrextern.ml | 4 +- interp/constrintern.ml | 9 +- interp/implicit_quantifiers.ml | 19 +- interp/implicit_quantifiers.mli | 4 +- kernel/closure.ml | 10 +- kernel/context.ml | 364 ++++++++++++++++++------- kernel/context.mli | 151 +++++++--- kernel/cooking.ml | 7 +- kernel/csymtable.ml | 10 +- kernel/declareops.ml | 35 ++- kernel/environ.ml | 64 ++--- kernel/fast_typeops.ml | 17 +- kernel/indtypes.ml | 35 +-- kernel/inductive.ml | 50 ++-- kernel/nativecode.ml | 17 +- kernel/nativelambda.ml | 3 +- kernel/pre_env.ml | 7 +- kernel/reduction.ml | 11 +- kernel/safe_typing.ml | 8 +- kernel/term.ml | 111 ++++---- kernel/term_typing.ml | 24 +- kernel/typeops.ml | 39 +-- kernel/vars.ml | 11 +- lib/util.ml | 1 + lib/util.mli | 1 + library/decls.ml | 10 +- library/heads.ml | 11 +- library/impargs.ml | 15 +- library/lib.ml | 9 +- plugins/cc/ccalgo.ml | 2 +- plugins/cc/cctac.ml | 8 +- plugins/decl_mode/decl_interp.ml | 2 +- plugins/decl_mode/decl_mode.ml | 2 +- plugins/decl_mode/decl_proof_instr.ml | 25 +- plugins/derive/derive.ml | 4 +- plugins/extraction/extraction.ml | 9 +- plugins/firstorder/formula.ml | 11 +- plugins/firstorder/instances.ml | 3 +- plugins/firstorder/rules.ml | 6 +- plugins/fourier/fourierR.ml | 6 +- plugins/funind/functional_principles_proofs.ml | 60 ++-- plugins/funind/functional_principles_types.ml | 39 +-- plugins/funind/glob_term_to_relation.ml | 52 ++-- plugins/funind/indfun.ml | 8 +- plugins/funind/invfun.ml | 40 +-- plugins/funind/merge.ml | 24 +- plugins/funind/recdef.ml | 18 +- plugins/omega/coq_omega.ml | 37 ++- plugins/rtauto/refl_tauto.ml | 5 +- plugins/rtauto/refl_tauto.mli | 2 +- pretyping/cases.ml | 196 +++++++------ pretyping/coercion.ml | 11 +- pretyping/constr_matching.ml | 15 +- pretyping/detyping.ml | 36 ++- pretyping/evarconv.ml | 34 ++- pretyping/evarsolve.ml | 131 +++++---- pretyping/evarutil.ml | 94 ++++--- pretyping/find_subterm.ml | 23 +- pretyping/indrec.ml | 48 ++-- pretyping/inductiveops.ml | 11 +- pretyping/nativenorm.ml | 21 +- pretyping/patternops.ml | 7 +- pretyping/pretyping.ml | 62 ++--- pretyping/reductionops.ml | 36 +-- pretyping/retyping.ml | 22 +- pretyping/tacred.ml | 54 ++-- pretyping/typeclasses.ml | 37 ++- pretyping/typing.ml | 13 +- pretyping/unification.ml | 27 +- pretyping/vnorm.ml | 14 +- printing/prettyp.ml | 31 ++- printing/prettyp.mli | 2 +- printing/printer.ml | 18 +- proofs/goal.ml | 5 +- proofs/logic.ml | 51 ++-- proofs/proof_global.ml | 7 +- proofs/proof_using.ml | 8 +- proofs/proofview.ml | 22 +- proofs/refiner.ml | 6 +- proofs/tacmach.ml | 17 +- stm/lemmas.ml | 11 +- stm/stm.ml | 6 +- tactics/auto.ml | 2 +- tactics/autorewrite.ml | 5 +- tactics/class_tactics.ml | 11 +- tactics/contradiction.ml | 8 +- tactics/elim.ml | 4 +- tactics/eqschemes.ml | 29 +- tactics/equality.ml | 36 +-- tactics/evar_tactics.ml | 7 +- tactics/hints.ml | 8 +- tactics/hipattern.ml4 | 10 +- tactics/inv.ml | 21 +- tactics/leminv.ml | 18 +- tactics/rewrite.ml | 40 +-- tactics/tacinterp.ml | 6 +- tactics/tactic_matching.ml | 14 +- tactics/tacticals.ml | 12 +- tactics/tactics.ml | 327 +++++++++++++--------- toplevel/assumptions.ml | 7 +- toplevel/auto_ind_decl.ml | 43 +-- toplevel/classes.ml | 44 +-- toplevel/command.ml | 78 +++--- toplevel/discharge.ml | 12 +- toplevel/himsg.ml | 24 +- toplevel/indschemes.ml | 3 +- toplevel/obligations.ml | 33 ++- toplevel/record.ml | 74 ++--- toplevel/search.ml | 9 +- toplevel/vernacentries.ml | 14 +- 127 files changed, 2283 insertions(+), 1572 deletions(-) diff --git a/checker/cic.mli b/checker/cic.mli index 041394d466..00ac2f56c3 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -111,7 +111,8 @@ type cofixpoint = constr pcofixpoint (** {6 Type of assumptions and contexts} *) -type rel_declaration = Name.t * constr option * constr +type rel_declaration = LocalAssum of Name.t * constr (* name, type *) + | LocalDef of Name.t * constr * constr (* name, value, type *) type rel_context = rel_declaration list (** The declarations below in .vo should be outside sections, diff --git a/checker/closure.ml b/checker/closure.ml index 400a535cf2..c2708e97d2 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -217,10 +217,10 @@ let ref_value_cache info ref = let defined_rels flags env = (* if red_local_const (snd flags) then*) fold_rel_context - (fun (id,b,t) (i,subs) -> - match b with - | None -> (i+1, subs) - | Some body -> (i+1, (i,body) :: subs)) + (fun decl (i,subs) -> + match decl with + | LocalAssum _ -> (i+1, subs) + | LocalDef (_,body,_) -> (i+1, (i,body) :: subs)) (rel_context env) ~init:(0,[]) (* else (0,[])*) diff --git a/checker/declarations.ml b/checker/declarations.ml index 32d1713a88..2f6eeba1d9 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -517,11 +517,14 @@ let map_decl_arity f g = function | RegularArity a -> RegularArity (f a) | TemplateArity a -> TemplateArity (g a) - -let subst_rel_declaration sub (id,copt,t as x) = - let copt' = Option.smartmap (subst_mps sub) copt in - let t' = subst_mps sub t in - if copt == copt' && t == t' then x else (id,copt',t') +let subst_rel_declaration sub = function + | LocalAssum (id,t) as x -> + let t' = subst_mps sub t in + if t == t' then x else LocalAssum (id,t') + | LocalDef (id,c,t) as x -> + let c' = subst_mps sub c in + let t' = subst_mps sub t in + if c == c' && t == t' then x else LocalDef (id,c',t') let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) diff --git a/checker/environ.ml b/checker/environ.ml index f8f5c29b79..7040fdda46 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -80,7 +80,7 @@ let push_rel d env = let push_rel_context ctxt x = fold_rel_context push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = - let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt (* Universe constraints *) diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 2865f5bd4a..f11fa5a7ad 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -56,10 +56,10 @@ let is_constructor_head t = let conv_ctxt_prefix env (ctx1:rel_context) ctx2 = let rec chk env rctx1 rctx2 = match rctx1, rctx2 with - (_,None,ty1 as d1)::rctx1', (_,None,ty2)::rctx2' -> + (LocalAssum (_,ty1) as d1)::rctx1', LocalAssum (_,ty2)::rctx2' -> conv env ty1 ty2; chk (push_rel d1 env) rctx1' rctx2' - | (_,Some bd1,ty1 as d1)::rctx1', (_,Some bd2,ty2)::rctx2' -> + | (LocalDef (_,bd1,ty1) as d1)::rctx1', LocalDef (_,bd2,ty2)::rctx2' -> conv env ty1 ty2; conv env bd1 bd2; chk (push_rel d1 env) rctx1' rctx2' @@ -94,10 +94,10 @@ let rec sorts_of_constr_args env t = match t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in varj :: sorts_of_constr_args env1 c2 | LetIn (name,def,ty,c) -> - let env1 = push_rel (name,Some def,ty) env in + let env1 = push_rel (LocalDef (name,def,ty)) env in sorts_of_constr_args env1 c | _ when is_constructor_head t -> [] | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor") @@ -167,7 +167,7 @@ let typecheck_arity env params inds = full_arity is used as argument or subject to cast, an upper universe will be generated *) let id = ind.mind_typename in - let env_ar' = push_rel (Name id, None, arity) env_ar in + let env_ar' = push_rel (LocalAssum (Name id, arity)) env_ar in env_ar') env inds in @@ -319,7 +319,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = let nhyps = List.length hyps in let rec check k index = function | [] -> () - | (_,Some _,_)::hyps -> check k (index+1) hyps + | LocalDef (_,_,_) :: hyps -> check k (index+1) hyps | _::hyps -> match whd_betadeltaiota env lpar.(k) with | Rel w when w = index -> check (k-1) (index+1) hyps @@ -340,7 +340,7 @@ let check_rec_par (env,n,_,_) hyps nrecp largs = | ([],_) -> () | (_,[]) -> failwith "number of recursive parameters cannot be greater than the number of parameters." - | (lp,(_,Some _,_)::hyps) -> find (index-1) (lp,hyps) + | (lp,LocalDef _ :: hyps) -> find (index-1) (lp,hyps) | (p::lp,_::hyps) -> (match whd_betadeltaiota env p with | Rel w when w = index -> find (index-1) (lp,hyps) @@ -370,14 +370,14 @@ let abstract_mind_lc env ntyps npars lc = [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = - (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) + (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in let specif = lookup_mind_specif env mi in let env' = - push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env (specif,u)) lpar) env in + push_rel (LocalAssum (Anonymous, + hnf_prod_applist env (type_of_inductive env (specif,u)) lpar)) env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in diff --git a/checker/inductive.ml b/checker/inductive.ml index 79dba4fac5..9480124211 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -88,10 +88,10 @@ let instantiate_params full t u args sign = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = fold_rel_context - (fun (_,copt,_) (largs,subs,ty) -> - match (copt, largs, ty) with - | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) - | (Some b,_,LetIn(_,_,_,t)) -> + (fun decl (largs,subs,ty) -> + match (decl, largs, ty) with + | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) + | (LocalDef (_,b,_),_,LetIn(_,_,_,t)) -> (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) @@ -161,7 +161,7 @@ let remember_subst u subst = (* Propagate the new levels in the signature *) let rec make_subst env = let rec make subst = function - | (_,Some _,_)::sign, exp, args -> + | LocalDef _ :: sign, exp, args -> make subst (sign, exp, args) | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in @@ -174,7 +174,7 @@ let rec make_subst env = (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env a)) in make (cons_subst u s subst) (sign, exp, args) - | (na,None,t)::sign, Some u::exp, [] -> + | LocalAssum (na,t) :: sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) (* substitution (when [u] is distinct from all other universes in the *) (* template, it is identity substitution otherwise (ie. when u is *) @@ -319,8 +319,8 @@ let elim_sorts (_,mip) = mip.mind_kelim let extended_rel_list n hyps = let rec reln l p = function - | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps + | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps + | LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps @@ -345,12 +345,12 @@ let is_correct_arity env c (p,pj) ind specif params = let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match pt', ar with - | Prod (na1,a1,t), (_,None,a1')::ar' -> + | Prod (na1,a1,t), LocalAssum (_,a1')::ar' -> (try conv env a1 a1' with NotConvertible -> raise (LocalArity None)); - srec (push_rel (na1,None,a1) env) t ar' + srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (na1,None,a1) env in + let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match (whd_betadeltaiota env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in @@ -362,8 +362,8 @@ let is_correct_arity env c (p,pj) ind specif params = | Sort s', [] -> check_allowed_sort (family_of_sort s') specif; false - | _, (_,Some _,_ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' + | _, (LocalDef _ as d)::ar' -> + srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in @@ -530,7 +530,7 @@ let make_renv env recarg tree = genv = [Lazy.lazy_from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = - { env = push_rel (x,None,ty) renv.env; + { env = push_rel (LocalAssum (x,ty)) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -628,14 +628,14 @@ let check_inductive_codomain env p = (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) let ienv_push_var (env, lra) (x,a,ra) = -(push_rel (x,None,a) env, (Norec,ra)::lra) +(push_rel (LocalAssum (x,a)) env, (Norec,ra)::lra) let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) env + push_rel (LocalAssum (Anonymous, + hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar)) env in let env = Array.fold_right push_ind mib.mind_packets env in let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in @@ -902,7 +902,7 @@ let filter_stack_domain env ci p stack = let t = whd_betadeltaiota env ar in match stack, t with | elt :: stack', Prod (n,a,c0) -> - let d = (n,None,a) in + let d = LocalAssum (n,a) in let ty, args = decompose_app (whd_betadeltaiota env a) in let elt = match ty with | Ind ind -> @@ -956,10 +956,10 @@ let check_one_fix renv recpos trees def = end else begin - match pi2 (lookup_rel p renv.env) with - | None -> + match lookup_rel p renv.env with + | LocalAssum _ -> List.iter (check_rec_call renv []) l - | Some c -> + | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) @@ -1078,7 +1078,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = match (whd_betadeltaiota env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in if n = k+1 then (* get the inductive type of the fixpoint *) let (mind, _) = @@ -1127,7 +1127,7 @@ let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (x, None, a) env) b + codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> @@ -1168,7 +1168,7 @@ let check_one_cofix env nbfix def deftype = | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in check_rec_call env' alreadygrd (n+1) tree vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) diff --git a/checker/reduction.ml b/checker/reduction.ml index 3a666a60a4..f1aa5d9194 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -490,7 +490,7 @@ let dest_prod env = let t = whd_betadeltaiota env c in match t with | Prod (n,a,c0) -> - let d = (n,None,a) in + let d = LocalAssum (n,a) in decrec (push_rel d env) (d::m) c0 | _ -> m,t in @@ -502,10 +502,10 @@ let dest_prod_assum env = let rty = whd_betadeltaiota_nolet env ty in match rty with | Prod (x,t,c) -> - let d = (x,None,t) in + let d = LocalAssum (x,t) in prodec_rec (push_rel d env) (d::l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in + let d = LocalDef (x,b,t) in prodec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> @@ -520,10 +520,10 @@ let dest_lam_assum env = let rty = whd_betadeltaiota_nolet env ty in match rty with | Lambda (x,t,c) -> - let d = (x,None,t) in + let d = LocalAssum (x,t) in lamec_rec (push_rel d env) (d::l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in + let d = LocalDef (x,b,t) in lamec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty diff --git a/checker/term.ml b/checker/term.ml index 6487d1a152..181d292ad4 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -222,24 +222,29 @@ let rel_context_length = List.length let rel_context_nhyps hyps = let rec nhyps acc = function | [] -> acc - | (_,None,_)::hyps -> nhyps (1+acc) hyps - | (_,Some _,_)::hyps -> nhyps acc hyps in + | LocalAssum _ :: hyps -> nhyps (1+acc) hyps + | LocalDef _ :: hyps -> nhyps acc hyps in nhyps 0 hyps let fold_rel_context f l ~init = List.fold_right f l init let map_rel_context f l = - let map_decl (n, body_o, typ as decl) = - let body_o' = Option.smartmap f body_o in - let typ' = f typ in - if body_o' == body_o && typ' == typ then decl else - (n, body_o', typ') + let map_decl = function + | LocalAssum (n, typ) as decl -> + let typ' = f typ in + if typ' == typ then decl else + LocalAssum (n, typ') + | LocalDef (n, body, typ) as decl -> + let body' = f body in + let typ' = f typ in + if body' == body && typ' == typ then decl else + LocalDef (n, body', typ') in List.smartmap map_decl l let extended_rel_list n hyps = let rec reln l p = function - | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps + | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps + | LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps @@ -272,8 +277,8 @@ let decompose_lam_n_assum n = let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match c with - | Lambda (x,t,c) -> lamdec_rec ((x,None,t) :: l) (n-1) c - | LetIn (x,b,t,c) -> lamdec_rec ((x,Some b,t) :: l) n c + | Lambda (x,t,c) -> lamdec_rec (LocalAssum (x,t) :: l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (LocalDef (x,b,t) :: l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in @@ -282,18 +287,18 @@ let decompose_lam_n_assum n = (* Iterate products, with or without lets *) (* Constructs either [(x:t)c] or [[x=b:t]c] *) -let mkProd_or_LetIn (na,body,t) c = - match body with - | None -> Prod (na, t, c) - | Some b -> LetIn (na, b, t, c) +let mkProd_or_LetIn decl c = + match decl with + | LocalAssum (na,t) -> Prod (na, t, c) + | LocalDef (na,b,t) -> LetIn (na, b, t, c) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let decompose_prod_assum = let rec prodec_rec l c = match c with - | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in @@ -305,8 +310,8 @@ let decompose_prod_n_assum n = let rec prodec_rec l n c = if Int.equal n 0 then l,c else match c with - | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) (n-1) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) (n-1) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) (n-1) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in @@ -324,8 +329,8 @@ let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign let destArity = let rec prodec_rec l c = match c with - | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t)::l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t)::l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") diff --git a/checker/term.mli b/checker/term.mli index ab488b2b7c..d6455e23f4 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -40,7 +40,7 @@ val extended_rel_list : int -> rel_context -> constr list val compose_lam : (name * constr) list -> constr -> constr val decompose_lam : constr -> (name * constr) list * constr val decompose_lam_n_assum : int -> constr -> rel_context * constr -val mkProd_or_LetIn : name * constr option * constr -> constr -> constr +val mkProd_or_LetIn : rel_declaration -> constr -> constr val it_mkProd_or_LetIn : constr -> rel_context -> constr val decompose_prod_assum : constr -> rel_context * constr val decompose_prod_n_assum : int -> constr -> rel_context * constr diff --git a/checker/typeops.ml b/checker/typeops.ml index d49c40a8bd..64afd21b2a 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -62,7 +62,7 @@ let judge_of_type u = Sort (Type (Univ.super u)) let judge_of_relative env n = try - let (_,_,typ) = lookup_rel n env in + let LocalAssum (_,typ) | LocalDef (_,_,typ) = lookup_rel n env in lift n typ with Not_found -> error_unbound_rel env n @@ -296,13 +296,13 @@ let rec execute env cstr = | Lambda (name,c1,c2) -> let _ = execute_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let j' = execute env1 c2 in Prod(name,c1,j') | Prod (name,c1,c2) -> let varj = execute_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let varj' = execute_type env1 c2 in Sort (sort_of_product env varj varj') @@ -314,7 +314,7 @@ let rec execute env cstr = let env',c2' = (* refresh_arity env *) env, c2 in let _ = execute_type env' c2' in judge_of_cast env' (c1,j1) DEFAULTcast c2' in - let env1 = push_rel (name,Some c1,c2) env in + let env1 = push_rel (LocalDef (name,c1,c2)) env in let j' = execute env1 c3 in subst1 c1 j' @@ -378,10 +378,10 @@ let infer_type env constr = execute_type env constr let check_ctxt env rels = fold_rel_context (fun d env -> match d with - (_,None,ty) -> + | LocalAssum (_,ty) -> let _ = infer_type env ty in push_rel d env - | (_,Some bd,ty) -> + | LocalDef (_,bd,ty) -> let j1 = infer env bd in let _ = infer env ty in conv_leq env j1 ty; @@ -399,9 +399,9 @@ let check_polymorphic_arity env params par = let pl = par.template_param_levels in let rec check_p env pl params = match pl, params with - Some u::pl, (na,None,ty)::params -> + Some u::pl, LocalAssum (na,ty)::params -> check_kind env ty u; - check_p (push_rel (na,None,ty) env) pl params + check_p (push_rel (LocalAssum (na,ty)) env) pl params | None::pl,d::params -> check_p (push_rel d env) pl params | [], _ -> () | _ -> failwith "check_poly: not the right number of params" in diff --git a/checker/values.ml b/checker/values.ml index c14e9223da..19cbb50606 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 7c050ff1db22f14ee3a4c44aae533082 checker/cic.mli +MD5 9f7fd499f812b6548a55f7067e6a9d06 checker/cic.mli *) @@ -154,8 +154,8 @@ and v_prec = Tuple ("prec_declaration", and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) - -let v_rdecl = v_tuple "rel_declaration" [|v_name;Opt v_constr;v_constr|] +let v_rdecl = v_sum "rel_declaration" 0 [| [|v_name; v_constr|]; (* LocalAssum *) + [|v_name; v_constr; v_constr|] |] (* LocalDef *) let v_rctxt = List v_rdecl let v_section_ctxt = v_enum "emptylist" 1 diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index c143afd374..0581a5f850 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -1,5 +1,5 @@ ========================================= -= CHANGES BETWEEN COQ V8.5 AND CQQ V8.6 = += CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= - The interface of the Context module was changed. @@ -9,9 +9,9 @@ Context.named_declaration ---> Context.Named.Declaration.t Context.named_list_declaration ---> Context.NamedList.Declaration.t Context.rel_declaration ---> Context.Rel.Declaration.t - Context.map_named_declaration ---> Context.Named.Declaration.map + Context.map_named_declaration ---> Context.Named.Declaration.map_constr Context.map_named_list_declaration ---> Context.NamedList.Declaration.map - Context.map_rel_declaration ---> Context.Rel.Declaration.map + Context.map_rel_declaration ---> Context.Rel.Declaration.map_constr Context.fold_named_declaration ---> Context.Named.Declaration.fold Context.fold_rel_declaration ---> Context.Rel.Declaration.fold Context.exists_named_declaration ---> Context.Named.Declaration.exists @@ -37,8 +37,8 @@ Context.extended_rel_vect ---> Context.Rel.to_extended_vect Context.fold_rel_context ---> Context.Rel.fold_outside Context.fold_rel_context_reverse ---> Context.Rel.fold_inside - Context.map_rel_context ---> Context.Rel.map - Context.map_named_context ---> Context.Named.map + Context.map_rel_context ---> Context.Rel.map_constr + Context.map_named_context ---> Context.Named.map_constr Context.iter_rel_context ---> Context.Rel.iter Context.iter_named_context ---> Context.Named.iter Context.empty_rel_context ---> Context.Rel.empty @@ -48,8 +48,27 @@ Context.rel_context_nhyps ---> Context.Rel.nhyps Context.rel_context_tags ---> Context.Rel.to_tags +- Originally, rel-context was represented as: + + Context.rel_context = Names.Name.t * Constr.t option * Constr.t + + Now it is represented as: + + Context.Rel.t = LocalAssum of Names.Name.t * Constr.t + | LocalDef of Names.Name.t * Constr.t * Constr.t + +- Originally, named-context was represented as: + + Context.named_context = Names.Id.t * Constr.t option * Constr.t + + Now it is represented as: + + Context.Named.t = LocalAssum of Names.Id.t * Constr.t + | LocalDef of Names.Id.t * Constr.t * Constr.t + + ========================================= -= CHANGES BETWEEN COQ V8.4 AND CQQ V8.5 = += CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = ========================================= ** Refactoring : more mli interfaces and simpler grammar.cma ** diff --git a/engine/evd.ml b/engine/evd.ml index 8f8b29d106..f1f65bd8af 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -16,6 +16,7 @@ open Vars open Termops open Environ open Globnames +open Context.Named.Declaration (** Generic filters *) module Filter : @@ -230,20 +231,20 @@ let evar_instance_array test_id info args = else instance_mismatch () | false :: filter, _ :: ctxt -> instrec filter ctxt i - | true :: filter, (id,_,_ as d) :: ctxt -> + | true :: filter, d :: ctxt -> if i < len then let c = Array.unsafe_get args i in if test_id d c then instrec filter ctxt (succ i) - else (id, c) :: instrec filter ctxt (succ i) + else (get_id d, c) :: instrec filter ctxt (succ i) else instance_mismatch () | _ -> instance_mismatch () in match Filter.repr (evar_filter info) with | None -> - let map i (id,_,_ as d) = + let map i d = if (i < len) then let c = Array.unsafe_get args i in - if test_id d c then None else Some (id,c) + if test_id d c then None else Some (get_id d, c) else instance_mismatch () in List.map_filter_i map (evar_context info) @@ -251,7 +252,7 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) 0 let make_evar_instance_array info args = - evar_instance_array (fun (id,_,_) -> isVarId id) info args + evar_instance_array (isVarId % get_id) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -660,7 +661,7 @@ let restrict evk filter ?candidates evd = evar_extra = Store.empty } in let evar_names = reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = Array.map_of_list (fun (id,_,_) -> mkVar id) ctxt in + let id_inst = Array.map_of_list (mkVar % get_id) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; @@ -722,10 +723,10 @@ let evars_of_term c = evrec Evar.Set.empty c let evars_of_named_context nc = - List.fold_right (fun (_, b, t) s -> + List.fold_right (fun decl s -> Option.fold_left (fun s t -> Evar.Set.union s (evars_of_term t)) - (Evar.Set.union s (evars_of_term t)) b) + (Evar.Set.union s (evars_of_term (get_type decl))) (get_value decl)) nc Evar.Set.empty let evars_of_filtered_evar_info evi = @@ -1228,8 +1229,9 @@ let pr_meta_map mmap = in prlist pr_meta_binding (metamap_to_list mmap) -let pr_decl ((id,b,_),ok) = - match b with +let pr_decl (decl,ok) = + let id = get_id decl in + match get_value decl with | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ print_constr c ++ str (if ok then ")" else "}") @@ -1346,8 +1348,9 @@ let print_env_short env = let pr_body n = function | None -> pr_name n | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in - let pr_named_decl (n, b, _) = pr_body (Name n) b in - let pr_rel_decl (n, b, _) = pr_body n b in + let pr_named_decl decl = pr_body (Name (get_id decl)) (get_value decl) in + let pr_rel_decl decl = let open Context.Rel.Declaration in + pr_body (get_name decl) (get_value decl) in let nc = List.rev (named_context env) in let rc = List.rev (rel_context env) in str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++ diff --git a/engine/namegen.ml b/engine/namegen.ml index fc3f0cc75b..6b2b585316 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -22,6 +22,7 @@ open Libnames open Globnames open Environ open Termops +open Context.Rel.Declaration (**********************************************************************) (* Conventional names *) @@ -113,7 +114,7 @@ let hdchar env c = | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else - try match Environ.lookup_rel (n-k) env with + try match Environ.lookup_rel (n-k) env |> to_tuple with | (Name id,_,_) -> lowercase_first_char id | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) with Not_found -> "y") @@ -142,10 +143,9 @@ let prod_name = mkProd_name let prod_create env (a,b) = mkProd (named_hd env a Anonymous, a, b) let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous, a, b) -let name_assumption env (na,c,t) = - match c with - | None -> (named_hd env t na, None, t) - | Some body -> (named_hd env body na, c, t) +let name_assumption env = function + | LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) + | LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) let name_context env hyps = snd @@ -277,11 +277,12 @@ let next_name_away = next_name_away_with_default default_non_dependent_string let make_all_name_different env = let avoid = ref (ids_of_named_context (named_context env)) in process_rel_context - (fun (na,c,t) newenv -> + (fun decl newenv -> + let (na,_,t) = to_tuple decl in let na = named_hd newenv t na in let id = next_name_away na !avoid in avoid := id::!avoid; - push_rel (Name id,c,t) newenv) + push_rel (set_name (Name id) decl) newenv) env (* 5- Looks for next fresh name outside a list; avoids also to use names that diff --git a/engine/termops.ml b/engine/termops.ml index b7d89ba7b1..f698f81513 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -15,6 +15,9 @@ open Term open Vars open Environ +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Sorts and sort family *) let print_sort = function @@ -98,26 +101,28 @@ let print_constr_env t = !term_printer t let print_constr t = !term_printer (Global.env()) t let set_print_constr f = term_printer := f -let pr_var_decl env (id,c,typ) = - let pbody = match c with - | None -> (mt ()) - | Some c -> +let pr_var_decl env decl = + let open NamedDecl in + let pbody = match decl with + | LocalAssum _ -> mt () + | LocalDef (_,c,_) -> (* Force evaluation *) let pb = print_constr_env env c in (str" := " ++ pb ++ cut () ) in - let pt = print_constr_env env typ in + let pt = print_constr_env env (get_type decl) in let ptyp = (str" : " ++ pt) in - (pr_id id ++ hov 0 (pbody ++ ptyp)) + (pr_id (get_id decl) ++ hov 0 (pbody ++ ptyp)) -let pr_rel_decl env (na,c,typ) = - let pbody = match c with - | None -> mt () - | Some c -> +let pr_rel_decl env decl = + let open RelDecl in + let pbody = match decl with + | LocalAssum _ -> mt () + | LocalDef (_,c,_) -> (* Force evaluation *) let pb = print_constr_env env c in (str":=" ++ spc () ++ pb ++ spc ()) in - let ptyp = print_constr_env env typ in - match na with + let ptyp = print_constr_env env (get_type decl) in + match get_name decl with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) @@ -157,42 +162,53 @@ let rel_list n m = in reln [] 1 -let push_rel_assum (x,t) env = push_rel (x,None,t) env +let push_rel_assum (x,t) env = + let open RelDecl in + push_rel (LocalAssum (x,t)) env let push_rels_assum assums = - push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums) + let open RelDecl in + push_rel_context (List.map (fun (x,t) -> LocalAssum (x,t)) assums) let push_named_rec_types (lna,typarray,_) env = + let open NamedDecl in let ctxt = Array.map2_i (fun i na t -> match na with - | Name id -> (id, None, lift i t) + | Name id -> LocalAssum (id, lift i t) | Anonymous -> anomaly (Pp.str "Fix declarations must be named")) lna typarray in Array.fold_left (fun e assum -> push_named assum e) env ctxt let lookup_rel_id id sign = + let open RelDecl in let rec lookrec n = function - | [] -> raise Not_found - | (Anonymous, _, _) :: l -> lookrec (n + 1) l - | (Name id', b, t) :: l -> - if Names.Id.equal id' id then (n, b, t) else lookrec (n + 1) l + | [] -> + raise Not_found + | (LocalAssum (Anonymous, _) | LocalDef (Anonymous,_,_)) :: l -> + lookrec (n + 1) l + | LocalAssum (Name id', t) :: l -> + if Names.Id.equal id' id then (n,None,t) else lookrec (n + 1) l + | LocalDef (Name id', b, t) :: l -> + if Names.Id.equal id' id then (n,Some b,t) else lookrec (n + 1) l in lookrec 1 sign (* Constructs either [forall x:t, c] or [let x:=b:t in c] *) -let mkProd_or_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> mkLetIn (na, b, t, c) +let mkProd_or_LetIn decl c = + let open RelDecl in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) (* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *) -let mkProd_wo_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> subst1 b c +let mkProd_wo_LetIn decl c = + let open RelDecl in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (_,b,_) -> subst1 b c let it_mkProd init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init let it_mkLambda init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init @@ -208,10 +224,11 @@ let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_Le let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init let it_mkLambda_or_LetIn_from_no_LetIn c decls = + let open RelDecl in let rec aux k decls c = match decls with | [] -> c - | (na,Some b,t)::decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c)) - | (na,None,t)::decls -> mkLambda (na,t,aux (k-1) decls c) + | LocalDef (na,b,t) :: decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c)) + | LocalAssum (na,t) :: decls -> mkLambda (na,t,aux (k-1) decls c) in aux (List.length decls) (List.rev decls) c (* *) @@ -302,7 +319,7 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with (co-)fixpoint) *) let fold_rec_types g (lna,typarray,_) e = - let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> RelDecl.LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> g assum e) e ctxt let map_left2 f a g b = @@ -317,7 +334,9 @@ let map_left2 f a g b = r, s end -let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with +let map_constr_with_binders_left_to_right g f l c = + let open RelDecl in + match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (b,k,t) -> @@ -327,18 +346,18 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with else mkCast (b',k,t') | Prod (na,t,b) -> let t' = f l t in - let b' = f (g (na,None,t) l) b in + let b' = f (g (LocalAssum (na,t)) l) b in if t' == t && b' == b then c else mkProd (na, t', b') | Lambda (na,t,b) -> let t' = f l t in - let b' = f (g (na,None,t) l) b in + let b' = f (g (LocalAssum (na,t)) l) b in if t' == t && b' == b then c else mkLambda (na, t', b') | LetIn (na,bo,t,b) -> let bo' = f l bo in let t' = f l t in - let b' = f (g (na,Some bo,t) l) b in + let b' = f (g (LocalDef (na,bo,t)) l) b in if bo' == bo && t' == t && b' == b then c else mkLetIn (na, bo', t', b') | App (c,[||]) -> assert false @@ -379,7 +398,9 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with else mkCoFix (ln,(lna,tl',bl')) (* strong *) -let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with +let map_constr_with_full_binders g f l cstr = + let open RelDecl in + match kind_of_term cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> cstr | Cast (c,k, t) -> @@ -388,16 +409,16 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with if c==c' && t==t' then cstr else mkCast (c', k, t') | Prod (na,t,c) -> let t' = f l t in - let c' = f (g (na,None,t) l) c in + let c' = f (g (LocalAssum (na,t)) l) c in if t==t' && c==c' then cstr else mkProd (na, t', c') | Lambda (na,t,c) -> let t' = f l t in - let c' = f (g (na,None,t) l) c in + let c' = f (g (LocalAssum (na,t)) l) c in if t==t' && c==c' then cstr else mkLambda (na, t', c') | LetIn (na,b,t,c) -> let b' = f l b in let t' = f l t in - let c' = f (g (na,Some b,t) l) c in + let c' = f (g (LocalDef (na,b,t)) l) c in if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c') | App (c,al) -> let c' = f l c in @@ -418,7 +439,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with | Fix (ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = - Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr @@ -426,7 +447,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = - Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr @@ -439,23 +460,25 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) -let fold_constr_with_full_binders g f n acc c = match kind_of_term c with +let fold_constr_with_full_binders g f n acc c = + let open RelDecl in + match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_, t) -> f n (f n acc c) t - | Prod (na,t,c) -> f (g (na,None,t) n) (f n acc t) c - | Lambda (na,t,c) -> f (g (na,None,t) n) (f n acc t) c - | LetIn (na,b,t,c) -> f (g (na,Some b,t) n) (f n (f n acc b) t) c + | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in + let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in + let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd @@ -467,23 +490,25 @@ let fold_constr_with_binders g f n acc c = each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) -let iter_constr_with_full_binders g f l c = match kind_of_term c with +let iter_constr_with_full_binders g f l c = + let open RelDecl in + match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_, t) -> f l c; f l t - | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c - | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c - | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c + | Prod (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c + | Lambda (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c + | LetIn (na,b,t,c) -> f l b; f l t; f (g (LocalDef (na,b,t)) l) c | App (c,args) -> f l c; Array.iter (f l) args | Proj (p,c) -> f l c | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl | CoFix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl @@ -531,10 +556,11 @@ let occur_var env id c = in try occur_rec c; false with Occur -> true -let occur_var_in_decl env hyp (_,c,typ) = - match c with - | None -> occur_var env hyp typ - | Some body -> +let occur_var_in_decl env hyp decl = + let open NamedDecl in + match decl with + | LocalAssum (_,typ) -> occur_var env hyp typ + | LocalDef (_, body, typ) -> occur_var env hyp typ || occur_var env hyp body @@ -593,10 +619,11 @@ let dependent_no_evar = dependent_main true false let dependent_univs = dependent_main false true let dependent_univs_no_evar = dependent_main true true -let dependent_in_decl a (_,c,t) = - match c with - | None -> dependent a t - | Some body -> dependent a body || dependent a t +let dependent_in_decl a decl = + let open NamedDecl in + match decl with + | LocalAssum (_,t) -> dependent a t + | LocalDef (_, body, t) -> dependent a body || dependent a t let count_occurrences m t = let n = ref 0 in @@ -699,10 +726,10 @@ let replace_term = replace_term_gen eq_constr let vars_of_env env = let s = - Context.Named.fold_outside (fun (id,_,_) s -> Id.Set.add id s) + Context.Named.fold_outside (fun decl s -> Id.Set.add (NamedDecl.get_id decl) s) (named_context env) ~init:Id.Set.empty in Context.Rel.fold_outside - (fun (na,_,_) s -> match na with Name id -> Id.Set.add id s | _ -> s) + (fun decl s -> match RelDecl.get_name decl with Name id -> Id.Set.add id s | _ -> s) (rel_context env) ~init:s let add_vname vars = function @@ -728,11 +755,11 @@ let empty_names_context = [] let ids_of_rel_context sign = Context.Rel.fold_outside - (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l) + (fun decl l -> match RelDecl.get_name decl with Name id -> id::l | Anonymous -> l) sign ~init:[] let ids_of_named_context sign = - Context.Named.fold_outside (fun (id,_,_) idl -> id::idl) sign ~init:[] + Context.Named.fold_outside (fun decl idl -> NamedDecl.get_id decl :: idl) sign ~init:[] let ids_of_context env = (ids_of_rel_context (rel_context env)) @@ -740,7 +767,7 @@ let ids_of_context env = let names_of_rel_context env = - List.map (fun (na,_,_) -> na) (rel_context env) + List.map RelDecl.get_name (rel_context env) let is_section_variable id = try let _ = Global.lookup_named id in true @@ -813,7 +840,7 @@ let filtering env cv_pb c1 c2 = end | Prod (n,t1,c1), Prod (_,t2,c2) -> aux env cv_pb t1 t2; - aux ((n,None,t1)::env) cv_pb c1 c2 + aux (RelDecl.LocalAssum (n,t1) :: env) cv_pb c1 c2 | _, Evar (ev,_) -> define cv_pb env ev c1 | Evar (ev,_), _ -> define cv_pb env ev c2 | _ -> @@ -826,8 +853,8 @@ let filtering env cv_pb c1 c2 = let decompose_prod_letin : constr -> int * Context.Rel.t * constr = let rec prodec_rec i l c = match kind_of_term c with - | Prod (n,t,c) -> prodec_rec (succ i) ((n,None,t)::l) c - | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c + | Prod (n,t,c) -> prodec_rec (succ i) (RelDecl.LocalAssum (n,t)::l) c + | LetIn (n,d,t,c) -> prodec_rec (succ i) (RelDecl.LocalDef (n,d,t)::l) c | Cast (c,_,_) -> prodec_rec i l c | _ -> i,l,c in prodec_rec 0 [] @@ -902,16 +929,16 @@ let process_rel_context f env = let assums_of_rel_context sign = Context.Rel.fold_outside - (fun (na,c,t) l -> - match c with - Some _ -> l - | None -> (na, t)::l) + (fun decl l -> + match decl with + | RelDecl.LocalDef _ -> l + | RelDecl.LocalAssum (na,t) -> (na, t)::l) sign ~init:[] let map_rel_context_in_env f env sign = let rec aux env acc = function | d::sign -> - aux (push_rel d env) (Context.Rel.Declaration.map (f env) d :: acc) sign + aux (push_rel d env) (RelDecl.map_constr (f env) d :: acc) sign | [] -> acc in @@ -919,7 +946,7 @@ let map_rel_context_in_env f env sign = let map_rel_context_with_binders f sign = let rec aux k = function - | d::sign -> Context.Rel.Declaration.map (f k) d :: aux (k-1) sign + | d::sign -> RelDecl.map_constr (f k) d :: aux (k-1) sign | [] -> [] in aux (Context.Rel.length sign) sign @@ -933,21 +960,23 @@ let lift_rel_context n = let smash_rel_context sign = let rec aux acc = function | [] -> acc - | (_,None,_ as d) :: l -> aux (d::acc) l - | (_,Some b,_) :: l -> + | (RelDecl.LocalAssum _ as d) :: l -> aux (d::acc) l + | RelDecl.LocalDef (_,b,_) :: l -> (* Quadratic in the number of let but there are probably a few of them *) aux (List.rev (substl_rel_context [b] (List.rev acc))) l in List.rev (aux [] sign) let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init -let rec mem_named_context id = function - | (id',_,_) :: _ when Id.equal id id' -> true +let rec mem_named_context id ctxt = + match ctxt with + | decl :: _ when Id.equal id (NamedDecl.get_id decl) -> true | _ :: sign -> mem_named_context id sign | [] -> false let compact_named_context_reverse sign = - let compact l (i1,c1,t1) = + let compact l decl = + let (i1,c1,t1) = NamedDecl.to_tuple decl in match l with | [] -> [[i1],c1,t1] | (l2,c2,t2)::q -> @@ -959,16 +988,17 @@ let compact_named_context_reverse sign = let compact_named_context sign = List.rev (compact_named_context_reverse sign) let clear_named_body id env = + let open NamedDecl in let aux _ = function - | (id',Some c,t) when Id.equal id id' -> push_named (id,None,t) + | LocalDef (id',c,t) when Id.equal id id' -> push_named (LocalAssum (id,t)) | d -> push_named d in fold_named_context aux env ~init:(reset_context env) let global_vars env ids = Id.Set.elements (global_vars_set env ids) let global_vars_set_of_decl env = function - | (_,None,t) -> global_vars_set env t - | (_,Some c,t) -> + | NamedDecl.LocalAssum (_,t) -> global_vars_set env t + | NamedDecl.LocalDef (_,c,t) -> Id.Set.union (global_vars_set env t) (global_vars_set env c) @@ -976,7 +1006,8 @@ let dependency_closure env sign hyps = if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside - (fun (hs,hl) (x,_,_ as d) -> + (fun (hs,hl) d -> + let x = NamedDecl.get_id d in if Id.Set.mem x hs then (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs), x::hl) @@ -996,7 +1027,7 @@ let on_judgment_type f j = { j with uj_type = f j.uj_type } let context_chop k ctx = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) - | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t) + | (n, (RelDecl.LocalDef _ as h)::t) -> chop_aux (h::acc) (n, t) | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) | (_, []) -> anomaly (Pp.str "context_chop") in chop_aux [] (k,ctx) diff --git a/engine/termops.mli b/engine/termops.mli index 720ed3bd67..c2a4f33235 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -101,7 +101,7 @@ val occur_evar : existential_key -> types -> bool val occur_var : env -> Id.t -> types -> bool val occur_var_in_decl : env -> - Id.t -> 'a * types option * types -> bool + Id.t -> Context.Named.Declaration.t -> bool val free_rels : constr -> Int.Set.t (** [dependent m t] tests whether [m] is a subterm of [t] *) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 20cf48d7f8..12ef0e0751 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -130,7 +130,8 @@ let annotate phrase = (** Goal display *) -let hyp_next_tac sigma env (id,_,ast) = +let hyp_next_tac sigma env decl = + let (id,_,ast) = Context.Named.Declaration.to_tuple decl in let id_s = Names.Id.to_string id in let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in [ @@ -187,8 +188,12 @@ let process_goal sigma g = Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) in let process_hyp d (env,l) = - let d = Context.NamedList.Declaration.map (Reductionops.nf_evar sigma) d in - let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in + let d = Context.NamedList.Declaration.map_constr (Reductionops.nf_evar sigma) d in + let d' = List.map (fun name -> let open Context.Named.Declaration in + match pi2 d with + | None -> LocalAssum (name, pi3 d) + | Some value -> LocalDef (name, value, pi3 d)) + (pi1 d) in (List.fold_right Environ.push_named d' env, (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in let (_env, hyps) = diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 70a35c6132..3a8c506cba 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -29,6 +29,8 @@ open Notation open Detyping open Misctypes open Decl_kinds + +module NamedDecl = Context.Named.Declaration (*i*) (* Translation from glob_constr to front constr *) @@ -980,7 +982,7 @@ let rec glob_of_pat env sigma = function | PRef ref -> GRef (loc,ref,None) | PVar id -> GVar (loc,id) | PEvar (evk,l) -> - let test (id,_,_) = function PVar id' -> Id.equal id id' | _ -> false in + let test decl = function PVar id' -> Id.equal (NamedDecl.get_id decl) id' | _ -> false in let l = Evd.evar_instance_array test (Evd.find sigma evk) l in let id = Evd.evar_ident evk sigma in GEvar (loc,id,List.map (on_snd (glob_of_pat env sigma)) l) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 964ed05140..70802d5cba 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -29,6 +29,7 @@ open Nametab open Notation open Inductiveops open Decl_kinds +open Context.Rel.Declaration (** constr_expr -> glob_constr translation: - it adds holes for implicit arguments @@ -1645,14 +1646,14 @@ let internalize globalenv env allow_patvar lvar c = |loc,(Name y as x) -> (y,PatVar(loc,x)) :: l in match case_rel_ctxt,arg_pats with (* LetIn in the rel_context *) - |(_,Some _,_)::t, l when not with_letin -> + | LocalDef _ :: t, l when not with_letin -> canonize_args t l forbidden_names match_acc ((Loc.ghost,Anonymous)::var_acc) |[],[] -> (add_name match_acc na, var_acc) |_::t,PatVar (loc,x)::tt -> canonize_args t tt forbidden_names (add_name match_acc (loc,x)) ((loc,x)::var_acc) - |(cano_name,_,ty)::t,c::tt -> + | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> let fresh = Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names ty in canonize_args t tt (fresh::forbidden_names) @@ -1894,7 +1895,7 @@ let interp_rawcontext_evars env evdref k bl = let t' = locate_if_hole (loc_of_glob_constr t) na t in let t = understand_tcc_evars env evdref ~expected_type:IsType t' in - let d = (na,None,t) in + let d = LocalAssum (na,t) in let impls = if k == Implicit then let na = match na with Name n -> Some n | Anonymous -> None in @@ -1904,7 +1905,7 @@ let interp_rawcontext_evars env evdref k bl = (push_rel d env, d::params, succ n, impls) | Some b -> let c = understand_judgment_tcc env evdref b in - let d = (na, Some c.uj_val, c.uj_type) in + let d = LocalDef (na, c.uj_val, c.uj_type) in (push_rel d env, d::params, n, impls)) (env,[],k+1,[]) (List.rev bl) in (env, par), impls diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 391c600ed2..751b03a4a8 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -20,6 +20,7 @@ open Pp open Libobject open Nameops open Misctypes +open Context.Rel.Declaration (*i*) let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" @@ -196,7 +197,7 @@ let combine_params avoid fn applied needed = List.partition (function (t, Some (loc, ExplByName id)) -> - let is_id (_, (na, _, _)) = match na with + let is_id (_, decl) = match get_name decl with | Name id' -> Id.equal id id' | Anonymous -> false in @@ -209,22 +210,22 @@ let combine_params avoid fn applied needed = (fun x -> match x with (t, Some (loc, ExplByName id)) -> id, t | _ -> assert false) named in - let is_unset (_, (_, b, _)) = match b with - | None -> true - | Some _ -> false + let is_unset (_, decl) = match decl with + | LocalAssum _ -> true + | LocalDef _ -> false in let needed = List.filter is_unset needed in let rec aux ids avoid app need = match app, need with [], [] -> List.rev ids, avoid - | app, (_, (Name id, _, _)) :: need when Id.List.mem_assoc id named -> + | app, (_, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need when Id.List.mem_assoc id named -> aux (Id.List.assoc id named :: ids) avoid app need - | (x, None) :: app, (None, (Name id, _, _)) :: need -> + | (x, None) :: app, (None, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need -> aux (x :: ids) avoid app need - | _, (Some cl, (_, _, _) as d) :: need -> + | _, (Some cl, _ as d) :: need -> let t', avoid' = fn avoid d in aux (t' :: ids) avoid' app need @@ -239,8 +240,8 @@ let combine_params avoid fn applied needed = in aux [] avoid applied needed let combine_params_freevar = - fun avoid (_, (na, _, _)) -> - let id' = next_name_away_from na avoid in + fun avoid (_, decl) -> + let id' = next_name_away_from (get_name decl) avoid in (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) let destClassApp cl = diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index b226bfa0af..d0327e5068 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -38,10 +38,10 @@ val make_fresh : Id.Set.t -> Environ.env -> Id.t -> Id.t val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits val combine_params_freevar : - Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) -> + Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t val implicit_application : Id.Set.t -> ?allow_partial:bool -> - (Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) -> + (Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t) -> constr_expr -> constr_expr * Id.Set.t diff --git a/kernel/closure.ml b/kernel/closure.ml index 9bc67b5adb..dc98cc65d0 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -247,8 +247,8 @@ let info_env info = info.i_cache.i_env let rec assoc_defined id = function | [] -> raise Not_found -| (_, None, _) :: ctxt -> assoc_defined id ctxt -| (id', Some c, _) :: ctxt -> +| Context.Named.Declaration.LocalAssum _ :: ctxt -> assoc_defined id ctxt +| Context.Named.Declaration.LocalDef (id', c, _) :: ctxt -> if Id.equal id id' then c else assoc_defined id ctxt let ref_value_cache ({i_cache = cache} as infos) ref = @@ -285,9 +285,9 @@ let defined_rels flags env = let ctx = rel_context env in let len = List.length ctx in let ans = Array.make len None in - let iter i (_, b, _) = match b with - | None -> () - | Some _ -> Array.unsafe_set ans i b + let iter i = function + | Context.Rel.Declaration.LocalAssum _ -> () + | Context.Rel.Declaration.LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b) in let () = List.iteri iter ctx in ans diff --git a/kernel/context.ml b/kernel/context.ml index 3be1e83230..cc1e6f1762 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -33,33 +33,122 @@ open Names Individual declarations are then designated by de Bruijn indexes. *) module Rel = struct - (** Representation of {e local declarations}. - - [(name, None, typ)] represents a {e local assumption}. - In the Reference Manual we denote them as [(name:typ)]. - - [(name, Some value, typ)] represents a {e local definition}. - In the Reference Manual we denote them as [(name := value : typ)]. - *) + (** Representation of {e local declarations}. *) module Declaration = struct - type t = Name.t * Constr.t option * Constr.t - - (** Map all terms in a given declaration. *) - let map f (n, v, ty) = (n, Option.map f v, f ty) - - (** Reduce all terms in a given declaration to a single value. *) - let fold f (_, v, ty) a = f ty (Option.fold_right f v a) + (* local declaration *) + type t = LocalAssum of Name.t * Constr.t (* local assumption *) + | LocalDef of Name.t * Constr.t * Constr.t (* local definition *) + + (** Return the name bound by a given declaration. *) + let get_name = function + | LocalAssum (na,_) + | LocalDef (na,_,_) -> na + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + let get_value = function + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some v + + (** Return the type of the name bound by a given declaration. *) + let get_type = function + | LocalAssum (_,ty) + | LocalDef (_,_,ty) -> ty + + (** Set the name that is bound by a given declaration. *) + let set_name na = function + | LocalAssum (_,ty) -> LocalAssum (na, ty) + | LocalDef (_,v,ty) -> LocalDef (na, v, ty) + + (** Set the type of the bound variable in a given declaration. *) + let set_type ty = function + | LocalAssum (na,_) -> LocalAssum (na, ty) + | LocalDef (na,v,_) -> LocalDef (na, v, ty) + + (** Return [true] iff a given declaration is a local assumption. *) + let is_local_assum = function + | LocalAssum _ -> true + | LocalDef _ -> false + + (** Return [true] iff a given declaration is a local definition. *) + let is_local_def = function + | LocalAssum _ -> false + | LocalDef _ -> true (** Check whether any term in a given declaration satisfies a given predicate. *) - let exists f (_, v, ty) = Option.cata f false v || f ty + let exists f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v || f ty (** Check whether all terms in a given declaration satisfy a given predicate. *) - let for_all f (_, v, ty) = Option.cata f true v && f ty + let for_all f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v && f ty (** Check whether the two given declarations are equal. *) - let equal (n1, v1, ty1) (n2, v2, ty2) = - Name.equal n1 n2 && Option.equal Constr.equal v1 v2 && Constr.equal ty1 ty2 + let equal decl1 decl2 = + match decl1, decl2 with + | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> + Name.equal n1 n2 && Constr.equal ty1 ty2 + | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> + Name.equal n1 n2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 + | _ -> + false + + (** Map the name bound by a given declaration. *) + let map_name f = function + | LocalAssum (na, ty) as decl -> + let na' = f na in + if na == na' then decl else LocalAssum (na', ty) + | LocalDef (na, v, ty) as decl -> + let na' = f na in + if na == na' then decl else LocalDef (na', v, ty) + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + let map_value f = function + | LocalAssum _ as decl -> decl + | LocalDef (na, v, t) as decl -> + let v' = f v in + if v == v' then decl else LocalDef (na, v', t) + + (** Map the type of the name bound by a given declaration. *) + let map_type f = function + | LocalAssum (na, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (na, ty') + | LocalDef (na, v, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalDef (na, v, ty') + + (** Map all terms in a given declaration. *) + let map_constr f = function + | LocalAssum (na, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (na, ty') + | LocalDef (na, v, ty) as decl -> + let v' = f v in + let ty' = f ty in + if v == v' && ty == ty' then decl else LocalDef (na, v', ty') + + (** Perform a given action on all terms in a given declaration. *) + let iter_constr f = function + | LocalAssum (_,ty) -> f ty + | LocalDef (_,v,ty) -> f v; f ty + + (** Reduce all terms in a given declaration to a single value. *) + let fold f decl acc = + match decl with + | LocalAssum (n,ty) -> f ty acc + | LocalDef (n,v,ty) -> f ty (f v acc) + + let to_tuple = function + | LocalAssum (na, ty) -> na, None, ty + | LocalDef (na, v, ty) -> na, Some v, ty + + let of_tuple = function + | n, None, ty -> LocalAssum (n,ty) + | n, Some v, ty -> LocalDef (n,v,ty) end (** Rel-context is represented as a list of declarations. @@ -73,6 +162,21 @@ module Rel = (** Return a new rel-context enriched by with a given inner-most declaration. *) let add d ctx = d :: ctx + (** Return the number of {e local declarations} in a given context. *) + let length = List.length + + (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the local definitions of [Γ] skipped in + [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + let nhyps = + let open Declaration in + let rec nhyps acc = function + | [] -> acc + | LocalAssum _ :: hyps -> nhyps (succ acc) hyps + | LocalDef _ :: hyps -> nhyps acc hyps + in + nhyps 0 + (** Return a declaration designated by a given de Bruijn index. @raise Not_found if the designated de Bruijn index is not present in the designated rel-context. *) let rec lookup n ctx = @@ -81,15 +185,14 @@ module Rel = | n, _ :: sign -> lookup (n-1) sign | _, [] -> raise Not_found + (** Check whether given two rel-contexts are equal. *) + let equal = List.equal Declaration.equal + (** Map all terms in a given rel-context. *) - let map f = - let map_decl (n, body_o, typ as decl) = - let body_o' = Option.smartmap f body_o in - let typ' = f typ in - if body_o' == body_o && typ' == typ then decl else - (n, body_o', typ') - in - List.smartmap map_decl + let map f = List.smartmap (Declaration.map_constr f) + + (** Perform a given action on every declaration in a given rel-context. *) + let iter f = List.iter (Declaration.iter_constr f) (** Reduce all terms in a given rel-context to a single value. Innermost declarations are processed first. *) @@ -99,29 +202,13 @@ module Rel = Outermost declarations are processed first. *) let fold_outside f l ~init = List.fold_right f l init - (** Perform a given action on every declaration in a given rel-context. *) - let iter f = List.iter (fun (_,b,t) -> f t; Option.iter f b) - - (** Return the number of {e local declarations} in a given context. *) - let length = List.length - - (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] - with n = |Δ| and with the local definitions of [Γ] skipped in - [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) - let nhyps = - let rec nhyps acc = function - | [] -> acc - | (_,None,_)::hyps -> nhyps (1+acc) hyps - | (_,Some _,_)::hyps -> nhyps acc hyps in - nhyps 0 - (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] and each {e local definition} is mapped to [false]. *) let to_tags = let rec aux l = function | [] -> l - | (_,Some _,_)::ctx -> aux (true::l) ctx - | (_,None,_)::ctx -> aux (false::l) ctx + | Declaration.LocalDef _ :: ctx -> aux (true::l) ctx + | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx in aux [] (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] @@ -129,8 +216,8 @@ module Rel = [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) let to_extended_list n = let rec reln l p = function - | (_, None, _) :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps - | (_, Some _, _) :: hyps -> reln l (p+1) hyps + | Declaration.LocalAssum _ :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps + | Declaration.LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 @@ -143,38 +230,127 @@ module Rel = Individual declarations are then designated by the identifiers they bind. *) module Named = struct - (** Representation of {e local declarations}. - - [(id, None, typ)] represents a {e local assumption}. - In the Reference Manual we denote them as [(name:typ)]. - - [(id, Some value, typ)] represents a {e local definition}. - In the Reference Manual we denote them as [(name := value : typ)]. - *) + (** Representation of {e local declarations}. *) module Declaration = struct - (** Named-context is represented as a list of declarations. - Inner-most declarations are at the beginning of the list. - Outer-most declarations are at the end of the list. *) - type t = Id.t * Constr.t option * Constr.t - - (** Map all terms in a given declaration. *) - let map = Rel.Declaration.map - - (** Reduce all terms in a given declaration to a single value. *) - let fold f (_, v, ty) a = f ty (Option.fold_right f v a) + (** local declaration *) + type t = LocalAssum of Id.t * Constr.t + | LocalDef of Id.t * Constr.t * Constr.t + + (** Return the identifier bound by a given declaration. *) + let get_id = function + | LocalAssum (id,_) -> id + | LocalDef (id,_,_) -> id + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + let get_value = function + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some v + + (** Return the type of the name bound by a given declaration. *) + let get_type = function + | LocalAssum (_,ty) + | LocalDef (_,_,ty) -> ty + + (** Set the identifier that is bound by a given declaration. *) + let set_id id = function + | LocalAssum (_,ty) -> LocalAssum (id, ty) + | LocalDef (_, v, ty) -> LocalDef (id, v, ty) + + (** Set the type of the bound variable in a given declaration. *) + let set_type ty = function + | LocalAssum (id,_) -> LocalAssum (id, ty) + | LocalDef (id,v,_) -> LocalDef (id, v, ty) + + (** Return [true] iff a given declaration is a local assumption. *) + let is_local_assum = function + | LocalAssum _ -> true + | LocalDef _ -> false + + (** Return [true] iff a given declaration is a local definition. *) + let is_local_def = function + | LocalDef _ -> true + | LocalAssum _ -> false (** Check whether any term in a given declaration satisfies a given predicate. *) - let exists f (_, v, ty) = Option.cata f false v || f ty + let exists f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v || f ty (** Check whether all terms in a given declaration satisfy a given predicate. *) - let for_all f (_, v, ty) = Option.cata f true v && f ty + let for_all f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v && f ty (** Check whether the two given declarations are equal. *) - let equal (i1, v1, ty1) (i2, v2, ty2) = - Id.equal i1 i2 && Option.equal Constr.equal v1 v2 && Constr.equal ty1 ty2 + let equal decl1 decl2 = + match decl1, decl2 with + | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> + Id.equal id1 id2 && Constr.equal ty1 ty2 + | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> + Id.equal id1 id2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 + | _ -> + false + + (** Map the identifier bound by a given declaration. *) + let map_id f = function + | LocalAssum (id, ty) as decl -> + let id' = f id in + if id == id' then decl else LocalAssum (id', ty) + | LocalDef (id, v, ty) as decl -> + let id' = f id in + if id == id' then decl else LocalDef (id', v, ty) + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + let map_value f = function + | LocalAssum _ as decl -> decl + | LocalDef (na, v, t) as decl -> + let v' = f v in + if v == v' then decl else LocalDef (na, v', t) + + (** Map the type of the name bound by a given declaration. *) + let map_type f = function + | LocalAssum (id, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (id, ty') + | LocalDef (id, v, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalDef (id, v, ty') + + (** Map all terms in a given declaration. *) + let map_constr f = function + | LocalAssum (id, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (id, ty') + | LocalDef (id, v, ty) as decl -> + let v' = f v in + let ty' = f ty in + if v == v' && ty == ty' then decl else LocalDef (id, v', ty') + + (** Perform a given action on all terms in a given declaration. *) + let iter_constr f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v; f ty + + (** Reduce all terms in a given declaration to a single value. *) + let fold f decl a = + match decl with + | LocalAssum (_, ty) -> f ty a + | LocalDef (_, v, ty) -> a |> f v |> f ty + + let to_tuple = function + | LocalAssum (id, ty) -> id, None, ty + | LocalDef (id, v, ty) -> id, Some v, ty + + let of_tuple = function + | id, None, ty -> LocalAssum (id, ty) + | id, Some v, ty -> LocalDef (id, v, ty) end + (** Named-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) type t = Declaration.t list (** empty named-context *) @@ -183,22 +359,23 @@ module Named = (** empty named-context *) let add d ctx = d :: ctx + (** Return the number of {e local declarations} in a given named-context. *) + let length = List.length + (** Return a declaration designated by a given de Bruijn index. - @raise Not_found if the designated identifier is not present in the designated named-context. *) - let rec lookup id = function - | (id',_,_ as decl) :: _ when Id.equal id id' -> decl - | _ :: sign -> lookup id sign - | [] -> raise Not_found + @raise Not_found if the designated identifier is not present in the designated named-context. *) let rec lookup id = function + | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl + | _ :: sign -> lookup id sign + | [] -> raise Not_found + + (** Check whether given two named-contexts are equal. *) + let equal = List.equal Declaration.equal (** Map all terms in a given named-context. *) - let map f = - let map_decl (n, body_o, typ as decl) = - let body_o' = Option.smartmap f body_o in - let typ' = f typ in - if body_o' == body_o && typ' == typ then decl else - (n, body_o', typ') - in - List.smartmap map_decl + let map f = List.smartmap (Declaration.map_constr f) + + (** Perform a given action on every declaration in a given named-context. *) + let iter f = List.iter (Declaration.iter_constr f) (** Reduce all terms in a given named-context to a single value. Innermost declarations are processed first. *) @@ -208,18 +385,9 @@ module Named = Outermost declarations are processed first. *) let fold_outside f l ~init = List.fold_right f l init - (** Perform a given action on every declaration in a given named-context. *) - let iter f = List.iter (fun (_,b,t) -> f t; Option.iter f b) - - (** Return the number of {e local declarations} in a given named-context. *) - let length = List.length - - (** Check whether given two named-contexts are equal. *) - let equal = List.equal Declaration.equal - (** Return the set of all identifiers bound in a given named-context. *) let to_vars = - List.fold_left (fun accu (id, _, _) -> Id.Set.add id accu) Id.Set.empty + List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty (** [instance_from_named_context Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local @@ -227,8 +395,8 @@ module Named = gives [Var id1, Var id3]. All [idj] are supposed distinct. *) let to_instance = let filter = function - | (id, None, _) -> Some (Constr.mkVar id) - | (_, Some _, _) -> None + | Declaration.LocalAssum (id, _) -> Some (Constr.mkVar id) + | _ -> None in List.map_filter filter end @@ -238,9 +406,15 @@ module NamedList = module Declaration = struct type t = Id.t list * Constr.t option * Constr.t - let map = Named.Declaration.map + + let map_constr f (ids, copt, ty as decl) = + let copt' = Option.map f copt in + let ty' = f ty in + if copt == copt' && ty == ty' then decl else (ids, copt', ty') end + type t = Declaration.t list + let fold f l ~init = List.fold_right f l init end diff --git a/kernel/context.mli b/kernel/context.mli index 1976e46d33..a69754cc29 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -26,21 +26,32 @@ open Names Individual declarations are then designated by de Bruijn indexes. *) module Rel : sig - (** Representation of {e local declarations}. - - [(name, None, typ)] represents a {e local assumption}. - - [(name, Some value, typ)] represents a {e local definition}. - *) module Declaration : sig - type t = Name.t * Constr.t option * Constr.t + (* local declaration *) + type t = LocalAssum of Name.t * Constr.t (* local assumption *) + | LocalDef of Name.t * Constr.t * Constr.t (* local definition *) - (** Map all terms in a given declaration. *) - val map : (Constr.t -> Constr.t) -> t -> t + (** Return the name bound by a given declaration. *) + val get_name : t -> Name.t - (** Reduce all terms in a given declaration to a single value. *) - val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + val get_value : t -> Constr.t option + + (** Return the type of the name bound by a given declaration. *) + val get_type : t -> Constr.t + + (** Set the name that is bound by a given declaration. *) + val set_name : Name.t -> t -> t + + (** Set the type of the bound variable in a given declaration. *) + val set_type : Constr.t -> t -> t + + (** Return [true] iff a given declaration is a local assumption. *) + val is_local_assum : t -> bool + + (** Return [true] iff a given declaration is a local definition. *) + val is_local_def : t -> bool (** Check whether any term in a given declaration satisfies a given predicate. *) val exists : (Constr.t -> bool) -> t -> bool @@ -50,6 +61,28 @@ sig (** Check whether the two given declarations are equal. *) val equal : t -> t -> bool + + (** Map the name bound by a given declaration. *) + val map_name : (Name.t -> Name.t) -> t -> t + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + val map_value : (Constr.t -> Constr.t) -> t -> t + + (** Map the type of the name bound by a given declaration. *) + val map_type : (Constr.t -> Constr.t) -> t -> t + + (** Map all terms in a given declaration. *) + val map_constr : (Constr.t -> Constr.t) -> t -> t + + (** Perform a given action on all terms in a given declaration. *) + val iter_constr : (Constr.t -> unit) -> t -> unit + + (** Reduce all terms in a given declaration to a single value. *) + val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + + val to_tuple : t -> Name.t * Constr.t option * Constr.t + val of_tuple : Name.t * Constr.t option * Constr.t -> t end (** Rel-context is represented as a list of declarations. @@ -63,6 +96,15 @@ sig (** Return a new rel-context enriched by with a given inner-most declaration. *) val add : Declaration.t -> t -> t + (** Return the number of {e local declarations} in a given context. *) + val length : t -> int + + (** Check whether given two rel-contexts are equal. *) + val equal : t -> t -> bool + + (** Return the number of {e local assumptions} in a given rel-context. *) + val nhyps : t -> int + (** Return a declaration designated by a given de Bruijn index. @raise Not_found if the designated de Bruijn index outside the range. *) val lookup : int -> t -> Declaration.t @@ -70,6 +112,9 @@ sig (** Map all terms in a given rel-context. *) val map : (Constr.t -> Constr.t) -> t -> t + (** Perform a given action on every declaration in a given rel-context. *) + val iter : (Constr.t -> unit) -> t -> unit + (** Reduce all terms in a given rel-context to a single value. Innermost declarations are processed first. *) val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a @@ -78,15 +123,6 @@ sig Outermost declarations are processed first. *) val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a - (** Perform a given action on every declaration in a given rel-context. *) - val iter : (Constr.t -> unit) -> t -> unit - - (** Return the number of {e local declarations} in a given context. *) - val length : t -> int - - (** Return the number of {e local assumptions} in a given rel-context. *) - val nhyps : t -> int - (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] and each {e local definition} is mapped to [false]. *) val to_tags : t -> bool list @@ -104,21 +140,32 @@ end Individual declarations are then designated by the identifiers they bind. *) module Named : sig - (** Representation of {e local declarations}. - - [(id, None, typ)] represents a {e local assumption}. - - [(id, Some value, typ)] represents a {e local definition}. - *) + (** Representation of {e local declarations}. *) module Declaration : sig - type t = Id.t * Constr.t option * Constr.t + type t = LocalAssum of Id.t * Constr.t + | LocalDef of Id.t * Constr.t * Constr.t - (** Map all terms in a given declaration. *) - val map : (Constr.t -> Constr.t) -> t -> t + (** Return the identifier bound by a given declaration. *) + val get_id : t -> Id.t - (** Reduce all terms in a given declaration to a single value. *) - val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + val get_value : t -> Constr.t option + + (** Return the type of the name bound by a given declaration. *) + val get_type : t -> Constr.t + + (** Set the identifier that is bound by a given declaration. *) + val set_id : Id.t -> t -> t + + (** Set the type of the bound variable in a given declaration. *) + val set_type : Constr.t -> t -> t + + (** Return [true] iff a given declaration is a local assumption. *) + val is_local_assum : t -> bool + + (** Return [true] iff a given declaration is a local definition. *) + val is_local_def : t -> bool (** Check whether any term in a given declaration satisfies a given predicate. *) val exists : (Constr.t -> bool) -> t -> bool @@ -128,6 +175,28 @@ sig (** Check whether the two given declarations are equal. *) val equal : t -> t -> bool + + (** Map the identifier bound by a given declaration. *) + val map_id : (Id.t -> Id.t) -> t -> t + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + val map_value : (Constr.t -> Constr.t) -> t -> t + + (** Map the type of the name bound by a given declaration. *) + val map_type : (Constr.t -> Constr.t) -> t -> t + + (** Map all terms in a given declaration. *) + val map_constr : (Constr.t -> Constr.t) -> t -> t + + (** Perform a given action on all terms in a given declaration. *) + val iter_constr : (Constr.t -> unit) -> t -> unit + + (** Reduce all terms in a given declaration to a single value. *) + val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + + val to_tuple : t -> Id.t * Constr.t option * Constr.t + val of_tuple : Id.t * Constr.t option * Constr.t -> t end (** Rel-context is represented as a list of declarations. @@ -141,13 +210,22 @@ sig (** Return a new rel-context enriched by with a given inner-most declaration. *) val add : Declaration.t -> t -> t + (** Return the number of {e local declarations} in a given named-context. *) + val length : t -> int + (** Return a declaration designated by an identifier of the variable bound in that declaration. @raise Not_found if the designated identifier is not bound in a given named-context. *) val lookup : Id.t -> t -> Declaration.t + (** Check whether given two rel-contexts are equal. *) + val equal : t -> t -> bool + (** Map all terms in a given named-context. *) val map : (Constr.t -> Constr.t) -> t -> t + (** Perform a given action on every declaration in a given named-context. *) + val iter : (Constr.t -> unit) -> t -> unit + (** Reduce all terms in a given named-context to a single value. Innermost declarations are processed first. *) val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a @@ -156,15 +234,6 @@ sig Outermost declarations are processed first. *) val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a - (** Perform a given action on every declaration in a given named-context. *) - val iter : (Constr.t -> unit) -> t -> unit - - (** Return the number of {e local declarations} in a given named-context. *) - val length : t -> int - - (** Check whether given two named-contexts are equal. *) - val equal : t -> t -> bool - (** Return the set of all identifiers bound in a given named-context. *) val to_vars : t -> Id.Set.t @@ -180,7 +249,7 @@ sig module Declaration : sig type t = Id.t list * Constr.t option * Constr.t - val map : (Constr.t -> Constr.t) -> t -> t + val map_constr : (Constr.t -> Constr.t) -> t -> t end type t = Declaration.t list diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 3ab6983d8a..d2106f8609 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -201,8 +201,11 @@ let cook_constant env { from = cb; info } = cb.const_body in let const_hyps = - Context.Named.fold_outside (fun (h,_,_) hyps -> - List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps) + Context.Named.fold_outside (fun decl hyps -> + let open Context.Named.Declaration in + let h = get_id decl in + List.filter (fun decl -> let id = get_id decl in + not (Id.equal id h)) hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with | RegularArity t -> diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 8f60216afa..cfbb89f06c 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -189,16 +189,18 @@ and slot_for_fv env fv = let nv = Pre_env.lookup_named_val id env in begin match force_lazy_val nv with | None -> - let _, b, _ = Context.Named.lookup id env.env_named_context in - fill_fv_cache nv id val_of_named idfun b + let open Context.Named in + let open Context.Named.Declaration in + fill_fv_cache nv id val_of_named idfun (lookup id env.env_named_context |> get_value) | Some (v, _) -> v end | FVrel i -> let rv = Pre_env.lookup_rel_val i env in begin match force_lazy_val rv with | None -> - let _, b, _ = Context.Rel.lookup i env.env_rel_context in - fill_fv_cache rv i val_of_rel env_of_rel b + let open Context.Rel in + let open Context.Rel.Declaration in + fill_fv_cache rv i val_of_rel env_of_rel (lookup i env.env_rel_context |> get_value) | Some (v, _) -> v end | FVuniv_var idu -> diff --git a/kernel/declareops.ml b/kernel/declareops.ml index f73eea030f..cb67135ad4 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -87,10 +87,18 @@ let is_opaque cb = match cb.const_body with (** {7 Constant substitutions } *) -let subst_rel_declaration sub (id,copt,t as x) = - let copt' = Option.smartmap (subst_mps sub) copt in - let t' = subst_mps sub t in - if copt == copt' && t == t' then x else (id,copt',t') +let subst_rel_declaration sub x = + let open Context.Rel.Declaration in + match x with + | LocalAssum (id,t) -> + let t' = subst_mps sub t in + if t == t' then x + else LocalAssum (id,t') + | LocalDef (id,v,t) -> + let v' = subst_mps sub v in + let t' = subst_mps sub t in + if v == v' && t == t' then x + else LocalDef (id,v',t') let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) @@ -140,11 +148,20 @@ let subst_const_body sub cb = share internal fields (e.g. constr), and not the records themselves. But would it really bring substantial gains ? *) -let hcons_rel_decl ((n,oc,t) as d) = - let n' = Names.Name.hcons n - and oc' = Option.smartmap Term.hcons_constr oc - and t' = Term.hcons_types t - in if n' == n && oc' == oc && t' == t then d else (n',oc',t') +let hcons_rel_decl d = + let open Context.Rel.Declaration in + match d with + | LocalAssum (n,t) -> + let n' = Names.Name.hcons n + and t' = Term.hcons_types t in + if n' == n && t' == t then d + else LocalAssum (n',t') + | LocalDef (n,v,t) -> + let n' = Names.Name.hcons n + and v' = Term.hcons_constr v + and t' = Term.hcons_types t in + if n' == n && v' == v && t' == t then d + else LocalDef (n',v',t') let hcons_rel_context l = List.smartmap hcons_rel_decl l diff --git a/kernel/environ.ml b/kernel/environ.ml index 847e1d08f9..1089dff92c 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -72,9 +72,8 @@ let lookup_rel n env = Context.Rel.lookup n env.env_rel_context let evaluable_rel n env = - match lookup_rel n env with - | (_,Some _,_) -> true - | _ -> false + let open Context.Rel.Declaration in + lookup_rel n env |> is_local_def let nb_rel env = env.env_nb_rel @@ -83,7 +82,8 @@ let push_rel = push_rel let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = - let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in + let open Context.Rel.Declaration in + let ctxt = Array.map2_i (fun i na t -> LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt let fold_rel_context f env ~init = @@ -107,17 +107,8 @@ let named_vals_of_val = snd (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) -let map_named_val f (ctxt,ctxtv) = - let rec map ctx = match ctx with - | [] -> [] - | (id, body, typ) :: rem -> - let body' = Option.smartmap f body in - let typ' = f typ in - let rem' = map rem in - if body' == body && typ' == typ && rem' == rem then ctx - else (id, body', typ') :: rem' - in - (map ctxt, ctxtv) +let map_named_val f = + on_fst (Context.Named.map f) let empty_named_context = Context.Named.empty @@ -138,10 +129,10 @@ let eq_named_context_val c1 c2 = (* A local const is evaluable if it is defined *) let named_type id env = - let (_,_,t) = lookup_named id env in t + lookup_named id env |> Context.Named.Declaration.get_type let named_body id env = - let (_,b,_) = lookup_named id env in b + lookup_named id env |> Context.Named.Declaration.get_value let evaluable_named id env = match named_body id env with @@ -426,15 +417,16 @@ let global_vars_set env constr = contained in the types of the needed variables. *) let really_needed env needed = + let open Context.Named.Declaration in Context.Named.fold_inside - (fun need (id,copt,t) -> - if Id.Set.mem id need then + (fun need decl -> + if Id.Set.mem (get_id decl) need then let globc = - match copt with - | None -> Id.Set.empty - | Some c -> global_vars_set env c in + match decl with + | LocalAssum _ -> Id.Set.empty + | LocalDef (_,c,_) -> global_vars_set env c in Id.Set.union - (global_vars_set env t) + (global_vars_set env (get_type decl)) (Id.Set.union globc need) else need) ~init:needed @@ -443,8 +435,9 @@ let really_needed env needed = let keep_hyps env needed = let really_needed = really_needed env needed in Context.Named.fold_outside - (fun (id,_,_ as d) nsign -> - if Id.Set.mem id really_needed then Context.Named.add d nsign + (fun d nsign -> + let open Context.Named.Declaration in + if Id.Set.mem (get_id d) really_needed then Context.Named.add d nsign else nsign) (named_context env) ~init:empty_named_context @@ -494,11 +487,12 @@ let compile_constant_body = Cbytegen.compile_constant_body false exception Hyp_not_found let apply_to_hyp (ctxt,vals) id f = + let open Context.Named.Declaration in let rec aux rtail ctxt vals = match ctxt, vals with - | (idc,c,ct as d)::ctxt, v::vals -> - if Id.equal idc id then - (f ctxt d rtail)::ctxt, v::vals + | d::ctxt, v::vals -> + if Id.equal (get_id d) id then + (f ctxt d rtail)::ctxt, v::vals else let ctxt',vals' = aux (d::rtail) ctxt vals in d::ctxt', v::vals' @@ -507,10 +501,11 @@ let apply_to_hyp (ctxt,vals) id f = in aux [] ctxt vals let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = + let open Context.Named.Declaration in let rec aux ctxt vals = match ctxt,vals with - | (idc,c,ct as d)::ctxt, v::vals -> - if Id.equal idc id then + | d::ctxt, v::vals -> + if Id.equal (get_id d) id then let sign = ctxt,vals in push_named_context_val (f d sign) sign else @@ -521,10 +516,11 @@ let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = in aux ctxt vals let insert_after_hyp (ctxt,vals) id d check = + let open Context.Named.Declaration in let rec aux ctxt vals = match ctxt, vals with - | (idc,c,ct)::ctxt', v::vals' -> - if Id.equal idc id then begin + | decl::ctxt', v::vals' -> + if Id.equal (get_id decl) id then begin check ctxt; push_named_context_val d (ctxt,vals) end else @@ -537,12 +533,12 @@ let insert_after_hyp (ctxt,vals) id d check = (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value (ctxt, vals) = + let open Context.Named.Declaration in let rec remove_hyps ctxt vals = match ctxt, vals with | [], [] -> [], [] | d :: rctxt, (nid, v) :: rvals -> - let (id, _, _) = d in let ans = remove_hyps rctxt rvals in - if Id.Set.mem id ids then ans + if Id.Set.mem (get_id d) ids then ans else let (rctxt', rvals') = ans in let d' = check_context d in diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index ebc1853d93..df95c93dc5 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -73,8 +73,9 @@ let judge_of_type u = let judge_of_relative env n = try - let (_,_,typ) = lookup_rel n env in - lift n typ + let open Context.Rel.Declaration in + let typ = get_type (lookup_rel n env) in + lift n typ with Not_found -> error_unbound_rel env n @@ -91,7 +92,10 @@ let judge_of_variable env id = (* TODO: check order? *) let check_hyps_inclusion env f c sign = Context.Named.fold_outside - (fun (id,_,ty1) () -> + (fun decl () -> + let open Context.Named.Declaration in + let id = get_id decl in + let ty1 = get_type decl in try let ty2 = named_type id env in if not (eq_constr ty2 ty1) then raise Exit @@ -325,6 +329,7 @@ let type_fixpoint env lna lar vdef vdeft = Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr = + let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> @@ -368,13 +373,13 @@ let rec execute env cstr = | Lambda (name,c1,c2) -> let _ = execute_is_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let c2t = execute env1 c2 in judge_of_abstraction env name c1 c2t | Prod (name,c1,c2) -> let vars = execute_is_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let vars' = execute_is_type env1 c2 in judge_of_product env name vars vars' @@ -382,7 +387,7 @@ let rec execute env cstr = let c1t = execute env c1 in let _c2s = execute_is_type env c2 in let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in - let env1 = push_rel (name,Some c1,c2) env in + let env1 = push_rel (LocalDef (name,c1,c2)) env in let c3t = execute env1 c3 in subst1 c1 c3t diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index a8625009ce..4834f95d15 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -20,6 +20,7 @@ open Reduction open Typeops open Entries open Pp +open Context.Rel.Declaration (* Tell if indices (aka real arguments) contribute to size of inductive type *) (* If yes, this is compatible with the univalent model *) @@ -122,7 +123,7 @@ let infos_and_sort env t = match kind_of_term t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in - let env1 = Environ.push_rel (name,None,varj.utj_val) env in + let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in let max = Universe.sup max (univ_of_sort varj.utj_type) in aux env1 c2 max | _ when is_constructor_head t -> max @@ -168,12 +169,14 @@ let infer_constructor_packet env_ar_par params lc = (* If indices matter *) let cumulate_arity_large_levels env sign = fst (List.fold_right - (fun (_,b,t as d) (lev,env) -> - if Option.is_empty b then + (fun d (lev,env) -> + match d with + | LocalAssum (_,t) -> let tj = infer_type env t in let u = univ_of_sort tj.utj_type in (Universe.sup u lev, push_rel d env) - else lev, push_rel d env) + | LocalDef _ -> + lev, push_rel d env) sign (Universe.type0m,env)) let is_impredicative env u = @@ -184,12 +187,12 @@ let is_impredicative env u = from the most recent and ignoring let-definitions) is not contributing or is Some u_k if its level is u_k and is contributing. *) let param_ccls params = - let fold acc = function (_, None, p) -> + let fold acc = function (LocalAssum (_, p)) -> (let c = strip_prod_assum p in match kind_of_term c with | Sort (Type u) -> Univ.Universe.level u | _ -> None) :: acc - | _ -> acc + | LocalDef _ -> acc in List.fold_left fold [] params @@ -249,7 +252,7 @@ let typecheck_inductive env mie = let full_arity = it_mkProd_or_LetIn arity params in let id = ind.mind_entry_typename in let env_ar' = - push_rel (Name id, None, full_arity) env_ar in + push_rel (LocalAssum (Name id, full_arity)) env_ar in (* (add_constraints cst2 env_ar) in *) (env_ar', (id,full_arity,sign @ params,expltype,deflev,inflev)::l)) (env',[]) @@ -390,7 +393,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = let nhyps = List.length hyps in let rec check k index = function | [] -> () - | (_,Some _,_)::hyps -> check k (index+1) hyps + | LocalDef _ :: hyps -> check k (index+1) hyps | _::hyps -> match kind_of_term (whd_betadeltaiota env lpar.(k)) with | Rel w when Int.equal w index -> check (k-1) (index+1) hyps @@ -412,7 +415,7 @@ if Int.equal nmr 0 then 0 else function ([],_) -> nmr | (_,[]) -> assert false (* |hyps|>=nmr *) - | (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps) + | (lp, LocalDef _ :: hyps) -> find k (index-1) (lp,hyps) | (p::lp,_::hyps) -> ( match kind_of_term (whd_betadeltaiota env p) with | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,hyps) @@ -426,15 +429,15 @@ if Int.equal nmr 0 then 0 else [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = - (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) + (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in let specif = (lookup_mind_specif env mi, u) in let ty = type_of_inductive env specif in let env' = - push_rel (Anonymous,None, - hnf_prod_applist env ty lpar) env in + let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lpar) in + push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in @@ -726,9 +729,9 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params in - let projections (na, b, t) (i, j, kns, pbs, subst, letsubst) = - match b with - | Some c -> + let projections decl (i, j, kns, pbs, subst, letsubst) = + match decl with + | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) let c = liftn 1 j c in @@ -746,7 +749,7 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in (i, j+1, kns, pbs, subst, letsubst) - | None -> + | LocalAssum (na,t) -> match na with | Name id -> let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index dd49c4a1b7..ca29d83f6a 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -17,6 +17,7 @@ open Declareops open Environ open Reduction open Type_errors +open Context.Rel.Declaration type mind_specif = mutual_inductive_body * one_inductive_body @@ -77,10 +78,10 @@ let instantiate_params full t u args sign = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = Context.Rel.fold_outside - (fun (_,copt,_) (largs,subs,ty) -> - match (copt, largs, kind_of_term ty) with - | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) - | (Some b,_,LetIn(_,_,_,t)) -> + (fun decl (largs,subs,ty) -> + match (decl, largs, kind_of_term ty) with + | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) + | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) @@ -152,7 +153,7 @@ let remember_subst u subst = (* Propagate the new levels in the signature *) let make_subst env = let rec make subst = function - | (_,Some _,_)::sign, exp, args -> + | LocalDef _ :: sign, exp, args -> make subst (sign, exp, args) | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in @@ -165,7 +166,7 @@ let make_subst env = (* a useless extra constraint *) let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in make (cons_subst u s subst) (sign, exp, args) - | (na,None,t)::sign, Some u::exp, [] -> + | LocalAssum (na,t) :: sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) (* substitution (when [u] is distinct from all other universes in the *) (* template, it is identity substitution otherwise (ie. when u is *) @@ -314,14 +315,14 @@ let is_correct_arity env c pj ind specif params = let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match kind_of_term pt', ar with - | Prod (na1,a1,t), (_,None,a1')::ar' -> + | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> let () = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in - srec (push_rel (na1,None,a1) env) t ar' + srec (push_rel (LocalAssum (na1,a1)) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (na1,None,a1) env in + let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match kind_of_term (whd_betadeltaiota env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in @@ -330,7 +331,7 @@ let is_correct_arity env c pj ind specif params = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in check_allowed_sort ksort specif - | _, (_,Some _,_ as d)::ar' -> + | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) @@ -482,7 +483,7 @@ let make_renv env recarg tree = genv = [Lazy.lazy_from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = - { env = push_rel (x,None,ty) renv.env; + { env = push_rel (LocalAssum (x,ty)) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -568,14 +569,14 @@ let check_inductive_codomain env p = (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) let ienv_push_var (env, lra) (x,a,ra) = - (push_rel (x,None,a) env, (Norec,ra)::lra) + (push_rel (LocalAssum (x,a)) env, (Norec,ra)::lra) let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) env + let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in + push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in @@ -848,7 +849,7 @@ let filter_stack_domain env ci p stack = let t = whd_betadeltaiota env ar in match stack, kind_of_term t with | elt :: stack', Prod (n,a,c0) -> - let d = (n,None,a) in + let d = LocalAssum (n,a) in let ty, args = decompose_app (whd_betadeltaiota env a) in let elt = match kind_of_term ty with | Ind ind -> @@ -905,10 +906,10 @@ let check_one_fix renv recpos trees def = end else begin - match pi2 (lookup_rel p renv.env) with - | None -> + match lookup_rel p renv.env with + | LocalAssum _ -> List.iter (check_rec_call renv []) l - | Some c -> + | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) @@ -983,10 +984,11 @@ let check_one_fix renv recpos trees def = | Var id -> begin - match pi2 (lookup_named id renv.env) with - | None -> + let open Context.Named.Declaration in + match lookup_named id renv.env with + | LocalAssum _ -> List.iter (check_rec_call renv []) l - | Some c -> + | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with (FixGuardError _) -> check_rec_call renv stack (applist(c,l)) @@ -1040,7 +1042,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = match kind_of_term (whd_betadeltaiota env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in if Int.equal n (k + 1) then (* get the inductive type of the fixpoint *) let (mind, _) = @@ -1090,7 +1092,7 @@ let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match kind_of_term b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (x, None, a) env) b + codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> @@ -1131,7 +1133,7 @@ let check_one_cofix env nbfix def deftype = | Lambda (x,a,b) -> let () = assert (List.is_empty args) in if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in check_rec_call env' alreadygrd (n+1) tree vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 711096b2b1..47274a5cd5 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1832,24 +1832,25 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = - let (_,body,_) = Context.Rel.lookup n env.env_rel_context in + let decl = Context.Rel.lookup n env.env_rel_context in let n = Context.Rel.length env.env_rel_context - n in - match body with - | Some t -> + let open Context.Rel.Declaration in + match decl with + | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Grel n, code)::auxdefs - | None -> + | LocalAssum _ -> Glet(Grel n, MLprimitive (Mk_rel n))::auxdefs and compile_named env sigma univ auxdefs id = - let (_,body,_) = Context.Named.lookup id env.env_named_context in - match body with - | Some t -> + let open Context.Named.Declaration in + match Context.Named.lookup id env.env_named_context with + | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Gnamed id, code)::auxdefs - | None -> + | LocalAssum _ -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 01f59df15a..91b40be7e9 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -727,7 +727,8 @@ let optimize lam = let lambda_of_constr env sigma c = set_global_env env; let env = Renv.make () in - let ids = List.rev_map (fun (id, _, _) -> id) !global_env.env_rel_context in + let open Context.Rel.Declaration in + let ids = List.rev_map get_name !global_env.env_rel_context in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env sigma c in (* if Flags.vm_draw_opt () then begin diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 4c1b2c5a64..99d99e6940 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -18,6 +18,7 @@ open Names open Univ open Term open Declarations +open Context.Named.Declaration (* The type of environments. *) @@ -124,18 +125,16 @@ let env_of_rel n env = (* Named context *) let push_named_context_val d (ctxt,vals) = - let id,_,_ = d in let rval = ref VKnone in - Context.Named.add d ctxt, (id,rval)::vals + Context.Named.add d ctxt, (get_id d,rval)::vals let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) - let id,body,_ = d in let rval = ref VKnone in { env_globals = env.env_globals; env_named_context = Context.Named.add d env.env_named_context; - env_named_vals = (id, rval) :: env.env_named_vals; + env_named_vals = (get_id d, rval) :: env.env_named_vals; env_rel_context = env.env_rel_context; env_rel_val = env.env_rel_val; env_nb_rel = env.env_nb_rel; diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 40b80cc5e9..cfc286135d 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -24,6 +24,7 @@ open Univ open Environ open Closure open Esubst +open Context.Rel.Declaration let rec is_empty_stack = function [] -> true @@ -739,7 +740,7 @@ let dest_prod env = let t = whd_betadeltaiota env c in match kind_of_term t with | Prod (n,a,c0) -> - let d = (n,None,a) in + let d = LocalAssum (n,a) in decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in @@ -751,10 +752,10 @@ let dest_prod_assum env = let rty = whd_betadeltaiota_nolet env ty in match kind_of_term rty with | Prod (x,t,c) -> - let d = (x,None,t) in + let d = LocalAssum (x,t) in prodec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in + let d = LocalDef (x,b,t) in prodec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> @@ -769,10 +770,10 @@ let dest_lam_assum env = let rty = whd_betadeltaiota_nolet env ty in match kind_of_term rty with | Lambda (x,t,c) -> - let d = (x,None,t) in + let d = LocalAssum (x,t) in lamec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in + let d = LocalDef (x,b,t) in lamec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index e56a6e0999..8a402322f0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -60,6 +60,7 @@ open Util open Names open Declarations +open Context.Named.Declaration (** {6 Safe environments } @@ -362,7 +363,8 @@ let check_required current_libs needed = hypothesis many many times, and the check performed here would cost too much. *) -let safe_push_named (id,_,_ as d) env = +let safe_push_named d env = + let id = get_id d in let _ = try let _ = Environ.lookup_named id env in @@ -383,13 +385,13 @@ let push_named_def (id,de) senv = (Opaqueproof.force_constraints (Environ.opaque_tables senv.env) o) | _ -> assert false in let senv' = push_context_set poly univs senv in - let env'' = safe_push_named (id,Some c,typ) senv'.env in + let env'' = safe_push_named (LocalDef (id,c,typ)) senv'.env in univs, {senv' with env=env''} let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in let t = Term_typing.translate_local_assum senv'.env t in - let env'' = safe_push_named (id,None,t) senv'.env in + let env'' = safe_push_named (LocalAssum (id,t)) senv'.env in {senv' with env=env''} diff --git a/kernel/term.ml b/kernel/term.ml index 9ba45f5403..4416770fe4 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -383,40 +383,46 @@ let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) -let mkProd_or_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> mkLetIn (na, b, t, c) - -let mkNamedProd_or_LetIn (id,body,t) c = - match body with - | None -> mkNamedProd id t c - | Some b -> mkNamedLetIn id b t c +let mkProd_or_LetIn decl c = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) + +let mkNamedProd_or_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedProd id t c + | LocalDef (id,b,t) -> mkNamedLetIn id b t c (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) -let mkProd_wo_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> subst1 b c - -let mkNamedProd_wo_LetIn (id,body,t) c = - match body with - | None -> mkNamedProd id t c - | Some b -> subst1 b (subst_var id c) +let mkProd_wo_LetIn decl c = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (na,b,t) -> subst1 b c + +let mkNamedProd_wo_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedProd id t c + | LocalDef (id,b,t) -> subst1 b (subst_var id c) (* non-dependent product t1 -> t2 *) let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) (* Constructs either [[x:t]c] or [[x=b:t]c] *) -let mkLambda_or_LetIn (na,body,t) c = - match body with - | None -> mkLambda (na, t, c) - | Some b -> mkLetIn (na, b, t, c) - -let mkNamedLambda_or_LetIn (id,body,t) c = - match body with - | None -> mkNamedLambda id t c - | Some b -> mkNamedLetIn id b t c +let mkLambda_or_LetIn decl c = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (na,t) -> mkLambda (na, t, c) + | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) + +let mkNamedLambda_or_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedLambda id t c + | LocalDef (id,b,t) -> mkNamedLetIn id b t c (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = @@ -576,10 +582,11 @@ let decompose_lam_n n = (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod_assum = + let open Context.Rel.Declaration in let rec prodec_rec l c = match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (Context.Rel.add (x,None,t) l) c - | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (x,Some b,t) l) c + | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) c + | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in @@ -589,9 +596,10 @@ let decompose_prod_assum = ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam_assum = let rec lamdec_rec l c = + let open Context.Rel.Declaration in match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (x,None,t) l) c - | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (x,Some b,t) l) c + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in @@ -606,11 +614,13 @@ let decompose_prod_n_assum n = error "decompose_prod_n_assum: integer parameter must be positive"; let rec prodec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (Context.Rel.add (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (x,Some b,t) l) (n-1) c - | Cast (c,_,_) -> prodec_rec l n c - | c -> error "decompose_prod_n_assum: not enough assumptions" + else + let open Context.Rel.Declaration in + match kind_of_term c with + | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c + | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c + | Cast (c,_,_) -> prodec_rec l n c + | c -> error "decompose_prod_n_assum: not enough assumptions" in prodec_rec Context.Rel.empty n @@ -625,11 +635,13 @@ let decompose_lam_n_assum n = error "decompose_lam_n_assum: integer parameter must be positive"; let rec lamdec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (x,Some b,t) l) n c - | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_assum: not enough abstractions" + else + let open Context.Rel.Declaration in + match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c + | Cast (c,_,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n_assum: not enough abstractions" in lamdec_rec Context.Rel.empty n @@ -639,11 +651,13 @@ let decompose_lam_n_decls n = error "decompose_lam_n_decls: integer parameter must be positive"; let rec lamdec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (x,Some b,t) l) (n-1) c - | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_decls: not enough abstractions" + else + let open Context.Rel.Declaration in + match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c + | Cast (c,_,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n_decls: not enough abstractions" in lamdec_rec Context.Rel.empty n @@ -669,10 +683,11 @@ let strip_lam_n n t = snd (decompose_lam_n n t) type arity = Context.Rel.t * sorts let destArity = + let open Context.Rel.Declaration in let rec prodec_rec l c = match kind_of_term c with - | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 979165e49c..2a3ac957fb 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -138,16 +138,17 @@ let check_signatures curmb sl = let skip_trusted_seff sl b e = let rec aux sl b e acc = + let open Context.Rel.Declaration in match sl, kind_of_term b with | (None|Some 0), _ -> b, e, acc | Some sl, LetIn (n,c,ty,bo) -> aux (Some (sl-1)) bo - (Environ.push_rel (n,Some c,ty) e) (`Let(n,c,ty)::acc) + (Environ.push_rel (LocalDef (n,c,ty)) e) (`Let(n,c,ty)::acc) | Some sl, App(hd,arg) -> begin match kind_of_term hd with | Lambda (n,ty,bo) -> aux (Some (sl-1)) bo - (Environ.push_rel (n,None,ty) e) (`Cut(n,ty,arg)::acc) + (Environ.push_rel (LocalAssum (n,ty)) e) (`Cut(n,ty,arg)::acc) | _ -> assert false end | _ -> assert false @@ -251,11 +252,13 @@ let global_vars_set_constant_type env = function ctx ~init:Id.Set.empty let record_aux env s_ty s_bo suggested_expr = + let open Context.Named.Declaration in let in_ty = keep_hyps env s_ty in let v = String.concat " " - (CList.map_filter (fun (id, _,_) -> - if List.exists (fun (id',_,_) -> Id.equal id id') in_ty then None + (CList.map_filter (fun decl -> + let id = get_id decl in + if List.exists (Id.equal id % get_id) in_ty then None else Some (Id.to_string id)) (keep_hyps env s_bo)) in Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) @@ -264,8 +267,9 @@ let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = + let open Context.Named.Declaration in let check declared inferred = - let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in + let mk_set l = List.fold_right Id.Set.add (List.map get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then let l = Id.Set.elements (Idset.diff inferred_set declared_set) in @@ -276,12 +280,13 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) str " used but not declared:" ++ fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in let sort evn l = - List.filter (fun (id,_,_) -> - List.exists (fun (id',_,_) -> Names.Id.equal id id') l) + List.filter (fun decl -> + let id = get_id decl in + List.exists (Names.Id.equal id % get_id) l) (named_context env) in (* We try to postpone the computation of used section variables *) let hyps, def = - let context_ids = List.map pi1 (named_context env) in + let context_ids = List.map get_id (named_context env) in match ctx with | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: @@ -472,7 +477,8 @@ let translate_local_def mb env id centry = | Undef _ -> () | Def _ -> () | OpaqueDef lc -> - let context_ids = List.map pi1 (named_context env) in + let open Context.Named.Declaration in + let context_ids = List.map get_id (named_context env) in let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Opaqueproof.force_proof (opaque_tables env) lc) in diff --git a/kernel/typeops.ml b/kernel/typeops.ml index f31cba0a8a..eeb12a2b49 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -77,8 +77,9 @@ let judge_of_type u = (*s Type of a de Bruijn index. *) let judge_of_relative env n = + let open Context.Rel.Declaration in try - let (_,_,typ) = lookup_rel n env in + let typ = get_type (lookup_rel n env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> @@ -98,18 +99,20 @@ let judge_of_variable env id = variables of the current env. Order does not have to be checked assuming that all names are distinct *) let check_hyps_inclusion env c sign = + let open Context.Named.Declaration in Context.Named.fold_outside - (fun (id,b1,ty1) () -> + (fun d1 () -> + let id = get_id d1 in try - let (_,b2,ty2) = lookup_named id env in - conv env ty2 ty1; - (match b2,b1 with - | None, None -> () - | None, Some _ -> + let d2 = lookup_named id env in + conv env (get_type d2) (get_type d1); + (match d2,d1 with + | LocalAssum _, LocalAssum _ -> () + | LocalAssum _, LocalDef _ -> (* This is wrong, because we don't know if the body is needed or not for typechecking: *) () - | Some _, None -> raise NotConvertible - | Some b2, Some b1 -> conv env b2 b1); + | LocalDef _, LocalAssum _ -> raise NotConvertible + | LocalDef (_,b2,_), LocalDef (_,b1,_) -> conv env b2 b1); with Not_found | NotConvertible | Option.Heterogeneous -> error_reference_variables env id c) sign @@ -124,9 +127,10 @@ let extract_level env p = match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None let extract_context_levels env l = - let fold l (_, b, p) = match b with - | None -> extract_level env p :: l - | _ -> l + let open Context.Rel.Declaration in + let fold l = function + | LocalAssum (_,p) -> extract_level env p :: l + | LocalDef _ -> l in List.fold_left fold [] l @@ -416,6 +420,7 @@ let type_fixpoint env lna lar vdefj = Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr = + let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> @@ -458,13 +463,13 @@ let rec execute env cstr = | Lambda (name,c1,c2) -> let varj = execute_type env c1 in - let env1 = push_rel (name,None,varj.utj_val) env in + let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in let j' = execute env1 c2 in judge_of_abstraction env name varj j' | Prod (name,c1,c2) -> let varj = execute_type env c1 in - let env1 = push_rel (name,None,varj.utj_val) env in + let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in let varj' = execute_type env1 c2 in judge_of_product env name varj varj' @@ -472,7 +477,7 @@ let rec execute env cstr = let j1 = execute env c1 in let j2 = execute_type env c2 in let _ = judge_of_cast env j1 DEFAULTcast j2 in - let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let env1 = push_rel (LocalDef (name,j1.uj_val,j2.utj_val)) env in let j' = execute env1 c3 in judge_of_letin env name j1 j2 j' @@ -550,10 +555,10 @@ let infer_v env cv = let infer_local_decl env id = function | LocalDef c -> let j = infer env c in - (Name id, Some j.uj_val, j.uj_type) + Context.Rel.Declaration.LocalDef (Name id, j.uj_val, j.uj_type) | LocalAssum c -> let j = infer env c in - (Name id, None, assumption_of_judgment env j) + Context.Rel.Declaration.LocalAssum (Name id, assumption_of_judgment env j) let infer_local_decls env decls = let rec inferec env = function diff --git a/kernel/vars.ml b/kernel/vars.ml index 4554c6be17..b935ab6b91 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -8,6 +8,7 @@ open Names open Esubst +open Context.Rel.Declaration (*********************) (* Occurring *) @@ -159,17 +160,17 @@ let substnl laml n c = substn_many (make_subst laml) n c let substl laml c = substn_many (make_subst laml) 0 c let subst1 lam c = substn_many [|make_substituend lam|] 0 c -let substnl_decl laml k r = Context.Rel.Declaration.map (fun c -> substnl laml k c) r -let substl_decl laml r = Context.Rel.Declaration.map (fun c -> substnl laml 0 c) r -let subst1_decl lam r = Context.Rel.Declaration.map (fun c -> subst1 lam c) r +let substnl_decl laml k r = map_constr (fun c -> substnl laml k c) r +let substl_decl laml r = map_constr (fun c -> substnl laml 0 c) r +let subst1_decl lam r = map_constr (fun c -> subst1 lam c) r (* Build a substitution from an instance, inserting missing let-ins *) let subst_of_rel_context_instance sign l = let rec aux subst sign l = match sign, l with - | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' - | (_,Some c,_)::sign', args' -> + | LocalAssum _ :: sign', a::args' -> aux (a::subst) sign' args' + | LocalDef (_,c,_)::sign', args' -> aux (substl subst c :: subst) sign' args' | [], [] -> subst | _ -> Errors.anomaly (Pp.str "Instance and signature do not match") diff --git a/lib/util.ml b/lib/util.ml index b67539918d..6e22d6be57 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -88,6 +88,7 @@ let matrix_transpose mat = let identity x = x let compose f g x = f (g x) +let (%) = compose let const x _ = x diff --git a/lib/util.mli b/lib/util.mli index 7923c65a3b..bf342c1e66 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -84,6 +84,7 @@ val matrix_transpose : 'a list list -> 'a list list val identity : 'a -> 'a val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b +val (%) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b val const : 'a -> 'b -> 'a val iterate : ('a -> 'a) -> int -> 'a -> 'a val repeat : int -> ('a -> unit) -> 'a -> unit diff --git a/library/decls.ml b/library/decls.ml index cafdcd0abd..6e21880f1f 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -46,16 +46,20 @@ let constant_kind kn = Cmap.find kn !csttab (** Miscellaneous functions. *) +open Context.Named.Declaration + let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right - (fun (id,c,t as d) signv -> - let d = if variable_opacity id then (id,None,t) else d in + (fun d signv -> + let id = get_id d in + let d = if variable_opacity id then LocalAssum (id, get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = Context.Named.fold_outside - (fun (id,_,_) sec_ids -> + (fun d sec_ids -> + let id = get_id d in try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids with Not_found -> sec_ids) (Environ.named_context (Global.env())) diff --git a/library/heads.ml b/library/heads.ml index 8124d3474f..4c9b789769 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -15,6 +15,7 @@ open Environ open Globnames open Libobject open Lib +open Context.Named.Declaration (** Characterization of the head of a term *) @@ -63,9 +64,9 @@ let kind_of_head env t = (try on_subterm k l b (variable_head id) with Not_found -> (* a goal variable *) - match pi2 (lookup_named id env) with - | Some c -> aux k l c b - | None -> NotImmediatelyComputableHead) + match lookup_named id env with + | LocalDef (_,c,_) -> aux k l c b + | LocalAssum _ -> NotImmediatelyComputableHead) | Const (cst,_) -> (try on_subterm k l b (constant_head cst) with Not_found -> @@ -132,8 +133,8 @@ let compute_head = function | None -> RigidHead (RigidParameter cst) | Some c -> kind_of_head env c) | EvalVarRef id -> - (match pi2 (Global.lookup_named id) with - | Some c when not (Decls.variable_opacity id) -> + (match Global.lookup_named id with + | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> kind_of_head (Global.env()) c | _ -> RigidHead (RigidVar id)) diff --git a/library/impargs.ml b/library/impargs.ml index f5f6a3eba7..4e344a9543 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -165,6 +165,7 @@ let update pos rig (na,st) = (* modified is_rigid_reference with a truncated env *) let is_flexible_reference env bound depth f = + let open Context.Named.Declaration in match kind_of_term f with | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true @@ -173,8 +174,7 @@ let is_flexible_reference env bound depth f = let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> - let (_, value, _) = Environ.lookup_named id env in - begin match value with None -> false | _ -> true end + Environ.lookup_named id env |> is_local_def | Ind _ | Construct _ -> false | _ -> true @@ -234,13 +234,14 @@ let find_displayed_name_in all avoid na (_,b as envnames_b) = let compute_implicits_gen strict strongly_strict revpat contextual all env t = let rigid = ref true in + let open Context.Rel.Declaration in let rec aux env avoid n names t = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (na,a,b) -> let na',avoid' = find_displayed_name_in all avoid na (names,b) in add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1)) - (aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b) + (aux (push_rel (LocalAssum (na',a)) env) avoid' (n+1) (na'::names) b) | _ -> rigid := is_rigid_head t; let names = List.rev names in @@ -252,7 +253,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = match kind_of_term (whd_betadeltaiota env t) with | Prod (na,a,b) -> let na',avoid = find_displayed_name_in all [] na ([],b) in - let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in + let v = aux (push_rel (LocalAssum (na',a)) env) avoid 1 [na'] b in !rigid, Array.to_list v | _ -> true, [] @@ -427,7 +428,7 @@ let compute_mib_implicits flags manual kn = (Array.mapi (* No need to lift, arities contain no de Bruijn *) (fun i mip -> (** No need to care about constraints here *) - (Name mip.mind_typename, None, Global.type_of_global_unsafe (IndRef (kn,i)))) + Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, Global.type_of_global_unsafe (IndRef (kn,i)))) mib.mind_packets) in let env_ar = push_rel_context ar env in let imps_one_inductive i mip = @@ -449,8 +450,8 @@ let compute_all_mib_implicits flags manual kn = let compute_var_implicits flags manual id = let env = Global.env () in - let (_,_,ty) = lookup_named id env in - compute_semi_auto_implicits env flags manual ty + let open Context.Named.Declaration in + compute_semi_auto_implicits env flags manual (get_type (lookup_named id env)) (* Implicits of a global reference. *) diff --git a/library/lib.ml b/library/lib.ml index e4617cafb6..f8bb6bac59 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -428,8 +428,10 @@ let add_section_context ctx = sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = + let open Context.Named.Declaration in let rec aux = function - | (Variable (id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> + | (Variable (id,impl,poly,ctx)::idl, decl::hyps) when Names.Id.equal id (get_id decl) -> + let (id',b,t) = to_tuple decl in let l, r = aux (idl,hyps) in (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r | (Variable (_,_,poly,ctx)::idl,hyps) -> @@ -448,7 +450,10 @@ let instance_from_variable_context sign = | [] -> [] in Array.of_list (inst_rec sign) -let named_of_variable_context ctx = List.map (fun (id,_,b,t) -> (id,b,t)) ctx +let named_of_variable_context ctx = let open Context.Named.Declaration in + List.map (function id,_,None,t -> LocalAssum (id,t) + | id,_,Some b,t -> LocalDef (id,b,t)) + ctx let add_section_replacement f g poly hyps = match !sectab with diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index bc3d9ed560..359157a4c1 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -824,7 +824,7 @@ let __eps__ = Id.of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in let {it=gl ; sigma=sigma} = state.gls in - let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in + let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in state.gls<- gls; id diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 09d9cf0195..e5b68af8e8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -23,6 +23,7 @@ open Pp open Errors open Util open Proofview.Notations +open Context.Rel.Declaration let reference dir s = lazy (Coqlib.gen_reference "CC" dir s) @@ -152,7 +153,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma (succ nrels) ff + quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts @@ -167,7 +168,7 @@ let litteral_of_constr env sigma term= else begin try - quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma 1 ff + quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -188,7 +189,8 @@ let make_prb gls depth additionnal_terms = let t = decompose_term env sigma c in ignore (add_term state t)) additionnal_terms; List.iter - (fun (id,_,e) -> + (fun decl -> + let (id,_,e) = Context.Named.Declaration.to_tuple decl in begin let cid=mkVar id in match litteral_of_constr env sigma e with diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 2a44dca219..7cfca53c50 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -403,7 +403,7 @@ let interp_suffices_clause env sigma (hyps,cot)= match hyp with (Hprop st | Hvar st) -> match st.st_label with - Name id -> Environ.push_named (id,None,st.st_it) env0 + Name id -> Environ.push_named (Context.Named.Declaration.LocalAssum (id,st.st_it)) env0 | _ -> env in let nenv = List.fold_right push_one locvars env in nenv,res diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index acee3d6c21..f9399d6824 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -116,7 +116,7 @@ let get_top_stack pts = let get_stack pts = Proof.get_at_focus proof_focus pts let get_last env = match Environ.named_context env with - | (id,_,_)::_ -> id + | decl :: _ -> Context.Named.Declaration.get_id decl | [] -> error "no previous statement to use" diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index f47b355417..22a646b3f8 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -30,6 +30,7 @@ open Namegen open Goptions open Misctypes open Sigma.Notations +open Context.Named.Declaration (* Strictness option *) @@ -229,7 +230,8 @@ let close_previous_case pts = (* automation *) let filter_hyps f gls = - let filter_aux (id,_,_) = + let filter_aux id = + let id = get_id id in if f id then tclIDTAC else @@ -331,11 +333,12 @@ let enstack_subsubgoals env se stack gls= let rc,_ = Reduction.dest_prod env apptype in let rec meta_aux last lenv = function [] -> (last,lenv,[]) - | (nam,_,typ)::q -> + | decl::q -> let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in - (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in + let open Context.Rel.Declaration in + (llast,holes,(nlast,special_nf gls (substl lenv (get_type decl)))::metas) in let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in @@ -411,7 +414,7 @@ let concl_refiner metas body gls = let _A = subst_meta subst typ in let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in - let nenv = Environ.push_named (_x,None,_A) env in + let nenv = Environ.push_named (LocalAssum (_x,_A)) env in let asort = family_of_sort (Typing.sort_of nenv (ref evd) _A) in let nsubst = (n,mkVar _x)::subst in if List.is_empty rest then @@ -606,7 +609,7 @@ let assume_tac hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_hyps_or_theses hyps gls = @@ -616,7 +619,7 @@ let assume_hyps_or_theses hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (id,None,c))) nam) + Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,c)))) nam) | Hprop {st_label=nam;st_it=Thesis (tk)} -> tclTHEN (push_intro_tac @@ -628,7 +631,7 @@ let assume_st hyps gls = (fun st -> tclTHEN (push_intro_tac - (fun id -> Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label)) + (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_st_letin hyps gls = @@ -637,7 +640,7 @@ let assume_st_letin hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (id,Some (fst st.st_it),snd st.st_it))) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (LocalDef (id, fst st.st_it, snd st.st_it)))) st.st_label)) hyps tclIDTAC gls (* suffices *) @@ -731,7 +734,7 @@ let rec consider_match may_intro introduced available expected gls = error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> - tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) + tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) begin match st.st_label with Anonymous -> @@ -799,8 +802,8 @@ let define_tac id args body gls = let cast_tac id_or_thesis typ gls = match id_or_thesis with This id -> - let (_,body,_) = pf_get_hyp gls id in - Proofview.V82.of_tactic (convert_hyp (id,body,typ)) gls + let body = pf_get_hyp gls id |> get_value in + Proofview.V82.of_tactic (convert_hyp (of_tuple (id,body,typ))) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index a47dc5b2fa..5d1551106f 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Context.Named.Declaration + let map_const_entry_body (f:Term.constr->Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body) : Safe_typing.private_constants Entries.const_entry_body = Future.chain ~pure:true x begin fun ((b,ctx),fx) -> @@ -32,7 +34,7 @@ let start_deriving f suchthat lemma = let open Proofview in TCons ( env , sigma , f_type_type , (fun sigma f_type -> TCons ( env , sigma , f_type , (fun sigma ef -> - let env' = Environ.push_named (f , (Some ef) , f_type) env in + let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in let evdref = ref sigma in let suchthat = Constrintern.interp_type_evars env' evdref suchthat in TCons ( env' , !evdref , suchthat , (fun sigma _ -> diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 38aef62e1e..6c57bc2bbd 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -25,6 +25,7 @@ open Globnames open Miniml open Table open Mlutil +open Context.Rel.Declaration (*i*) exception I of inductive_kind @@ -74,7 +75,7 @@ type flag = info * scheme let rec flag_of_type env t : flag = let t = whd_betadeltaiota env none t in match kind_of_term t with - | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c + | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) | Sort _ -> (Info,TypeScheme) | _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default) @@ -247,7 +248,7 @@ let rec extract_type env db j c args = | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kprop | Rel n -> (match lookup_rel n env with - | (_,Some t,_) -> extract_type env db j (lift n t) args + | LocalDef (_,t,_) -> extract_type env db j (lift n t) args | _ -> (* Asks [db] a translation for [n]. *) if n > List.length db then Tunknown @@ -560,7 +561,7 @@ let rec extract_term env mle mlt c args = put_magic_if magic (MLlam (id, d'))) | LetIn (n, c1, t1, c2) -> let id = id_of_name n in - let env' = push_rel (Name id, Some c1, t1) env in + let env' = push_rel (LocalDef (Name id, c1, t1)) env in (* We directly push the args inside the [LetIn]. TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (lift 1) args in @@ -835,7 +836,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt = let decomp_lams_eta_n n m env c t = let rels = fst (splay_prod_n env none n t) in - let rels = List.map (fun (id,_,c) -> (id,c)) rels in + let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in let rels',c = decompose_lam c in let d = n - m in (* we'd better keep rels' as long as possible. *) diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index ae2d059fa2..2ed436c6bf 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -15,6 +15,7 @@ open Tacmach open Util open Declarations open Globnames +open Context.Rel.Declaration let qflag=ref true @@ -139,8 +140,8 @@ let build_atoms gl metagen side cciterm = negative:= unsigned :: !negative end; let v = ind_hyps 0 i l gl in - let g i _ (_,_,t) = - build_rec env polarity (lift i t) in + let g i _ decl = + build_rec env polarity (lift i (get_type decl)) in let f l = List.fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) @@ -150,8 +151,8 @@ let build_atoms gl metagen side cciterm = | Exists(i,l)-> let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in - let g i _ (_,_,t) = - build_rec (var::env) polarity (lift i t) in + let g i _ decl = + build_rec (var::env) polarity (lift i (get_type decl)) in List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in @@ -224,7 +225,7 @@ let build_formula side nam typ gl metagen= | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> - let (_,_,d)=List.last (ind_hyps 0 i l gl).(0) in + let d = get_type (List.last (ind_hyps 0 i l gl).(0)) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index a717cc91ea..797f43f2a0 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -22,6 +22,7 @@ open Formula open Sequent open Names open Misctypes +open Context.Rel.Declaration let compare_instance inst1 inst2= match inst1,inst2 with @@ -117,7 +118,7 @@ let mk_open_instance id idc gl m t= if Int.equal n 0 then evmap, decls else let nid=(fresh_id avoid var_id gl) in let evmap, (c, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in - let decl = (Name nid,None,c) in + let decl = LocalAssum (Name nid,c) in aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in evmap, decls, revt diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index e676a8a936..b0e8f7d25c 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -19,6 +19,7 @@ open Formula open Sequent open Globnames open Locus +open Context.Named.Declaration type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic @@ -34,12 +35,13 @@ let wrap n b continue seq gls= if i<=0 then seq else match nc with []->anomaly (Pp.str "Not the expected number of hyps") - | ((id,_,typ) as nd)::q-> + | nd::q-> + let id = get_id nd in if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else - add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in + add_formula Hyp (VarRef id) (get_type nd) (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 4c0aa6c759..8bc84608e6 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -445,7 +445,11 @@ let is_ineq (h,t) = ;; *) -let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;; +let list_of_sign s = + let open Context.Named.Declaration in + List.map (function LocalAssum (name, typ) -> name, typ + | LocalDef (name, _, typ) -> name, typ) + s;; let mkAppL a = let l = Array.to_list a in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 4eab5f9126..28982c37fe 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -15,6 +15,7 @@ open Tactics open Indfun_common open Libnames open Globnames +open Context.Rel.Declaration (* let msgnl = Pp.msgnl *) @@ -304,11 +305,11 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = in let new_type_of_hyp,ctxt_size,witness_fun = List.fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> + (fun i (end_of_type,ctxt_size,witness_fun) decl -> try let witness = Int.Map.find i sub in - if not (Option.is_empty b') then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) + if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); + (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -536,7 +537,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (scan_type new_context new_t') with Failure "NoChange" -> (* Last thing todo : push the rel in the context and continue *) - scan_type ((x,None,t_x)::context) t' + scan_type (LocalAssum (x,t_x) :: context) t' end end else @@ -736,7 +737,8 @@ let build_proof tclTHEN (Proofview.V82.of_tactic intro) (fun g' -> - let (id,_,_) = pf_last_hyp g' in + let open Context.Named.Declaration in + let id = pf_last_hyp g' |> get_id in let new_term = pf_nf_betaiota g' (mkApp(dyn_infos.info,[|mkVar id|])) @@ -921,7 +923,9 @@ let generalize_non_dep hyp g = let env = Global.env () in let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in let to_revert,_ = - Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> + let open Context.Named.Declaration in + Environ.fold_named_context_reverse (fun (clear,keep) decl -> + let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (Termops.occur_var_in_decl env hyp) keep || Termops.occur_var env hyp hyp_typ @@ -936,7 +940,7 @@ let generalize_non_dep hyp g = ((* observe_tac "thin" *) (thin to_revert)) g -let id_of_decl (na,_,_) = (Nameops.out_name na) +let id_of_decl decl = Nameops.out_name (get_name decl) let var_of_decl decl = mkVar (id_of_decl decl) let revert idl = tclTHEN @@ -1044,7 +1048,8 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a ( fun g' -> let just_introduced = nLastDecls nb_intro_to_do g' in - let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g' ) @@ -1069,11 +1074,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (Name new_id) ) in - let fresh_decl = - (fun (na,b,t) -> - (fresh_id na,b,t) - ) - in + let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; @@ -1120,11 +1121,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam ) in observe (str "full_params := " ++ - prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) + prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) full_params ); observe (str "princ_params := " ++ - prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) + prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) princ_params ); observe (str "fbody_with_full_params := " ++ @@ -1165,7 +1166,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let pte_to_fix,rev_info = List.fold_left_i - (fun i (acc_map,acc_info) (pte,_,_) -> + (fun i (acc_map,acc_info) decl -> + let pte = get_name decl in let infos = info_array.(i) in let type_args,_ = decompose_prod infos.types in let nargs = List.length type_args in @@ -1259,7 +1261,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let args = nLastDecls nb_args g in let fix_body = fix_info.body_with_param in (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let args_id = List.map (fun (id,_,_) -> id) args in + let open Context.Named.Declaration in + let args_id = List.map get_id args in let dyn_infos = { nb_rec_hyps = -100; @@ -1276,7 +1279,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (do_replace evd full_params (fix_info.idx + List.length princ_params) - (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) + (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs @@ -1317,8 +1320,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam [ tclDO nb_args (Proofview.V82.of_tactic intro); (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let args_id = List.map (fun (id,_,_) -> id) args in + let args = nLastDecls nb_args g in + let open Context.Named.Declaration in + let args_id = List.map get_id args in let dyn_infos = { nb_rec_hyps = -100; @@ -1520,7 +1524,7 @@ let prove_principle_for_gen avoid := new_id :: !avoid; Name new_id in - let fresh_decl (na,b,t) = (fresh_id na,b,t) in + let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; @@ -1550,11 +1554,11 @@ let prove_principle_for_gen in let rec_arg_id = match List.rev post_rec_arg with - | (Name id,_,_)::_ -> id + | (LocalAssum (Name id,_) | LocalDef (Name id,_,_)) :: _ -> id | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in + let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in @@ -1582,7 +1586,7 @@ let prove_principle_for_gen ) g in - let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in + let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in let lemma = match !tcc_lemma_ref with | None -> error "No tcc proof !!" @@ -1629,7 +1633,7 @@ let prove_principle_for_gen [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (fun (na,_,_) -> Nameops.out_name na) + (List.rev_map (fun decl -> Nameops.out_name (get_name decl)) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by @@ -1667,7 +1671,7 @@ let prove_principle_for_gen in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = - List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates + List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates in let pte_info = { proving_tac = @@ -1683,7 +1687,7 @@ let prove_principle_for_gen is_mes acc_inv fix_id (!tcc_list@(List.map - (fun (na,_,_) -> (Nameops.out_name na)) + (fun decl -> (Nameops.out_name (get_name decl))) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) @@ -1712,7 +1716,7 @@ let prove_principle_for_gen (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof - (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) + (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches) (List.rev args_ids) ) gl' diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index e2c3bbb978..7a933c04b2 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -8,6 +8,7 @@ open Names open Pp open Entries open Tactics +open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs open Misctypes @@ -32,11 +33,13 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t = match predicates with | [] -> [] - |(Name x,v,t)::predicates -> - let id = Namegen.next_ident_away x avoid in - Hashtbl.add tbl id x; - (Name id,v,t)::(change_predicates_names (id::avoid) predicates) - | (Anonymous,_,_)::_ -> anomaly (Pp.str "Anonymous property binder ") + | decl :: predicates -> + (match Context.Rel.Declaration.get_name decl with + | Name x -> + let id = Namegen.next_ident_away x avoid in + Hashtbl.add tbl id x; + set_name (Name id) decl :: change_predicates_names (id::avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder ")) in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = @@ -46,15 +49,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) - let change_predicate_sort i (x,_,t) = + let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod t in + let args,_ = decompose_prod (get_type decl) in let real_args = if princ_type_info.indarg_in_concl then List.tl args else args in - Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) + Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), + compose_prod real_args (mkSort new_sort)) in let new_predicates = List.map_i @@ -69,7 +73,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | _ -> error "Not a valid predicate" ) in - let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in + let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> @@ -114,7 +118,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Rel n -> begin try match Environ.lookup_rel n env with - | _,_,t when is_dom t -> raise Toberemoved + | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved | _ -> pre_princ,[] with Not_found -> assert false end @@ -159,7 +163,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_x : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (x,None,t) env in + let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b @@ -188,7 +192,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in let new_x : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (x,Some v,t) env in + let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b @@ -227,7 +231,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in it_mkProd_or_LetIn (it_mkProd_or_LetIn - pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) + pre_res (List.map (function Context.Named.Declaration.LocalAssum (id,b) -> LocalAssum (Name (Hashtbl.find tbl id), b) + | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) new_predicates) ) princ_type_info.params @@ -235,10 +240,12 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let change_property_sort evd toSort princ princName = + let open Context.Rel.Declaration in let princ_info = compute_elim_sig princ in - let change_sort_in_predicate (x,v,t) = - (x,None, - let args,ty = decompose_prod t in + let change_sort_in_predicate decl = + LocalAssum + (get_name decl, + let args,ty = decompose_prod (get_type decl) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); compose_prod args (mkSort toSort) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 80de8e764d..8a0a1a064d 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -335,15 +335,17 @@ let raw_push_named (na,raw_value,raw_typ) env = | Name id -> let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in - Environ.push_named (id,value,typ) env + let open Context.Named.Declaration in + Environ.push_named (of_tuple (id,value,typ)) env let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = + let open Context.Rel.Declaration in observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match pat with - | PatVar(_,na) -> Environ.push_rel (na,None,typ) env + | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) typ @@ -351,15 +353,16 @@ let add_pat_variables pat typ env : Environ.env = in let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = fst ( Context.Rel.fold_outside - (fun (na,v,t) (env,ctxt) -> - match na with + (fun decl (env,ctxt) -> + let _,v,t = Context.Rel.Declaration.to_tuple decl in + match Context.Rel.Declaration.get_name decl with | Anonymous -> assert false | Name id -> let new_t = substl ctxt t in @@ -370,7 +373,8 @@ let add_pat_variables pat typ env : Environ.env = Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) ); - (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) + let open Context.Named.Declaration in + (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) @@ -398,7 +402,8 @@ let rec pattern_to_term_and_type env typ = function in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let open Context.Rel.Declaration in + let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = @@ -597,9 +602,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let new_env = + let open Context.Named.Declaration in match n with Anonymous -> env - | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env + | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res @@ -875,7 +881,7 @@ exception Continue *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_glob_constr rt); - + let open Context.Rel.Declaration in match rt with | GProd(_,n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in @@ -895,7 +901,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let new_env = Environ.push_rel (n,None,t') env in + let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -926,7 +932,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let subst_b = if is_in_b then b else replace_var_by_term id rt b in - let new_env = Environ.push_rel (n,None,t') env in + let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env @@ -970,9 +976,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (fun acc var_as_constr arg -> if isRel var_as_constr then - let (na,_,_) = - Environ.lookup_rel (destRel var_as_constr) env - in + let open Context.Rel.Declaration in + let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in match na with | Anonymous -> acc | Name id' -> @@ -1010,7 +1015,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in let new_env = let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - Environ.push_rel (n,None,t') env + Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons @@ -1048,7 +1053,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let new_env = Environ.push_rel (n,None,t') env in + let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1064,7 +1069,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let new_env = Environ.push_rel (n,None,t') env in + let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1085,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> - let new_env = Environ.push_rel (n,None,t') env in + let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1108,7 +1113,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in let type_t' = Typing.unsafe_type_of env evd t' in - let new_env = Environ.push_rel (n,Some t',type_t') env in + let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1132,7 +1137,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = depth t in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let new_env = Environ.push_rel (na,None,t') env in + let new_env = Environ.push_rel (LocalAssum (na,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1254,12 +1259,13 @@ let do_build_inductive let relnames = Array.map mk_rel_id funnames in let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) + let open Context.Named.Declaration in let evd,env = Array.fold_right2 (fun id c (evd,env) -> let evd,t = Typing.type_of env evd (mkConstU c) in evd, - Environ.push_named (id,None,t) + Environ.push_named (LocalAssum (id,t)) (* try *) (* Typing.e_type_of env evd (mkConstU c) *) (* with Not_found -> *) @@ -1298,8 +1304,8 @@ let do_build_inductive *) let rel_arities = Array.mapi rel_arity funsargs in Util.Array.fold_left2 (fun env rel_name rel_ar -> - Environ.push_named (rel_name,None, - fst (with_full_print (Constrintern.interp_constr env evd) rel_ar)) env) env relnames rel_arities + Environ.push_named (LocalAssum (rel_name, + fst (with_full_print (Constrintern.interp_constr env evd) rel_ar))) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d1e1098259..86abf9e2ef 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,3 +1,4 @@ +open Context.Rel.Declaration open Errors open Util open Names @@ -13,10 +14,10 @@ open Decl_kinds open Sigma.Notations let is_rec_info scheme_info = - let test_branche min acc (_,_,br) = + let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in let free_rels_in_br = Termops.free_rels new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br @@ -153,7 +154,8 @@ let build_newrecursive let evdref = ref (Evd.from_env env0) in let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in - (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) + let open Context.Named.Declaration in + (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 0c9d3bb819..56bc4328d1 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -5,6 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) + open Tacexpr open Declarations open Errors @@ -20,6 +21,7 @@ open Indfun_common open Tacmach open Misctypes open Termops +open Context.Rel.Declaration (* Some pretty printing function for debugging purpose *) @@ -134,18 +136,21 @@ let generate_type evd g_to_f f graph i = let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") - | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type + | decl :: fun_ctxt -> fun_ctxt, get_type decl in let rec args_from_decl i accu = function | [] -> accu - | (_, Some _, _) :: l -> + | LocalDef _ :: l -> args_from_decl (succ i) accu l | _ :: l -> let t = mkRel i in args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in + let filter = fun decl -> match get_name decl with + | Name id -> Some id + | Anonymous -> None + in let named_ctxt = List.map_filter filter fun_ctxt in let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in @@ -171,12 +176,12 @@ let generate_type evd g_to_f f graph i = \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(f,args_as_rels)),res_type)::fun_ctxt + LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f - then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* @@ -260,10 +265,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* and built the intro pattern for each of them *) let intro_pats = List.map - (fun (_,_,br_type) -> + (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl))))) ) branches in @@ -390,10 +395,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun ((_,(ctxt,concl))) -> match ctxt with | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") - | hres::res::(x,_,t)::ctxt -> + | hres::res::decl::ctxt -> let res = Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) - ((x,None,t)::ctxt) + (LocalAssum (get_name decl, get_type decl) :: ctxt) in res ) @@ -408,8 +413,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let bindings = let params_bindings,avoid = List.fold_left2 - (fun (bindings,avoid) (x,_,_) p -> - let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -418,8 +423,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes in let lemmas_bindings = List.rev (fst (List.fold_left2 - (fun (bindings,avoid) (x,_,_) p -> - let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -455,9 +460,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes generalize every hypothesis which depends of [x] but [hyp] *) let generalize_dependent_of x hyp g = + let open Context.Named.Declaration in tclMAP (function - | (id,None,t) when not (Id.equal id hyp) && + | LocalAssum (id,t) when not (Id.equal id hyp) && (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) @@ -663,10 +669,10 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let branches = List.rev princ_infos.branches in let intro_pats = List.map - (fun (_,_,br_type) -> + (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type)) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl))) ) branches in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 57782dd71f..c71d9a9ca4 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -24,6 +24,7 @@ open Declarations open Glob_term open Glob_termops open Decl_kinds +open Context.Rel.Declaration (** {1 Utilities} *) @@ -134,9 +135,9 @@ let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in - List.iter (fun (nm, optcstr, tp) -> - print_string (string_of_name nm^":"); - prconstr tp; print_string "\n") + List.iter (fun decl -> + print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); + prconstr (get_type decl); print_string "\n") ib1.mind_arity_ctxt; Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); Array.iteri @@ -459,11 +460,12 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in let _ = prstr "\notherprms1:\n" in let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); + prconstr (get_type decl); prstr "\n") otherprms1 in let _ = prstr "\notherprms2:\n" in let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n") otherprms2 in { ident=id; @@ -823,9 +825,11 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in let arity,_ = List.fold_left - (fun (acc,env) (nm,_,c) -> + (fun (acc,env) decl -> + let nm = Context.Rel.Declaration.get_name decl in + let c = get_type decl in let typ = Constrextern.extern_constr false env Evd.empty c in - let newenv = Environ.push_rel (nm,None,c) env in + let newenv = Environ.push_rel (LocalAssum (nm,c)) env in CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) (shift.funresprms2 @ shift.funresprms1 @@ -852,10 +856,10 @@ let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with - | (nme,None,t) -> + | LocalAssum (nme,t) -> let traw = Detyping.detype false [] (Global.env()) Evd.empty t in GProd (Loc.ghost,nme,Explicit,traw,t2) - | (_,Some _,_) -> assert false + | LocalDef _ -> assert false (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking @@ -969,7 +973,7 @@ let funify_branches relinfo nfuns branch = | Rel i -> let reali = i-shift in (reali>=0 && reali false in (* FIXME: *) - (Anonymous,Some mkProp,mkProp) + LocalDef (Anonymous,mkProp,mkProp) let relprinctype_to_funprinctype relprinctype nfuns = diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index b096783412..09c5aa5673 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -40,7 +40,7 @@ open Eauto open Indfun_common open Sigma.Notations - +open Context.Rel.Declaration (* Ugly things which should not be here *) @@ -181,7 +181,7 @@ let (value_f:constr list -> global_reference -> constr) = ) in let context = List.map - (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) + (fun (x, c) -> LocalAssum (Name x, c)) (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = @@ -678,8 +678,10 @@ let mkDestructEq : let hyps = pf_hyps g in let to_revert = Util.List.map_filter - (fun (id, _, t) -> - if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t) + (fun decl -> + let open Context.Named.Declaration in + let id = get_id decl in + if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in @@ -1253,7 +1255,7 @@ let clear_goals = then Termops.pop b' else if b' == b then t else mkProd(na,t',b') - | _ -> map_constr clear_goal t + | _ -> Term.map_constr clear_goal t in List.map clear_goal @@ -1489,7 +1491,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let env = Global.env() in let evd = ref (Evd.from_env env) in let function_type = interp_type_evars env evd type_of_f in - let env = push_named (function_name,None,function_type) env in + let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let ty = interp_type_evars env evd ~impls:rec_impls eq in let evm, nf = Evarutil.nf_evars_and_universes !evd in @@ -1497,7 +1499,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let function_type = nf function_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in - let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in + let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in let eq' = nf_zeta env_eq' eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) @@ -1515,7 +1517,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in + let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in let relation = fst (*FIXME*)(interp_constr env_with_pre_rec_args diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 7e38109d67..b740649e98 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -28,6 +28,7 @@ open Nametab open Contradiction open Misctypes open Proofview.Notations +open Context.Named.Declaration module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -1695,25 +1696,26 @@ let destructure_hyps = let pf_nf = Tacmach.New.of_old pf_nf gl in let rec loop = function | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) - | (i,body,t)::lit -> + | decl::lit -> + let (i,_,t) = to_tuple decl in begin try match destructurate_prop t with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> (Tacticals.New.tclTHENS (elim_id i) - [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); - onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) + [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); + onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop ((i1,None,t1)::(i2,None,t2)::lit))) + loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit))) + loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) @@ -1724,7 +1726,7 @@ let destructure_hyps = Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> - (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) + (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit)))) ] else loop lit @@ -1735,7 +1737,7 @@ let destructure_hyps = Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) + (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in @@ -1744,7 +1746,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) + (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in @@ -1754,9 +1756,8 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None, - mk_or (mk_and t1 (mk_not t2)) - (mk_and (mk_not t1) t2))::lit)))) + (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2)) + (mk_and (mk_not t1) t2)) :: lit)))) ] | Kimp(t1,t2) -> (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. @@ -1767,14 +1768,14 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) + (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability t in Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) + (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) ] | Kapp(op,[t1;t2]) -> (try @@ -1807,15 +1808,13 @@ let destructure_hyps = match destructurate_type (pf_nf typ) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check - (i,body, - (mkApp (Lazy.force coq_neq, [| t1;t2|])))) + (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + decl)) (loop lit)) | Kapp(Z,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check - (i,body, - (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) + (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + decl)) (loop lit)) | _ -> loop lit end diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 9c22b5adb3..2f3a3e5514 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -13,6 +13,7 @@ open Util open Term open Tacmach open Proof_search +open Context.Named.Declaration let force count lazc = incr count;Lazy.force lazc @@ -128,9 +129,9 @@ let rec make_form atom_env gls term = let rec make_hyps atom_env gls lenv = function [] -> [] - | (_,Some body,typ)::rest -> + | LocalDef (_,body,typ)::rest -> make_hyps atom_env gls (typ::body::lenv) rest - | (id,None,typ)::rest -> + | LocalAssum (id,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in if List.exists (Termops.dependent (mkVar id)) lenv || diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index c9e591bbdf..9a14ac6c79 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -18,7 +18,7 @@ val make_hyps : atom_env -> Proof_type.goal Tacmach.sigma -> Term.types list -> - (Names.Id.t * Term.types option * Term.types) list -> + Context.Named.t -> (Names.Id.t * Proof_search.form) list val rtauto_tac : Proof_type.tactic diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 2cbf3a2650..dd58590923 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -28,6 +28,7 @@ open Evarutil open Evarsolve open Evarconv open Evd +open Context.Rel.Declaration (* Pattern-matching errors *) @@ -272,13 +273,13 @@ let inductive_template evdref env tmloc ind = | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in let (_,evarl,_) = List.fold_right - (fun (na,b,ty) (subst,evarl,n) -> - match b with - | None -> + (fun decl (subst,evarl,n) -> + match decl with + | LocalAssum (na,ty) -> let ty' = substl subst ty in let e = e_new_evar env evdref ~src:(hole_source n) ty' in (e::subst,e::evarl,n+1) - | Some b -> + | LocalDef (na,b,ty) -> (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in applist (mkIndU indu,List.rev evarl) @@ -306,15 +307,15 @@ let binding_vars_of_inductive = function | NotInd _ -> [] | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs -let extract_inductive_data env sigma (_,b,t) = - match b with - | None -> +let extract_inductive_data env sigma decl = + match decl with + | LocalAssum (_,t) -> let tmtyp = try try_find_ind env sigma t None with Not_found -> NotInd (None,t) in let tmtypvars = binding_vars_of_inductive tmtyp in (tmtyp,tmtypvars) - | Some _ -> + | LocalDef (_,_,t) -> (NotInd (None, t), []) let unify_tomatch_with_patterns evdref env loc typ pats realnames = @@ -427,7 +428,7 @@ let remove_current_pattern eqn = let push_current_pattern (cur,ty) eqn = match eqn.patterns with | pat::pats -> - let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in + let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -454,9 +455,9 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } exception NotAdjustable let rec adjust_local_defs loc = function - | (pat :: pats, (_,None,_) :: decls) -> + | (pat :: pats, LocalAssum _ :: decls) -> pat :: adjust_local_defs loc (pats,decls) - | (pats, (_,Some _,_) :: decls) -> + | (pats, LocalDef _ :: decls) -> PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) | [], [] -> [] | _ -> raise NotAdjustable @@ -528,9 +529,10 @@ let dependencies_in_pure_rhs nargs eqns = let deps_columns = matrix_transpose deps_rows in List.map (List.exists (fun x -> x)) deps_columns -let dependent_decl a = function - | (na,None,t) -> dependent a t - | (na,Some c,t) -> dependent a t || dependent a c +let dependent_decl a = + function + | LocalAssum (na,t) -> dependent a t + | LocalDef (na,c,t) -> dependent a t || dependent a c let rec dep_in_tomatch n = function | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l @@ -601,7 +603,7 @@ let relocate_index_tomatch n1 n2 = NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in - Abstract (i, Context.Rel.Declaration.map (relocate_index n1 n2 depth) d) + Abstract (i, map_constr (relocate_index n1 n2 depth) d) :: genrec (depth+1) rest in genrec 0 @@ -634,7 +636,7 @@ let replace_tomatch n c = | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> - Abstract (i, Context.Rel.Declaration.map (replace_term n c depth) d) + Abstract (i, map_constr (replace_term n c depth) d) :: replrec (depth+1) rest in replrec 0 @@ -659,7 +661,7 @@ let rec liftn_tomatch_stack n depth = function NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i let na = merge_name - (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) + (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env t na) avoid)) d na in (na::l,(out_name na)::avoid)) @@ -727,18 +729,16 @@ let get_names env sign eqns = (* We now replace the names y1 .. yn y by the actual names *) (* xi1 .. xin xi to be found in the i-th clause of the matrix *) -let set_declaration_name x (_,c,t) = (x,c,t) - -let recover_initial_subpattern_names = List.map2 set_declaration_name +let recover_initial_subpattern_names = List.map2 set_name let recover_and_adjust_alias_names names sign = let rec aux = function | [],[] -> [] - | x::names, (_,None,t)::sign -> - (x,(alias_of_pat x,None,t)) :: aux (names,sign) - | names, (na,(Some _ as c),t)::sign -> - (PatVar (Loc.ghost,na),(na,c,t)) :: aux (names,sign) + | x::names, LocalAssum (_,t)::sign -> + (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign) + | names, (LocalDef (na,_,_) as decl)::sign -> + (PatVar (Loc.ghost,na), decl) :: aux (names,sign) | _ -> assert false in List.split (aux (names,sign)) @@ -753,11 +753,12 @@ let push_rels_eqn_with_names sign eqn = let sign = recover_initial_subpattern_names subpatnames sign in push_rels_eqn sign eqn -let push_generalized_decl_eqn env n (na,c,t) eqn = - let na = match na with - | Anonymous -> Anonymous - | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in - push_rels_eqn [(na,c,t)] eqn +let push_generalized_decl_eqn env n decl eqn = + match get_name decl with + | Anonymous -> + push_rels_eqn [decl] eqn + | Name _ -> + push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn let drop_alias_eqn eqn = { eqn with alias_stack = List.tl eqn.alias_stack } @@ -765,7 +766,7 @@ let drop_alias_eqn eqn = let push_alias_eqn alias eqn = let aliasname = List.hd eqn.alias_stack in let eqn = drop_alias_eqn eqn in - let alias = set_declaration_name aliasname alias in + let alias = set_name aliasname alias in push_rels_eqn [alias] eqn (**********************************************************************) @@ -931,7 +932,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = in let pred = extract_predicate ccl tms in (* Build the predicate properly speaking *) - let sign = List.map2 set_declaration_name (na::names) sign in + let sign = List.map2 set_name (na::names) sign in it_mkLambda_or_LetIn_name env pred sign (* [expand_arg] is used by [specialize_predicate] @@ -1117,14 +1118,14 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with | [], _ -> brs,tomatch,pred,[] | n::deps, Abstract (i,d) :: tomatch -> - let d = Context.Rel.Declaration.map (nf_evar evd) d in - let is_d = match d with (_, None, _) -> false | _ -> true in + let d = map_constr (nf_evar evd) d in + let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck && Array.exists (is_dependent_branch k) brs then (* Dependency in the current term to match and its dependencies is real *) let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in let inst = match d with - | (_, None, _) -> mkRel n :: inst + | LocalAssum _ -> mkRel n :: inst | _ -> inst in brs, Abstract (i,d) :: tomatch, pred, inst @@ -1186,12 +1187,13 @@ let group_equations pb ind current cstrs mat = let rec generalize_problem names pb = function | [] -> pb, [] | i::l -> - let (na,b,t as d) = Context.Rel.Declaration.map (lift i) (Environ.lookup_rel i pb.env) in let pb',deps = generalize_problem names pb l in - begin match (na, b) with - | Anonymous, Some _ -> pb', deps + let d = map_constr (lift i) (Environ.lookup_rel i pb.env) in + begin match d with + | LocalDef (Anonymous,_,_) -> pb', deps | _ -> - let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *) + (* for better rendering *) + let d = map_type (whd_betaiota !(pb.evdref)) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch (i+1) 1 tomatch in { pb' with @@ -1219,7 +1221,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* that had matched constructor C *) let cs_args = const_info.cs_args in let names,aliasname = get_names pb.env cs_args eqns in - let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in + let typs = List.map2 set_name names cs_args + in (* We build the matrix obtained by expanding the matching on *) (* "C x1..xn as x" followed by a residual matching on eqn into *) @@ -1229,7 +1232,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* We adjust the terms to match in the context they will be once the *) (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *) let typs' = - List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 typs in + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in let extenv = push_rel_context typs pb.env in @@ -1267,7 +1270,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let typs' = List.map2 - (fun (tm,(tmtyp,_),(na,_,_)) deps -> + (fun (tm, (tmtyp,_), decl) deps -> + let na = get_name decl in let na = match curname, na with | Name _, Anonymous -> curname | Name _, Name _ -> na @@ -1391,7 +1395,7 @@ and shift_problem ((current,t),_,na) pb = let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in let pb = { pb with - env = push_rel (na,Some current,ty) pb.env; + env = push_rel (LocalDef (na,current,ty)) pb.env; tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; @@ -1439,7 +1443,7 @@ and compile_generalization pb i d rest = ([false]). *) and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = let f c t = - let alias = (na,Some c,t) in + let alias = LocalDef (na,c,t) in let pb = { pb with env = push_rel alias pb.env; @@ -1575,9 +1579,9 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t = (* \--------------extenv------------/ *) let (p, _, _) = lookup_rel_id x (rel_context extenv) in let rec traverse_local_defs p = - match pi2 (lookup_rel p extenv) with - | Some c -> assert (isRel c); traverse_local_defs (p + destRel c) - | None -> p in + match lookup_rel p extenv with + | LocalDef (_,c,_) -> assert (isRel c); traverse_local_defs (p + destRel c) + | LocalAssum _ -> p in let p = traverse_local_defs p in let u = lift (n' - n) u in try Some (p, u, expand_vars_in_term extenv u) @@ -1622,7 +1626,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = convertible subterms of the substitution *) let rec aux (k,env,subst as x) t = let t = whd_evar !evdref t in match kind_of_term t with - | Rel n when pi2 (lookup_rel n env) != None -> t + | Rel n when is_local_def (lookup_rel n env) -> t | Evar ev -> let ty = get_type_of env !evdref t in let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in @@ -1658,7 +1662,8 @@ let abstract_tycon loc env evdref subst tycon extenv t = List.map (fun a -> not (isRel a) || dependent a u || Int.Set.mem (destRel a) depvl) inst in let named_filter = - List.map (fun (id,_,_) -> dependent (mkVar id) u) + let open Context.Named.Declaration in + List.map (fun d -> dependent (mkVar (get_id d)) u) (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in @@ -1726,7 +1731,7 @@ let build_inversion_problem loc env sigma tms t = List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in - let d = (alias_of_pat pat,None,typ) in + let d = LocalAssum (alias_of_pat pat,typ) in let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = ids_of_context env in @@ -1743,7 +1748,7 @@ let build_inversion_problem loc env sigma tms t = let n = List.length sign in let decls = - List.map_i (fun i d -> (mkRel i, Context.Rel.Declaration.map (lift i) d)) 1 sign in + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in let pb_env = push_rel_context sign env in let decls = @@ -1753,8 +1758,8 @@ let build_inversion_problem loc env sigma tms t = let dep_sign = find_dependencies_signature (List.make n true) decls in let sub_tms = - List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) -> - let na = if List.is_empty deps then Anonymous else force_name na in + List.map2 (fun deps (tm, (tmtyp,_), decl) -> + let na = if List.is_empty deps then Anonymous else force_name (get_name decl) in Pushed (true,((tm,tmtyp),deps,na))) dep_sign decls in let subst = List.map (fun (na,t) -> (na,lift n t)) subst in @@ -1815,7 +1820,8 @@ let build_inversion_problem loc env sigma tms t = let build_initial_predicate arsign pred = let rec buildrec n pred tmnames = function | [] -> List.rev tmnames,pred - | ((na,c,t)::realdecls)::lnames -> + | (decl::realdecls)::lnames -> + let na = get_name decl in let n' = n + List.length realdecls in buildrec (n'+1) pred (force_name na::tmnames) lnames | _ -> assert false @@ -1827,7 +1833,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = match tm with | NotInd (bo,typ) -> (match t with - | None -> [na,Option.map (lift n) bo,lift n typ] + | None -> (match bo with + | None -> [LocalAssum (na, lift n typ)] + | Some b -> [LocalDef (na, lift n b, lift n typ)]) | Some (loc,_,_) -> user_err_loc (loc,"", str"Unexpected type annotation for a term of non inductive type.")) @@ -1845,8 +1853,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = anomaly (Pp.str "Ill-formed 'in' clause in cases"); List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in - (na,None,build_dependent_inductive env0 indf') - ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in + LocalAssum (na, build_dependent_inductive env0 indf') + ::(List.map2 set_name realnal arsign) in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> @@ -2027,7 +2035,7 @@ let constr_of_pat env evdref arsign pat avoid = let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in - (PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, + (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in @@ -2044,7 +2052,8 @@ let constr_of_pat env evdref arsign pat avoid = assert (Int.equal nb_args_constr (List.length args)); let patargs, args, sign, env, n, m, avoid = List.fold_right2 - (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> + (fun decl ua (patargs, args, sign, env, n, m, avoid) -> + let t = get_type decl in let pat', sign', arg', typ', argtypargs, n', avoid = let liftt = liftn (List.length sign) (succ (List.length args)) t in typ env (substl args liftt, []) ua avoid @@ -2066,7 +2075,7 @@ let constr_of_pat env evdref arsign pat avoid = Anonymous -> pat', sign, app, apptype, realargs, n, avoid | Name id -> - let sign = (alias, None, lift m ty) :: sign in + let sign = LocalAssum (alias, lift m ty) :: sign in let avoid = id :: avoid in let sign, i, avoid = try @@ -2078,14 +2087,14 @@ let constr_of_pat env evdref arsign pat avoid = (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in - (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid + LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in - pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid + let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in + pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid (* shadows functional version *) @@ -2100,23 +2109,23 @@ match kind_of_term t with | Rel 0 -> true | _ -> false -let rels_of_patsign l = - List.map (fun ((na, b, t) as x) -> - match b with - | Some t' when is_topvar t' -> (na, None, t) - | _ -> x) l +let rels_of_patsign = + List.map (fun decl -> + match decl with + | LocalDef (na,t',t) when is_topvar t' -> LocalAssum (na,t) + | _ -> decl) let vars_of_ctx ctx = let _, y = - List.fold_right (fun (na, b, t) (prev, vars) -> - match b with - | Some t' when is_topvar t' -> + List.fold_right (fun decl (prev, vars) -> + match decl with + | LocalDef (na,t',t) when is_topvar t' -> prev, (GApp (Loc.ghost, (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> - match na with + match get_name decl with Anonymous -> invalid_arg "vars_of_ctx" | Name n -> n, GVar (Loc.ghost, n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) @@ -2225,7 +2234,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = match ineqs with | None -> [], arity | Some ineqs -> - [Anonymous, None, ineqs], lift 1 arity + [LocalAssum (Anonymous, ineqs)], lift 1 arity in let eqs_rels, arity = decompose_prod_n_assum neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity @@ -2236,7 +2245,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let _btype = evd_comb1 (Typing.type_of env) evdref bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in - let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in + let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = let bref = GVar (Loc.ghost, branch_name) in match vars_of_ctx rhs_rels with @@ -2285,7 +2294,7 @@ let abstract_tomatch env tomatchs tycon = (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, + LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) ([], [], [], tycon) tomatchs in List.rev prev, ctx, tycon @@ -2293,7 +2302,7 @@ let abstract_tomatch env tomatchs tycon = let build_dependent_signature env evdref avoid tomatchs arsign = let avoid = ref avoid in let arsign = List.rev arsign in - let allnames = List.rev_map (List.map pi1) arsign in + let allnames = List.rev_map (List.map get_name) arsign in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in let eqs, neqs, refls, slift, arsign' = List.fold_left2 @@ -2309,11 +2318,15 @@ let build_dependent_signature env evdref avoid tomatchs arsign = (* Build the arity signature following the names in matched terms as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) - let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *) + let app_decl = List.hd arsign in (* The matched argument *) + let appn = get_name app_decl in + let appt = get_type app_decl in let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 - (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> + (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> + let name = get_name decl in + let t = get_type decl in let argt = Retyping.get_type_of env !evdref arg in let eq, refl_arg = if Reductionops.is_conv env !evdref argt t then @@ -2331,16 +2344,16 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let previd, id = let name = match kind_of_term arg with - Rel n -> pi1 (lookup_rel n env) + Rel n -> get_name (lookup_rel n env) | _ -> name in make_prime avoid name in (env, succ nargeqs, - (Name (eq_id avoid previd), None, eq) :: argeqs, + (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, refl_arg :: refl_args, pred slift, - (Name id, b, t) :: argsign')) + set_name (Name id) decl :: argsign')) (env, neqs, [], [], slift, []) args argsign in let eq = mk_JMeq evdref @@ -2351,22 +2364,23 @@ let build_dependent_signature env evdref avoid tomatchs arsign = in let refl_eq = mk_JMeq_refl evdref ty tm in let previd, id = make_prime avoid appn in - (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, + ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, succ nargeqs, refl_eq :: refl_args, pred slift, - (((Name id, appb, appt) :: argsign') :: arsigns)) + ((set_name (Name id) app_decl :: argsign') :: arsigns)) | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) - let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in + let decl = match arsign with [x] -> x | _ -> assert(false) in + let name = get_name decl in let previd, id = make_prime avoid name in - let arsign' = (Name id, b, typ) in + let arsign' = set_name (Name id) decl in let tomatch_ty = type_of_tomatch ty in let eq = mk_eq evdref (lift nar tomatch_ty) (mkRel slift) (lift nar tm) in - ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, + ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, (mk_eq_refl evdref tomatch_ty tm) :: refl_args, pred slift, (arsign' :: []) :: arsigns)) ([], 0, [], nar, []) tomatchs arsign @@ -2440,7 +2454,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in + let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) + | NotInd (Some b, t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = @@ -2513,7 +2529,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* names of aliases will be recovered from patterns (hence Anonymous *) (* here) *) - let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in + let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) + | NotInd (Some b,t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 489a311bc6..9d5a6006de 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -142,6 +142,7 @@ let mu env evdref t = and coerce loc env evdref (x : Term.constr) (y : Term.constr) : (Term.constr -> Term.constr) option = + let open Context.Rel.Declaration in let rec coerce_unify env x y = let x = hnf env !evdref x and y = hnf env !evdref y in try @@ -151,8 +152,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env evdref x y in let dest_prod c = + let open Context.Rel.Declaration in match Reductionops.splay_prod_n env ( !evdref) 1 c with - | [(na,b,t)], c -> (na,t), c + | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c | _ -> raise NoSubtacCoercion in let coerce_application typ typ' c c' l l' = @@ -205,7 +207,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let name' = Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env)) in - let env' = push_rel (name', None, a') env in + let env' = push_rel (LocalAssum (name', a')) env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) let coec1 = app_opt env' evdref c1 (mkRel 1) in @@ -255,7 +257,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | _ -> raise NoSubtacCoercion in let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in - let env' = push_rel (Name Namegen.default_dependent_ident, None, a) env in + let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in let c2 = coerce_unify env' b b' in match c1, c2 with | None, None -> None @@ -475,7 +477,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let name = match name with | Anonymous -> Name Namegen.default_dependent_ident | _ -> name in - let env1 = push_rel (name,None,u1) env in + let open Context.Rel.Declaration in + let env1 = push_rel (LocalAssum (name,u1)) env in let (evd', v1) = inh_conv_coerce_to_fail loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 69c1dfb47a..4fb4112022 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -20,6 +20,7 @@ open Vars open Pattern open Patternops open Misctypes +open Context.Rel.Declaration (*i*) (* Given a term with second-order variables in it, @@ -254,15 +255,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env) + sorec ((na1,na2,t2)::ctx) (Environ.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> @@ -271,7 +272,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in if noccur_between 1 n b2 && noccur_between 1 n' b2' then - let f l (na,_,t) = (Anonymous,na,t)::l in + let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in let ctx_br = List.fold_left f ctx ctx_b2 in let ctx_br' = List.fold_left f ctx ctx_b2' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in @@ -367,21 +368,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2)) | _ -> assert false in - let env' = Environ.push_rel (x,None,c1) env in + let env' = Environ.push_rel (LocalAssum (x,c1)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | Prod (x,c1,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkProd (x, c1, c2)) | _ -> assert false in - let env' = Environ.push_rel (x,None,c1) env in + let env' = Environ.push_rel (LocalAssum (x,c1)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | LetIn (x,c1,t,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2)) | _ -> assert false in - let env' = Environ.push_rel (x,Some c1,t) env in + let env' = Environ.push_rel (LocalDef (x,c1,t)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | App (c1,lc) -> let topdown = true in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index c8ecf91d33..67a8f01aa4 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -24,6 +24,7 @@ open Nametab open Mod_subst open Misctypes open Decl_kinds +open Context.Named.Declaration let dl = Loc.ghost @@ -33,8 +34,15 @@ let print_universes = Flags.univ_print (** If true, prints local context of evars, whatever print_arguments *) let print_evar_arguments = ref false -let add_name na b t (nenv, env) = add_name na nenv, push_rel (na, b, t) env -let add_name_opt na b t (nenv, env) = +let add_name na b t (nenv, env) = + let open Context.Rel.Declaration in + add_name na nenv, push_rel (match b with + | None -> LocalAssum (na,t) + | Some b -> LocalDef (na,b,t) + ) + env + +let add_name_opt na b t (nenv, env) = match t with | None -> Termops.add_name na nenv, env | Some t -> add_name na b t (nenv, env) @@ -510,11 +518,14 @@ let rec detype flags avoid env sigma t = else noparams () | Evar (evk,cl) -> - let bound_to_itself_or_letin (id,b,_) c = - b != None || - try let n = List.index Name.equal (Name id) (fst env) in - isRelN n c - with Not_found -> isVarId id c in + let bound_to_itself_or_letin decl c = + match decl with + | LocalDef _ -> true + | LocalAssum (id,_) -> + try let n = List.index Name.equal (Name id) (fst env) in + isRelN n c + with Not_found -> isVarId id c + in let id,l = try let id = Evd.evar_ident evk sigma in @@ -684,17 +695,24 @@ let detype_rel_context ?(lax=false) where avoid env sigma sign = let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function | [] -> [] - | (na,b,t)::rest -> + | decl::rest -> + let open Context.Rel.Declaration in + let na = get_name decl in + let t = get_type decl in let na',avoid' = match where with | None -> na,avoid | Some c -> - if b != None then + if is_local_def decl then compute_displayed_let_name_in (RenamingElsewhereFor (fst env,c)) avoid na c else compute_displayed_name_in (RenamingElsewhereFor (fst env,c)) avoid na c in + let b = match decl with + | LocalAssum _ -> None + | LocalDef (_,b,_) -> Some b + in let b' = Option.map (detype (lax,false) avoid env sigma) b in let t' = detype (lax,false) avoid env sigma t in (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 99e51330ef..020f998aa7 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -23,6 +23,7 @@ open Globnames open Evd open Pretype_errors open Sigma.Notations +open Context.Rel.Declaration type unify_fun = transparent_state -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result @@ -55,12 +56,15 @@ let eval_flexible_term ts env evd c = then constant_opt_value_in env cu else None | Rel n -> - (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v - with Not_found -> None) + (try match lookup_rel n env with + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some (lift n v) + with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let (_,v,_) = lookup_named id env in v + let open Context.Named.Declaration in + lookup_named id env |> get_value else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) @@ -394,7 +398,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty assert (match sk with [] -> true | _ -> false); let (na,c1,c'1) = destLambda term in let c = nf_evar evd c1 in - let env' = push_rel (na,None,c) env in + let env' = push_rel (LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd @@ -561,7 +565,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let b = nf_evar i b1 in let t = nf_evar i t1 in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2); + evar_conv_x ts (push_rel (LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) @@ -676,7 +680,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let c = nf_evar i c1 in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)] + evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -735,7 +739,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let c = nf_evar i c1 in let na = Nameops.name_max n1 n2 in - evar_conv_x ts (push_rel (na,None,c) env) i pbty c'1 c'2)] + evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then @@ -912,6 +916,7 @@ let choose_less_dependent_instance evk evd term args = | [] -> None | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) +open Context.Named.Declaration let apply_on_subterm env evdref f c t = let rec applyrec (env,(k,c) as acc) t = (* By using eq_constr, we make an approximation, for instance, we *) @@ -922,7 +927,7 @@ let apply_on_subterm env evdref f c t = match kind_of_term t with | Evar (evk,args) when Evd.is_undefined !evdref evk -> let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in - let g (_,b,_) a = if Option.is_empty b then applyrec acc a else a in + let g decl a = if is_local_assum decl then applyrec acc a else a in mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) | _ -> map_constr_with_binders_left_to_right @@ -939,17 +944,17 @@ let filter_possible_projections c ty ctxt args = let fv2 = collect_vars (mkApp (c,args)) in let len = Array.length args in let tyvars = collect_vars ty in - List.map_i (fun i (id,b,_) -> + List.map_i (fun i decl -> let () = assert (i < len) in let a = Array.unsafe_get args i in - (match b with None -> false | Some c -> not (isRel c || isVar c)) || + (match decl with LocalAssum _ -> false | LocalDef (_,c,_) -> not (isRel c || isVar c)) || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel a && Int.Set.mem (destRel a) fv1 || isVar a && Id.Set.mem (destVar a) fv2 || - Id.Set.mem id tyvars) + Id.Set.mem (get_id decl) tyvars) 0 ctxt let solve_evars = ref (fun _ -> failwith "solve_evars not installed") @@ -980,17 +985,18 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let env_evar = evar_filtered_env evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - let instance = List.map mkVar (List.map pi1 ctxt) in + let instance = List.map mkVar (List.map get_id ctxt) in let rec make_subst = function - | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c -> + | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c -> begin match occs with | Some _ -> error "Cannot force abstraction on identity instance." | None -> make_subst (ctxt',l,occsl) end - | (id,_,t)::ctxt', c::l, occs::occsl -> + | decl'::ctxt', c::l, occs::occsl -> + let (id,_,t) = to_tuple decl' in let evs = ref [] in let ty = Retyping.get_type_of env_rhs evd c in let filter' = filter_possible_projections c ty ctxt args in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 0dd0ad2e08..a65394e17b 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -19,6 +19,7 @@ open Retyping open Reductionops open Evarutil open Pretype_errors +open Context.Rel.Declaration let normalize_evar evd ev = match kind_of_term (whd_evar evd (mkEvar ev)) with @@ -79,7 +80,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) pbty env evd t = if !modified then evdref := Evd.add !evdref ev {evi with evar_concl = ty'} else () - | _ -> iter_constr (refresh_term_evars onevars false) t + | _ -> Constr.iter (refresh_term_evars onevars false) t and refresh_polymorphic_positions args pos = let rec aux i = function | Some l :: ls -> @@ -162,7 +163,8 @@ type 'a update = | UpdateWith of 'a | NoUpdate -let inst_of_vars sign = Array.map_of_list (fun (id,_,_) -> mkVar id) sign +open Context.Named.Declaration +let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -205,6 +207,7 @@ let restrict_instance evd evk filter argsv = let evi = Evd.find evd evk in Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv +open Context.Rel.Declaration let noccur_evar env evd evk c = let cache = ref Int.Set.empty (* cache for let-ins *) in let rec occur_rec (k, env as acc) c = @@ -217,9 +220,9 @@ let noccur_evar env evd evk c = else Array.iter (occur_rec acc) args') | Rel i when i > k -> if not (Int.Set.mem (i-k) !cache) then - (match pi2 (Environ.lookup_rel i env) with - | None -> () - | Some b -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b)) + (match Environ.lookup_rel i env with + | LocalAssum _ -> () + | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b)) | Proj (p,c) -> let c = try Retyping.expand_projection env evd p c [] @@ -241,9 +244,11 @@ let noccur_evar env evd evk c = variable in its family of aliased variables *) let compute_var_aliases sign = - List.fold_right (fun (id,b,c) aliases -> - match b with - | Some t -> + let open Context.Named.Declaration in + List.fold_right (fun decl aliases -> + let id = get_id decl in + match decl with + | LocalDef (_,t,_) -> (match kind_of_term t with | Var id' -> let aliases_of_id = @@ -251,27 +256,30 @@ let compute_var_aliases sign = Id.Map.add id (aliases_of_id@[t]) aliases | _ -> Id.Map.add id [t] aliases) - | None -> aliases) + | LocalAssum _ -> aliases) sign Id.Map.empty let compute_rel_aliases var_aliases rels = - snd (List.fold_right (fun (_,b,u) (n,aliases) -> - (n-1, - match b with - | Some t -> - (match kind_of_term t with - | Var id' -> - let aliases_of_n = - try Id.Map.find id' var_aliases with Not_found -> [] in - Int.Map.add n (aliases_of_n@[t]) aliases - | Rel p -> - let aliases_of_n = - try Int.Map.find (p+n) aliases with Not_found -> [] in - Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases - | _ -> - Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) - | None -> aliases)) - rels (List.length rels,Int.Map.empty)) + snd (List.fold_right + (fun decl (n,aliases) -> + (n-1, + match decl with + | LocalDef (_,t,u) -> + (match kind_of_term t with + | Var id' -> + let aliases_of_n = + try Id.Map.find id' var_aliases with Not_found -> [] in + Int.Map.add n (aliases_of_n@[t]) aliases + | Rel p -> + let aliases_of_n = + try Int.Map.find (p+n) aliases with Not_found -> [] in + Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases + | _ -> + Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) + | LocalAssum _ -> aliases) + ) + rels + (List.length rels,Int.Map.empty)) let make_alias_map env = (* We compute the chain of aliases for each var and rel *) @@ -305,13 +313,13 @@ let normalize_alias aliases x = let normalize_alias_var var_aliases id = destVar (normalize_alias (var_aliases,Int.Map.empty) (mkVar id)) -let extend_alias (_,b,_) (var_aliases,rel_aliases) = +let extend_alias decl (var_aliases,rel_aliases) = let rel_aliases = Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l)) rel_aliases Int.Map.empty in let rel_aliases = - match b with - | Some t -> + match decl with + | LocalDef(_,t,_) -> (match kind_of_term t with | Var id' -> let aliases_of_binder = @@ -323,7 +331,7 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) = Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases | _ -> Int.Map.add 1 [lift 1 t] rel_aliases) - | None -> rel_aliases in + | LocalAssum _ -> rel_aliases in (var_aliases, rel_aliases) let expand_alias_once aliases x = @@ -429,16 +437,17 @@ let get_actual_deps aliases l t = | Rel n -> Int.Set.mem n fv_rels | _ -> assert false) l +open Context.Named.Declaration let remove_instance_local_defs evd evk args = let evi = Evd.find evd evk in let len = Array.length args in let rec aux sign i = match sign with | [] -> let () = assert (i = len) in [] - | (_, None, _) :: sign -> + | LocalAssum _ :: sign -> let () = assert (i < len) in (Array.unsafe_get args i) :: aux sign (succ i) - | (_, Some _, _) :: sign -> + | LocalDef _ :: sign -> aux sign (succ i) in aux (evar_filtered_context evi) 0 @@ -500,7 +509,8 @@ let solve_pattern_eqn env l c = match kind_of_term a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> - let d = Context.Rel.Declaration.map (lift n) (lookup_rel n env) in + let open Context.Rel.Declaration in + let d = map_constr (lift n) (lookup_rel n env) in mkLambda_or_LetIn d c' | Var id -> let d = lookup_named id env in mkNamedLambda_or_LetIn d c' @@ -529,9 +539,9 @@ let make_projectable_subst aliases sigma evi args = let evar_aliases = compute_var_aliases sign in let (_,full_subst,cstr_subst) = List.fold_right - (fun (id,b,c) (args,all,cstrs) -> - match b,args with - | None, a::rest -> + (fun decl (args,all,cstrs) -> + match decl,args with + | LocalAssum (id,c), a::rest -> let a = whd_evar sigma a in let cstrs = let a',args = decompose_app_vect a in @@ -541,7 +551,7 @@ let make_projectable_subst aliases sigma evi args = Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) - | Some c, a::rest -> + | LocalDef (id,c,_), a::rest -> let a = whd_evar sigma a in (match kind_of_term c with | Var id' -> @@ -601,10 +611,12 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let sign1 = evar_hyps evi1 in let filter1 = evar_filter evi1 in let src = subterm_source evk1 evi1.evar_source in - let ids1 = List.map pi1 (named_context_of_val sign1) in + let ids1 = List.map get_id (named_context_of_val sign1) in let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in + let open Context.Rel.Declaration in let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = - List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> + List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> + let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in let id = next_name_away na avoid in let evd,t_in_sign = let s = Retyping.get_sort_of env evd t_in_env in @@ -612,13 +624,13 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in - let evd,b_in_sign = match b with - | None -> evd,None - | Some b -> + let evd,b_in_sign = match d with + | LocalAssum _ -> evd,None + | LocalDef (_,b,_) -> let evd,b = define_evar_from_virtual_equation define_fun env evd src b t_in_sign sign filter inst_in_env in evd,Some b in - (push_named_context_val (id,b_in_sign,t_in_sign) sign, Filter.extend 1 filter, + (push_named_context_val (Context.Named.Declaration.of_tuple (id,b_in_sign,t_in_sign)) sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,id::avoid)) @@ -756,9 +768,10 @@ let project_with_effects aliases sigma effects t subst = effects := p :: !effects; c +open Context.Named.Declaration let rec find_solution_type evarenv = function - | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv) - | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv) + | (id,ProjectVar)::l -> get_type (lookup_named id evarenv) + | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv) | (id,ProjectEvar _)::l -> find_solution_type evarenv l | [] -> assert false @@ -892,7 +905,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = *) let set_of_evctx l = - List.fold_left (fun s (id,_,_) -> Id.Set.add id s) Id.Set.empty l + List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l let filter_effective_candidates evi filter candidates = match filter with @@ -924,7 +937,13 @@ let closure_of_filter evd evk = function | Some filter -> let evi = Evd.find_undefined evd evk in let vars = collect_vars (Evarutil.nf_evar evd (evar_concl evi)) in - let test b (id,c,_) = b || Idset.mem id vars || match c with None -> false | Some c -> not (isRel c || isVar c) in + let test b decl = b || Idset.mem (get_id decl) vars || + match decl with + | LocalAssum _ -> + false + | LocalDef (_,c,_) -> + not (isRel c || isVar c) + in let newfilter = Filter.map_along test filter (evar_context evi) in (* Now ensure that restriction is at least what is was originally *) let newfilter = Option.cata (Filter.map_along (&&) newfilter) newfilter (Filter.repr (evar_filter evi)) in @@ -1280,7 +1299,7 @@ let occur_evar_upto_types sigma n c = seen := Evar.Set.add sp !seen; Option.iter occur_rec (existential_opt_value sigma e); occur_rec (existential_type sigma e)) - | _ -> iter_constr occur_rec c + | _ -> Constr.iter occur_rec c in try occur_rec c; false with Occur -> true @@ -1365,15 +1384,16 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let t = whd_evar !evdref t in match kind_of_term t with | Rel i when i>k -> - (match pi2 (Environ.lookup_rel (i-k) env') with - | None -> project_variable (mkRel (i-k)) - | Some b -> + let open Context.Rel.Declaration in + (match Environ.lookup_rel (i-k) env' with + | LocalAssum _ -> project_variable (mkRel (i-k)) + | LocalDef (_,b,_) -> try project_variable (mkRel (i-k)) with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b)) | Var id -> - (match pi2 (Environ.lookup_named id env') with - | None -> project_variable t - | Some b -> + (match Environ.lookup_named id env' with + | LocalAssum _ -> project_variable t + | LocalDef (_,b,_) -> try project_variable t with NotInvertibleUsingOurAlgorithm _ -> imitate envk b) | LetIn (na,b,u,c) -> @@ -1453,7 +1473,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let names = ref Idset.empty in let rec is_id_subst ctxt s = match ctxt, s with - | ((id, _, _) :: ctxt'), (c :: s') -> + | (decl :: ctxt'), (c :: s') -> + let id = get_id decl in names := Idset.add id !names; isVarId id c && is_id_subst ctxt' s' | [], [] -> true diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 8c210e2833..343d3ef903 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -76,13 +76,15 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=nf_evar sigma v;utj_type=t} let env_nf_evar sigma env = + let open Context.Rel.Declaration in process_rel_context - (fun d e -> push_rel (Context.Rel.Declaration.map (nf_evar sigma) d) e) env + (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env let env_nf_betaiotaevar sigma env = + let open Context.Rel.Declaration in process_rel_context (fun d e -> - push_rel (Context.Rel.Declaration.map (Reductionops.nf_betaiota sigma) d) e) env + push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env let nf_evars_universes evm = Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) @@ -149,11 +151,16 @@ let is_ground_term evd t = not (has_undefined_evars evd t) let is_ground_env evd env = - let is_ground_decl = function - (_,Some b,_) -> is_ground_term evd b + let open Context.Rel.Declaration in + let is_ground_rel_decl = function + | LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in - List.for_all is_ground_decl (rel_context env) && - List.for_all is_ground_decl (named_context env) + let open Context.Named.Declaration in + let is_ground_named_decl = function + | LocalDef (_,b,_) -> is_ground_term evd b + | _ -> true in + List.for_all is_ground_rel_decl (rel_context env) && + List.for_all is_ground_named_decl (named_context env) (* Memoization is safe since evar_map and environ are applicative structures *) @@ -231,10 +238,11 @@ let non_instantiated sigma = (************************) let make_pure_subst evi args = + let open Context.Named.Declaration in snd (List.fold_right - (fun (id,b,c) (args,l) -> + (fun decl (args,l) -> match args with - | a::rest -> (rest, (id,a)::l) + | a::rest -> (rest, (get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature")) (evar_filtered_context evi) (Array.rev_to_list args,[])) @@ -276,17 +284,15 @@ let subst2 subst vsubst c = let push_rel_context_to_named_context env typ = (* compute the instances relative to the named context and rel_context *) - let ids = List.map pi1 (named_context env) in + let open Context.Named.Declaration in + let ids = List.map get_id (named_context env) in let inst_vars = List.map mkVar ids in let inst_rels = List.rev (rel_list 0 (nb_rel env)) in - let replace_var_named_declaration id0 id (id',b,t) = + let replace_var_named_declaration id0 id decl = + let id' = get_id decl in let id' = if Id.equal id0 id' then id else id' in let vsubst = [id0 , mkVar id] in - let b = match b with - | None -> None - | Some c -> Some (replace_vars vsubst c) - in - id', b, replace_vars vsubst t + decl |> set_id id' |> map_constr (replace_vars vsubst) in let replace_var_named_context id0 id env = let nc = Environ.named_context env in @@ -303,7 +309,12 @@ let push_rel_context_to_named_context env typ = (* We do keep the instances corresponding to local definition (see above) *) let (subst, vsubst, _, env) = Context.Rel.fold_outside - (fun (na,c,t) (subst, vsubst, avoid, env) -> + (fun decl (subst, vsubst, avoid, env) -> + let open Context.Rel.Declaration in + let na = get_name decl in + let c = get_value decl in + let t = get_type decl in + let open Context.Named.Declaration in let id = (* ppedrot: we want to infer nicer names for the refine tactic, but keeping at the same time backward compatibility in other code @@ -321,7 +332,10 @@ let push_rel_context_to_named_context env typ = context. Unless [id] is a section variable. *) let subst = List.map (replace_vars [id0,mkVar id]) subst in let vsubst = (id0,mkVar id)::vsubst in - let d = (id0, Option.map (subst2 subst vsubst) c, subst2 subst vsubst t) in + let d = match c with + | None -> LocalAssum (id0, subst2 subst vsubst t) + | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t) + in let env = replace_var_named_context id0 id env in (mkVar id0 :: subst, vsubst, id::avoid, push_named d env) | _ -> @@ -329,7 +343,10 @@ let push_rel_context_to_named_context env typ = incorrect. We revert to a less robust behaviour where the new binder has name [id]. Which amounts to the same behaviour than when [id=id0]. *) - let d = (id,Option.map (subst2 subst vsubst) c,subst2 subst vsubst t) in + let d = match c with + | None -> LocalAssum (id, subst2 subst vsubst t) + | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t) + in (mkVar id :: subst, vsubst, id::avoid, push_named d env) ) (rel_context env) ~init:([], [], ids, env) in @@ -477,7 +494,7 @@ let rec check_and_clear_in_constr env evdref err ids c = let ctxt = Evd.evar_filtered_context evi in let (rids,filter) = List.fold_right2 - (fun (rid, ob,c as h) a (ri,filter) -> + (fun h a (ri,filter) -> try (* Check if some id to clear occurs in the instance a of rid in ev and remember the dependency *) @@ -493,7 +510,8 @@ let rec check_and_clear_in_constr env evdref err ids c = let () = Id.Map.iter check ri in (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) - with Depends id -> (Id.Map.add rid id ri, false::filter)) + with Depends id -> let open Context.Named.Declaration in + (Id.Map.add (get_id h) id ri, false::filter)) ctxt (Array.to_list l) (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) @@ -528,11 +546,10 @@ let clear_hyps_in_evi_main env evdref hyps terms ids = let terms = List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in let nhyps = - let check_context ((id,ob,c) as decl) = - let err = OccurHypInSimpleClause (Some id) in - let ob' = Option.smartmap (fun c -> check_and_clear_in_constr env evdref err ids c) ob in - let c' = check_and_clear_in_constr env evdref err ids c in - if ob == ob' && c == c' then decl else (id, ob', c') + let open Context.Named.Declaration in + let check_context decl = + let err = OccurHypInSimpleClause (Some (get_id decl)) in + map_constr (check_and_clear_in_constr env evdref err ids) decl in let check_value vk = match force_lazy_val vk with | None -> vk @@ -570,11 +587,12 @@ let process_dependent_evar q acc evm is_dependent e = (* Queues evars appearing in the types of the goal (conclusion, then hypotheses), they are all dependent. *) queue_term q true evi.evar_concl; - List.iter begin fun (_,b,t) -> - queue_term q true t; - match b with - | None -> () - | Some b -> queue_term q true b + List.iter begin fun decl -> + let open Context.Named.Declaration in + queue_term q true (get_type decl); + match decl with + | LocalAssum _ -> () + | LocalDef (_,b,_) -> queue_term q true b end (Environ.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> @@ -625,11 +643,11 @@ let undefined_evars_of_term evd t = evrec Evar.Set.empty t let undefined_evars_of_named_context evd nc = - List.fold_right (fun (_, b, t) s -> - Option.fold_left (fun s t -> - Evar.Set.union s (undefined_evars_of_term evd t)) - (Evar.Set.union s (undefined_evars_of_term evd t)) b) - nc Evar.Set.empty + let open Context.Named.Declaration in + Context.Named.fold_outside + (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) + nc + ~init:Evar.Set.empty let undefined_evars_of_evar_info evd evi = Evar.Set.union (undefined_evars_of_term evd evi.evar_concl) @@ -709,6 +727,7 @@ let idx = Namegen.default_dependent_ident (* Refining an evar to a product *) let define_pure_evar_as_product evd evk = + let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in @@ -717,7 +736,7 @@ let define_pure_evar_as_product evd evk = let evd1,(dom,u1) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in let evd2,rng = - let newenv = push_named (id, None, dom) evenv in + let newenv = push_named (LocalAssum (id, dom)) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in if is_prop_sort s then @@ -756,6 +775,7 @@ let define_evar_as_product evd (evk,args) = *) let define_pure_evar_as_lambda env evd evk = + let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let typ = whd_betadeltaiota evenv evd (evar_concl evi) in @@ -766,7 +786,7 @@ let define_pure_evar_as_lambda env evd evk = let avoid = ids_of_named_context (evar_context evi) in let id = next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in - let newenv = push_named (id, None, dom) evenv in + let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 6733b7fca0..ae8b91c346 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -59,19 +59,22 @@ let proceed_with_occurrences f occs x = (** Applying a function over a named_declaration with an hypothesis location request *) -let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) = - let f = f (Some (id,hyploc)) in - match bodyopt,hyploc with - | None, InHypValueOnly -> +let map_named_declaration_with_hyploc f hyploc acc decl = + let open Context.Named.Declaration in + let f = f (Some (get_id decl, hyploc)) in + match decl,hyploc with + | LocalAssum (id,_), InHypValueOnly -> error_occurrences_error (IncorrectInValueOccurrence id) - | None, _ | Some _, InHypTypeOnly -> - let acc,typ = f acc typ in acc,(id,bodyopt,typ) - | Some body, InHypValueOnly -> - let acc,body = f acc body in acc,(id,Some body,typ) - | Some body, InHyp -> + | LocalAssum (id,typ), _ -> + let acc,typ = f acc typ in acc, LocalAssum (id,typ) + | LocalDef (id,body,typ), InHypTypeOnly -> + let acc,typ = f acc typ in acc, LocalDef (id,body,typ) + | LocalDef (id,body,typ), InHypValueOnly -> + let acc,body = f acc body in acc, LocalDef (id,body,typ) + | LocalDef (id,body,typ), InHyp -> let acc,body = f acc body in let acc,typ = f acc typ in - acc,(id,Some body,typ) + acc, LocalDef (id,body,typ) (** Finding a subterm up to some testing function *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index fb45be6635..713c99597a 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -28,6 +28,7 @@ open Environ open Reductionops open Nametab open Sigma.Notations +open Context.Rel.Declaration type dep_flag = bool @@ -77,7 +78,6 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *) let env' = push_rel_context lnamespar env in - let rec add_branch env k = if Int.equal k (Array.length mip.mind_consnames) then let nbprod = k+1 in @@ -85,7 +85,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let indf' = lift_inductive_family nbprod indf in let arsign,_ = get_arity env indf' in let depind = build_dependent_inductive env indf' in - let deparsign = (Anonymous,None,depind)::arsign in + let deparsign = LocalAssum (Anonymous,depind)::arsign in let ci = make_case_info env (fst pind) RegularStyle in let pbody = @@ -118,14 +118,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let cs = lift_constructor (k+1) constrs.(k) in let t = build_branch_type env dep (mkRel (k+1)) cs in mkLambda_string "f" t - (add_branch (push_rel (Anonymous, None, t) env) (k+1)) + (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1)) in let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in let typP = make_arity env' dep indf s in let c = it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP - (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar in Sigma (c, sigma, p) @@ -154,10 +154,10 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with | Prod (n,t,c) -> - let d = (n,None,t) in + let d = LocalAssum (n,t) in make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) | LetIn (n,b,t,c) when List.is_empty largs -> - let d = (n,Some b,t) in + let d = LocalDef (n,b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) | Ind (_,_) -> let realargs = List.skipn nparams largs in @@ -192,22 +192,22 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = | None -> make_prod env (n,t, - process_constr (push_rel (n,None,t) env) (i+1) c_0 rest + process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest (nhyps-1) (i::li)) | Some(dep',p) -> let nP = lift (i+1+decP) p in - let env' = push_rel (n,None,t) env in + let env' = push_rel (LocalAssum (n,t)) env in let t_0 = process_pos env' dep' nP (lift 1 t) in make_prod_dep (dep || dep') env (n,t, mkArrow t_0 (process_constr - (push_rel (Anonymous,None,t_0) env') + (push_rel (LocalAssum (Anonymous,t_0)) env') (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) | LetIn (n,b,t,c_0) -> mkLetIn (n,b,t, process_constr - (push_rel (n,Some b,t) env) + (push_rel (LocalDef (n,b,t)) env) (i+1) c_0 recargs (nhyps-1) li) | _ -> assert false else @@ -232,10 +232,10 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with | Prod (n,t,c) -> - let d = (n,None,t) in + let d = LocalAssum (n,t) in mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) | LetIn (n,b,t,c) when List.is_empty largs -> - let d = (n,Some b,t) in + let d = LocalDef (n,b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs @@ -250,7 +250,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = in (* ici, cstrprods est la liste des produits du constructeur instantié *) let rec process_constr env i f = function - | (n,None,t as d)::cprest, recarg::rest -> + | (LocalAssum (n,t) as d)::cprest, recarg::rest -> let optionpos = match dest_recarg recarg with | Norec -> None @@ -271,7 +271,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = (n,t,process_constr env' (i+1) (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg]))) (cprest,rest))) - | (n,Some c,t as d)::cprest, rest -> + | (LocalDef (n,c,t) as d)::cprest, rest -> mkLetIn (n,c,t, process_constr (push_rel d env) (i+1) (lift 1 f) @@ -322,7 +322,7 @@ let mis_make_indrec env sigma listdepkind mib u = let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in - let deparsign = (Anonymous,None,depind)::arsign in + let deparsign = LocalAssum (Anonymous,depind)::arsign in let nonrecpar = Context.Rel.length lnonparrec in let larsign = Context.Rel.length deparsign in @@ -357,7 +357,7 @@ let mis_make_indrec env sigma listdepkind mib u = let depind' = build_dependent_inductive env indf' in let arsign',_ = get_arity env indf' in - let deparsign' = (Anonymous,None,depind')::arsign' in + let deparsign' = LocalAssum (Anonymous,depind')::arsign' in let pargs = let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec @@ -387,11 +387,13 @@ let mis_make_indrec env sigma listdepkind mib u = let branch = branches.(0) in let ctx, br = decompose_lam_assum branch in let n, subst = - List.fold_right (fun (na,b,t) (i, subst) -> - if b == None then - let t = mkProj (Projection.make ps.(i) true, mkRel 1) in - (i + 1, t :: subst) - else (i, mkRel 0 :: subst)) + List.fold_right (fun decl (i, subst) -> + match decl with + | LocalAssum (na,t) -> + let t = mkProj (Projection.make ps.(i) true, mkRel 1) in + i + 1, t :: subst + | LocalDef (na,b,t) -> + i, mkRel 0 :: subst) ctx (0, []) in let term = substl subst br in @@ -440,7 +442,7 @@ let mis_make_indrec env sigma listdepkind mib u = true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg in mkLambda_string "f" p_0 - (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) + (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1)) in onerec env 0 | [] -> makefix i listdepkind @@ -454,7 +456,7 @@ let mis_make_indrec env sigma listdepkind mib u = in let typP = make_arity env dep indf s in mkLambda_string "P" typP - (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) + (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest) | [] -> make_branch env 0 listdepkind in diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index bb38c72f25..80f1988a97 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -17,6 +17,7 @@ open Declarations open Declareops open Environ open Reductionops +open Context.Rel.Declaration (* The following three functions are similar to the ones defined in Inductive, but they expect an env *) @@ -389,7 +390,7 @@ let make_arity_signature env dep indf = if dep then (* We need names everywhere *) Namegen.name_context env - ((Anonymous,None,build_dependent_inductive env indf)::arsign) + ((LocalAssum (Anonymous,build_dependent_inductive env indf))::arsign) (* Costly: would be better to name once for all at definition time *) else (* No need to enforce names *) @@ -459,7 +460,7 @@ let is_predicate_explicitly_dep env pred arsign = let rec srec env pval arsign = let pv' = whd_betadeltaiota env Evd.empty pval in match kind_of_term pv', arsign with - | Lambda (na,t,b), (_,None,_)::arsign -> + | Lambda (na,t,b), (LocalAssum _)::arsign -> srec (push_rel_assum (na,t) env) b arsign | Lambda (na,_,t), _ -> @@ -539,11 +540,11 @@ let arity_of_case_predicate env (ind,params) dep k = that appear in the type of the inductive by the sort of the conclusion, and the other ones by fresh universes. *) let rec instantiate_universes env evdref scl is = function - | (_,Some _,_ as d)::sign, exp -> + | (LocalDef _ as d)::sign, exp -> d :: instantiate_universes env evdref scl is (sign, exp) | d::sign, None::exp -> d :: instantiate_universes env evdref scl is (sign, exp) - | (na,None,ty)::sign, Some l::exp -> + | (LocalAssum (na,ty))::sign, Some l::exp -> let ctx,_ = Reduction.dest_arity env ty in let u = Univ.Universe.make l in let s = @@ -557,7 +558,7 @@ let rec instantiate_universes env evdref scl is = function let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in evdref := evm; s in - (na,None,mkArity(ctx,s)):: instantiate_universes env evdref scl is (sign, exp) + (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp) | sign, [] -> sign (* Uniform parameters are exhausted *) | [], _ -> assert false diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 6d09d56985..8ddfeaf2f0 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -19,6 +19,7 @@ open Util open Nativecode open Nativevalues open Nativelambda +open Context.Rel.Declaration (** This module implements normalization by evaluation to OCaml code *) @@ -121,9 +122,8 @@ let build_case_type dep p realargs c = else mkApp(p, realargs) (* TODO move this function *) -let type_of_rel env n = - let (_,_,ty) = lookup_rel n env in - lift n ty +let type_of_rel env n = + lookup_rel n env |> get_type |> lift n let type_of_prop = mkSort type1_sort @@ -132,8 +132,9 @@ let type_of_sort s = | Prop _ -> type_of_prop | Type u -> mkType (Univ.super u) -let type_of_var env id = - try let (_,_,ty) = lookup_named id env in ty +let type_of_var env id = + let open Context.Named.Declaration in + try lookup_named id env |> get_type with Not_found -> anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound") @@ -181,7 +182,7 @@ let rec nf_val env v typ = Errors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in - let env = push_rel (name,None,dom) env in + let env = push_rel (LocalAssum (name,dom)) env in let body = nf_val env (f (mk_rel_accu lvl)) codom in mkLambda(name,dom,body) | Vconst n -> construct_of_constr_const env n typ @@ -257,7 +258,7 @@ and nf_atom env atom = | Aprod(n,dom,codom) -> let dom = nf_type env dom in let vn = mk_rel_accu (nb_rel env) in - let env = push_rel (n,None,dom) env in + let env = push_rel (LocalAssum (n,dom)) env in let codom = nf_type env (codom vn) in mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv @@ -328,7 +329,7 @@ and nf_atom_type env atom = | Aprod(n,dom,codom) -> let dom,s1 = nf_type_sort env dom in let vn = mk_rel_accu (nb_rel env) in - let env = push_rel (n,None,dom) env in + let env = push_rel (LocalAssum (n,dom)) env in let codom,s2 = nf_type_sort env (codom vn) in mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2) | Aevar(ev,ty) -> @@ -356,7 +357,7 @@ and nf_predicate env ind mip params v pT = (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in let dep,body = - nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in @@ -366,7 +367,7 @@ and nf_predicate env ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in - let body = nf_type (push_rel (name,None,dom) env) vb in + let body = nf_type (push_rel (LocalAssum (name,dom)) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index af46c390a6..827071054a 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -123,6 +123,7 @@ let head_of_constr_reference c = match kind_of_term c with let pattern_of_constr env sigma t = let rec pattern_of_constr env t = + let open Context.Rel.Declaration in match kind_of_term t with | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) @@ -132,11 +133,11 @@ let pattern_of_constr env sigma t = | Sort (Type _) -> PSort (GType []) | Cast (c,_,_) -> pattern_of_constr env c | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c, - pattern_of_constr (push_rel (na,Some c,t) env) b) + pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) | Prod (na,c,b) -> PProd (na,pattern_of_constr env c, - pattern_of_constr (push_rel (na, None, c) env) b) + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c, - pattern_of_constr (push_rel (na, None, c) env) b) + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | App (f,a) -> (match match kind_of_term f with diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 11fba7b941..7c91b1a934 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -42,6 +42,7 @@ open Glob_ops open Evarconv open Pattern open Misctypes +open Context.Named.Declaration type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = constr_under_binders Id.Map.t @@ -319,7 +320,7 @@ let ltac_interp_name_env k0 lvar env = let n = Context.Rel.length (rel_context env) - k0 in let ctxt,_ = List.chop n (rel_context env) in let env = pop_rel_context n env in - let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in + let ctxt = List.map (Context.Rel.Declaration.map_name (ltac_interp_name lvar)) ctxt in push_rel_context ctxt env let invert_ltac_bound_name lvar env id0 id = @@ -372,8 +373,7 @@ let pretype_id pretype k0 loc env evdref lvar id = str "Variable " ++ pr_id id ++ str " should be bound to a term."); (* Check if [id] is a section or goal variable *) try - let (_,_,typ) = lookup_named id env in - { uj_val = mkVar id; uj_type = typ } + { uj_val = mkVar id; uj_type = (get_type (lookup_named id env)) } with Not_found -> (* [id] not found, standard error message *) error_var_not_found_loc loc id @@ -418,8 +418,7 @@ let pretype_ref loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) - (try let (_,_,ty) = lookup_named id env in - make_judge (mkVar id) ty + (try make_judge (mkVar id) (get_type (lookup_named id env)) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal @@ -459,6 +458,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in let pretype_type = pretype_type k0 resolve_tc in let pretype = pretype k0 resolve_tc in + let open Context.Rel.Declaration in match t with | GRef (loc,ref,u) -> inh_conv_coerce_to_tycon loc env evdref @@ -518,14 +518,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ [] -> ctxt | (na,bk,None,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = (na,None,ty'.utj_val) in - let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in + let dcl = LocalAssum (na, ty'.utj_val) in + let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in - let dcl = (na,Some bd'.uj_val,ty'.utj_val) in - let dcl' = (ltac_interp_name lvar na,Some bd'.uj_val,ty'.utj_val) in + let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in + let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in let larj = @@ -694,7 +694,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let var = (name,None,j.utj_val) in + let var = LocalAssum (name, j.utj_val) in let j' = pretype rng (push_rel var env) evdref lvar c2 in let name = ltac_interp_name lvar name in let resj = judge_of_abstraction env (orelse_name name name') j j' in @@ -738,7 +738,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let var = (name,Some j.uj_val,t) in + let var = LocalDef (name, j.uj_val, t) in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in let name = ltac_interp_name lvar name in @@ -763,17 +763,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ int cs.cs_nargs ++ str " variables."); let fsign, record = match get_projections env indf with - | None -> List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args, false + | None -> + List.map2 set_name (List.rev nal) cs.cs_args, false | Some ps -> let rec aux n k names l = match names, l with - | na :: names, ((_, None, t) :: l) -> + | na :: names, (LocalAssum (_,t) :: l) -> let proj = Projection.make ps.(cs.cs_nargs - k) true in - (na, Some (lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val))), t) + LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) :: aux (n+1) (k + 1) names l - | na :: names, ((_, c, t) :: l) -> - (na, c, t) :: aux (n+1) k names l + | na :: names, (decl :: l) -> + set_name na decl :: aux (n+1) k names l | [], [] -> [] | _ -> assert false in aux 1 1 (List.rev nal) cs.cs_args, true in @@ -781,7 +781,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ if not record then let nal = List.map (fun na -> ltac_interp_name lvar na) nal in let nal = List.rev nal in - let fsign = List.map2 (fun na (_,b,t) -> (na,b,t)) nal fsign in + let fsign = List.map2 set_name nal fsign in let f = it_mkLambda_or_LetIn f fsign in let ci = make_case_info env (fst ind) LetStyle in mkCase (ci, p, cj.uj_val,[|f|]) @@ -792,10 +792,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + List.map (set_name Anonymous) arsgn else arsgn in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let psign = LocalAssum (na, build_dependent_inductive env indf) :: arsgn in let nar = List.length arsgn in (match po with | Some p -> @@ -851,11 +851,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then (* Make dependencies from arity signature impossible *) - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + List.map (set_name Anonymous) arsgn else arsgn in let nar = List.length arsgn in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let psign = LocalAssum (na, build_dependent_inductive env indf) :: arsgn in let pred,p = match po with | Some p -> let env_p = push_rel_context psign env in @@ -880,14 +880,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let pi = beta_applist (pi, [build_dependent_constructor cs]) in let csgn = if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + List.map (set_name Anonymous) cs.cs_args else - List.map - (fun (n, b, t) -> - match n with - Name _ -> (n, b, t) - | Anonymous -> (Name Namegen.default_non_dependent_ident, b, t)) - cs.cs_args + List.map (map_name (function Name _ as n -> n + | Anonymous -> Name Namegen.default_non_dependent_ident)) + cs.cs_args in let env_c = push_rel_context csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in @@ -949,8 +946,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ in inh_conv_coerce_to_tycon loc env evdref cj tycon and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = - let f (id,_,t) (subst,update) = - let t = replace_vars subst t in + let f decl (subst,update) = + let id = get_id decl in + let t = replace_vars subst (get_type decl) in let c, update = try let c = List.assoc id update in @@ -962,7 +960,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = if is_conv env !evdref t t' then mkRel n, update else raise Not_found with Not_found -> try - let (_,_,t') = lookup_named id env in + let t' = lookup_named id env |> get_type in if is_conv env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> user_err_loc (loc,"",str "Cannot interpret " ++ diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 5e21154a67..d7637d1c27 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -15,6 +15,7 @@ open Termops open Univ open Evd open Environ +open Context.Rel.Declaration exception Elimconst @@ -607,7 +608,7 @@ let strong whdfun env sigma t = strongrec env t let local_strong whdfun sigma = - let rec strongrec t = map_constr strongrec (whdfun sigma t) in + let rec strongrec t = Constr.map strongrec (whdfun sigma t) in strongrec let rec strong_prodspine redfun sigma c = @@ -799,6 +800,7 @@ let equal_stacks (x, l) (y, l') = | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) let rec whd_state_gen ?csts tactic_mode flags env sigma = + let open Context.Named.Declaration in let rec whrec cst_l (x, stack as s) = let () = if !debug_RAKAM then let open Pp in @@ -815,11 +817,11 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = match kind_of_term x with | Rel n when Closure.RedFlags.red_set flags Closure.RedFlags.fDELTA -> (match lookup_rel n env with - | (_,Some body,_) -> whrec Cst_stack.empty (lift n body, stack) + | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack) | _ -> fold ()) | Var id when Closure.RedFlags.red_set flags (Closure.RedFlags.fVAR id) -> (match lookup_named id env with - | (_,Some body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack) + | LocalDef (_,body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack) | _ -> fold ()) | Evar ev -> (match safe_evar_value sigma ev with @@ -922,7 +924,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = | Some _ when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA -> apply_subst whrec [] cst_l x stack | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA -> - let env' = push_rel (na,None,t) env in + let env' = push_rel (LocalAssum (na,t)) env in let whrec' = whd_state_gen tactic_mode flags env' sigma in (match kind_of_term (Stack.zip ~refold:true (fst (whrec' (c, Stack.empty)))) with | App (f,cl) -> @@ -1442,7 +1444,7 @@ let splay_prod env sigma = let t = whd_betadeltaiota env sigma c in match kind_of_term t with | Prod (n,a,c0) -> - decrec (push_rel (n,None,a) env) + decrec (push_rel (LocalAssum (n,a)) env) ((n,a)::m) c0 | _ -> m,t in @@ -1453,7 +1455,7 @@ let splay_lam env sigma = let t = whd_betadeltaiota env sigma c in match kind_of_term t with | Lambda (n,a,c0) -> - decrec (push_rel (n,None,a) env) + decrec (push_rel (LocalAssum (n,a)) env) ((n,a)::m) c0 | _ -> m,t in @@ -1464,11 +1466,11 @@ let splay_prod_assum env sigma = let t = whd_betadeltaiota_nolet env sigma c in match kind_of_term t with | Prod (x,t,c) -> - prodec_rec (push_rel (x,None,t) env) - (Context.Rel.add (x, None, t) l) c + prodec_rec (push_rel (LocalAssum (x,t)) env) + (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> - prodec_rec (push_rel (x, Some b, t) env) - (Context.Rel.add (x, Some b, t) l) c + prodec_rec (push_rel (LocalDef (x,b,t)) env) + (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let t' = whd_betadeltaiota env sigma t in @@ -1489,8 +1491,8 @@ let splay_prod_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Prod (n,a,c0) -> - decrec (push_rel (n,None,a) env) - (m-1) (Context.Rel.add (n,None,a) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_prod_n" in decrec env n Context.Rel.empty @@ -1499,8 +1501,8 @@ let splay_lam_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Lambda (n,a,c0) -> - decrec (push_rel (n,None,a) env) - (m-1) (Context.Rel.add (n,None,a) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_lam_n" in decrec env n Context.Rel.empty @@ -1538,8 +1540,8 @@ let find_conclusion env sigma = let rec decrec env c = let t = whd_betadeltaiota env sigma c in match kind_of_term t with - | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 - | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 + | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 + | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 | t -> t in decrec env @@ -1623,7 +1625,7 @@ let meta_reducible_instance evd b = with | Some g -> irec (mkProj (p,g)) | None -> mkProj (p,c)) - | _ -> map_constr irec u + | _ -> Constr.map irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus else irec b.rebus diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index cb4e588eea..1a6f7832aa 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -18,6 +18,7 @@ open Reductionops open Environ open Termops open Arguments_renaming +open Context.Rel.Declaration type retype_error = | NotASort @@ -71,13 +72,14 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = match kind_of_term (whd_betadeltaiota env sigma ar), args with - | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some (lift n h),t) env) (n + 1) b l + | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) let type_of_var env id = - try let (_,_,ty) = lookup_named id env in ty + let open Context.Named.Declaration in + try get_type (lookup_named id env) with Not_found -> retype_error (BadVariable id) let decomp_sort env sigma t = @@ -86,13 +88,13 @@ let decomp_sort env sigma t = | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = - let rec type_of env cstr= + let rec type_of env cstr = match kind_of_term cstr with | Meta n -> (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus with Not_found -> retype_error (BadMeta n)) | Rel n -> - let (_,_,ty) = lookup_rel n env in + let ty = get_type (lookup_rel n env) in lift n ty | Var id -> type_of_var env id | Const cst -> rename_type_of_constant env cst @@ -115,9 +117,9 @@ let retype ?(polyprop=true) sigma = | Prod _ -> whd_beta sigma (applist (t, [c])) | _ -> t) | Lambda (name,c1,c2) -> - mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2) + mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2) | LetIn (name,b,c1,c2) -> - subst1 b (type_of (push_rel (name,Some b,c1) env) c2) + subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) | App(f,args) when is_template_polymorphic env f -> @@ -140,7 +142,7 @@ let retype ?(polyprop=true) sigma = | Sort (Prop c) -> type1_sort | Sort (Type u) -> Type (Univ.super u) | Prod (name,t,c2) -> - (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with + (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s @@ -161,7 +163,7 @@ let retype ?(polyprop=true) sigma = | Sort (Prop c) -> InType | Sort (Type u) -> InType | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (name,None,t) env) c2 in + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 | App(f,args) when is_template_polymorphic env f -> @@ -235,9 +237,9 @@ let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } let sorts_of_context env evc ctxt = let rec aux = function | [] -> env,[] - | (_,_,t as d)::ctxt -> + | d :: ctxt -> let env,sorts = aux ctxt in - let s = get_sort_of env evc t in + let s = get_sort_of env evc (get_type d) in (push_rel d env,s::sorts) in snd (aux ctxt) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index bd46911c92..ae224cf0d4 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -53,12 +53,13 @@ let is_evaluable env = function | EvalVarRef id -> is_evaluable_var env id let value_of_evaluable_ref env evref u = + let open Context.Named.Declaration in match evref with | EvalConstRef con -> (try constant_value_in env (con,u) with NotEvaluableConst IsProj -> raise (Invalid_argument "value_of_evaluable_ref")) - | EvalVarRef id -> Option.get (pi2 (lookup_named id env)) + | EvalVarRef id -> lookup_named id env |> get_value |> Option.get let evaluable_of_global_reference env = function | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst @@ -103,29 +104,29 @@ let destEvalRefU c = match kind_of_term c with | Evar ev -> (EvalEvar ev, Univ.Instance.empty) | _ -> anomaly (Pp.str "Not an unfoldable reference") -let unsafe_reference_opt_value env sigma eval = +let unsafe_reference_opt_value env sigma eval = match eval with | EvalConst cst -> (match (lookup_constant cst env).Declarations.const_body with | Declarations.Def c -> Some (Mod_subst.force_constr c) | _ -> None) | EvalVar id -> - let (_,v,_) = lookup_named id env in - v + let open Context.Named.Declaration in + lookup_named id env |> get_value | EvalRel n -> - let (_,v,_) = lookup_rel n env in - Option.map (lift n) v + let open Context.Rel.Declaration in + lookup_rel n env |> map_value (lift n) |> get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev let reference_opt_value env sigma eval u = match eval with | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> - let (_,v,_) = lookup_named id env in - v + let open Context.Named.Declaration in + lookup_named id env |> get_value | EvalRel n -> - let (_,v,_) = lookup_rel n env in - Option.map (lift n) v + let open Context.Rel.Declaration in + lookup_rel n env |> map_value (lift n) |> get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable @@ -258,7 +259,8 @@ let compute_consteval_direct env sigma ref = let c',l = whd_betadelta_stack env sigma c in match kind_of_term c' with | Lambda (id,t,g) when List.is_empty l && not onlyproj -> - srec (push_rel (id,None,t) env) (n+1) (t::labs) onlyproj g + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) @@ -277,7 +279,8 @@ let compute_consteval_mutual_fix env sigma ref = let nargs = List.length l in match kind_of_term c' with | Lambda (na,t,g) when List.is_empty l -> - srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct env sigma ref with @@ -371,7 +374,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs = let dummy = mkProp let vfx = Id.of_string "_expanded_fix_" let vfun = Id.of_string "_eliminator_function_" -let venv = val_of_named_context [(vfx, None, dummy); (vfun, None, dummy)] +let venv = let open Context.Named.Declaration in + val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)] (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by @@ -534,9 +538,11 @@ let match_eval_ref_value env sigma constr = | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> Some (constant_value_in env (sp, u)) | Var id when is_evaluable env (EvalVarRef id) -> - let (_,v,_) = lookup_named id env in v - | Rel n -> let (_,v,_) = lookup_rel n env in - Option.map (lift n) v + let open Context.Named.Declaration in + lookup_named id env |> get_value + | Rel n -> + let open Context.Rel.Declaration in + lookup_rel n env |> map_value (lift n) |> get_value | Evar ev -> Evd.existential_opt_value sigma ev | _ -> None @@ -601,12 +607,14 @@ let whd_nothing_for_iota env sigma s = let rec whrec (x, stack as s) = match kind_of_term x with | Rel n -> + let open Context.Rel.Declaration in (match lookup_rel n env with - | (_,Some body,_) -> whrec (lift n body, stack) + | LocalDef (_,body,_) -> whrec (lift n body, stack) | _ -> s) | Var id -> + let open Context.Named.Declaration in (match lookup_named id env with - | (_,Some body,_) -> whrec (body, stack) + | LocalDef (_,body,_) -> whrec (body, stack) | _ -> s) | Evar ev -> (try whrec (Evd.existential_value sigma ev, stack) @@ -809,7 +817,9 @@ let try_red_product env sigma c = simpfun (Stack.zip (f,stack'))) | _ -> simpfun (appvect (redrec env f, l))) | Cast (c,_,_) -> redrec env c - | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) + | Prod (x,a,b) -> + let open Context.Rel.Declaration in + mkProd (x, a, redrec (push_rel (LocalAssum (x,a)) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | Proj (p, c) -> @@ -1157,8 +1167,9 @@ let reduce_to_ind_gen allow_product env sigma t = match kind_of_term (fst (decompose_app t)) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> + let open Context.Rel.Declaration in if allow_product then - elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l) + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else errorlabstrm "" (str"Not an inductive definition.") | _ -> @@ -1235,7 +1246,8 @@ let reduce_to_ref_gen allow_product env sigma ref t = match kind_of_term c with | Prod (n,ty,t') -> if allow_product then - elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) + let open Context.Rel.Declaration in + elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l) else error_cannot_recognize ref | _ -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 3d6196c352..6c62bd08fc 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -16,6 +16,7 @@ open Evd open Util open Typeclasses_errors open Libobject +open Context.Rel.Declaration (*i*) let typeclasses_unique_solutions = ref false @@ -180,9 +181,7 @@ let subst_class (subst,cl) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx ctx = List.smartmap - (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t)) - ctx in + let do_subst_ctx = List.smartmap (map_constr do_subst) in let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in @@ -199,15 +198,19 @@ let discharge_class (_,cl) = let repl = Lib.replacement_context () in let rel_of_variable_context ctx = List.fold_right ( fun (n,_,b,t) (ctx', subst) -> - let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in + let decl = match b with + | None -> LocalAssum (Name n, substn_vars 1 subst t) + | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t) + in (decl :: ctx', n :: subst) ) ctx ([], []) in let discharge_rel_context subst n rel = let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in let ctx, _ = List.fold_right - (fun (id, b, t) (ctx, k) -> - (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k) + (fun decl (ctx, k) -> + map_constr (substn_vars k subst) decl :: ctx, succ k + ) rel ([], n) in ctx in @@ -217,15 +220,15 @@ let discharge_class (_,cl) = | ConstRef cst -> Lib.section_segment_of_constant cst | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in let discharge_context ctx' subst (grs, ctx) = - let grs' = - let newgrs = List.map (fun (_, _, t) -> - match class_of_constr t with - | None -> None - | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) - ctx' + let grs' = + let newgrs = List.map (fun decl -> + match decl |> get_type |> class_of_constr with + | None -> None + | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) + ctx' in - List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs - @ newgrs + List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs + @ newgrs in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else @@ -431,11 +434,7 @@ let add_class cl = *) let instance_constructor (cl,u) args = - let filter (_, b, _) = match b with - | None -> true - | Some _ -> false - in - let lenpars = List.count filter (snd cl.cl_context) in + let lenpars = List.count is_local_assum (snd cl.cl_context) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with | IndRef ind -> diff --git a/pretyping/typing.ml b/pretyping/typing.ml index fb0c49320f..8be28a6202 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -18,6 +18,7 @@ open Inductive open Inductiveops open Typeops open Arguments_renaming +open Context.Rel.Declaration let meta_type evd mv = let ty = @@ -88,16 +89,16 @@ let e_is_correct_arity env evdref c pj ind specif params = let rec srec env pt ar = let pt' = whd_betadeltaiota env !evdref pt in match kind_of_term pt', ar with - | Prod (na1,a1,t), (_,None,a1')::ar' -> + | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> if not (Evarconv.e_cumul env evdref a1 a1') then error (); - srec (push_rel (na1,None,a1) env) t ar' + srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Sort s, [] -> if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in evdref := Evd.define ev (mkSort s) evd - | _, (_,Some _,_ as d)::ar' -> + | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> error () @@ -229,14 +230,14 @@ let rec execute env evdref cstr = | Lambda (name,c1,c2) -> let j = execute env evdref c1 in let var = e_type_judgment env evdref j in - let env1 = push_rel (name,None,var.utj_val) env in + let env1 = push_rel (LocalAssum (name, var.utj_val)) env in let j' = execute env1 evdref c2 in judge_of_abstraction env1 name var j' | Prod (name,c1,c2) -> let j = execute env evdref c1 in let varj = e_type_judgment env evdref j in - let env1 = push_rel (name,None,varj.utj_val) env in + let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in let j' = execute env1 evdref c2 in let varj' = e_type_judgment env1 evdref j' in judge_of_product env name varj varj' @@ -246,7 +247,7 @@ let rec execute env evdref cstr = let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in - let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 diff --git a/pretyping/unification.ml b/pretyping/unification.ml index b5e882bc4b..6614749d08 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -28,6 +28,7 @@ open Locus open Locusops open Find_subterm open Sigma.Notations +open Context.Named.Declaration let keyed_unification = ref (false) let _ = Goptions.declare_bool_option { @@ -58,7 +59,7 @@ let occur_meta_or_undefined_evar evd c = | Evar_defined c -> occrec c; Array.iter occrec args | Evar_empty -> raise Occur) - | _ -> iter_constr occrec c + | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true let occur_meta_evd sigma mv c = @@ -67,7 +68,7 @@ let occur_meta_evd sigma mv c = let c = whd_evar sigma (whd_meta sigma c) in match kind_of_term c with | Meta mv' when Int.equal mv mv' -> raise Occur - | _ -> iter_constr occrec c + | _ -> Constr.iter occrec c in try occrec c; false with Occur -> true (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, @@ -75,7 +76,10 @@ let occur_meta_evd sigma mv c = let abstract_scheme env evd c l lname_typ = List.fold_left2 - (fun (t,evd) (locc,a) (na,_,ta) -> + (fun (t,evd) (locc,a) decl -> + let open Context.Rel.Declaration in + let na = get_name decl in + let ta = get_type decl in let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... @@ -146,7 +150,7 @@ let rec subst_meta_instances bl c = | Meta i -> let select (j,_,_) = Int.equal i j in (try pi2 (List.find select bl) with Not_found -> c) - | _ -> map_constr (subst_meta_instances bl) c + | _ -> Constr.map (subst_meta_instances bl) c (** [env] should be the context in which the metas live *) @@ -164,7 +168,7 @@ let pose_all_metas_as_evars env evd t = evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref; ev) | _ -> - map_constr aux t in + Constr.map aux t in let c = aux t in (* side-effect *) (!evdref, c) @@ -568,8 +572,8 @@ let subst_defined_metas_evars (bl,el) c = | Evar (evk,args) -> let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in (try substrec (pi3 (List.find select el)) - with Not_found -> map_constr substrec c) - | _ -> map_constr substrec c + with Not_found -> Constr.map substrec c) + | _ -> Constr.map substrec c in try Some (substrec c) with Not_found -> None let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN = @@ -1448,10 +1452,10 @@ let indirectly_dependent c d decls = it is needed otherwise, as e.g. when abstracting over "2" in "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious way to see that the second hypothesis depends indirectly over 2 *) - List.exists (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls + List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls let indirect_dependency d decls = - pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls)) + decls |> List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d) |> List.hd |> get_id let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = let current_sigma = Sigma.to_evar_map current_sigma in @@ -1570,7 +1574,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = in let likefirst = clause_with_generic_occurrences occs in let mkvarid () = mkVar id in - let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) = + let compute_dependency _ d (sign,depdecls) = + let hyp = get_id d in match occurrences_of_hyp hyp occs with | NoOccurrences, InHyp -> if indirectly_dependent c d depdecls then @@ -1607,7 +1612,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = replace_term_occ_modulo occ test mkvarid concl in let lastlhyp = - if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in + if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in let res = match out test with | None -> None | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma)) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 8b9c2d6c92..7ea9b90635 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -15,6 +15,7 @@ open Environ open Inductive open Reduction open Vm +open Context.Rel.Declaration (*******************************************) (* Calcul de la forme normal d'un terme *) @@ -134,7 +135,7 @@ and nf_whd env whd typ = let dom = nf_vtype env (dom p) in let name = Name (Id.of_string "x") in let vc = body_of_vfun (nb_rel env) (codom p) in - let codom = nf_vtype (push_rel (name,None,dom) env) vc in + let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) vc in mkProd(name,dom,codom) | Vfun f -> nf_fun env f typ | Vfix(f,None) -> nf_fix env f @@ -202,11 +203,12 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk = in nf_univ_args ~nb_univs mk env stk | VarKey id -> - let (_,_,ty) = lookup_named id env in + let open Context.Named.Declaration in + let ty = get_type (lookup_named id env) in nf_stk env (mkVar id) ty stk | RelKey i -> let n = (nb_rel env - i) in - let (_,_,ty) = lookup_rel n env in + let ty = get_type (lookup_rel n env) in nf_stk env (mkRel n) (lift n ty) stk and nf_stk ?from:(from=0) env c t stk = @@ -260,7 +262,7 @@ and nf_predicate env ind mip params v pT = let vb = body_of_vfun k f in let name,dom,codom = decompose_prod env pT in let dep,body = - nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in @@ -270,7 +272,7 @@ and nf_predicate env ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in - let body = nf_vtype (push_rel (name,None,dom) env) vb in + let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_val env v crazy_type @@ -306,7 +308,7 @@ and nf_fun env f typ = Errors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in - let body = nf_val (push_rel (name,None,dom) env) vb codom in + let body = nf_val (push_rel (LocalAssum (name,dom)) env) vb codom in mkLambda(name,dom,body) and nf_fix env f = diff --git a/printing/prettyp.ml b/printing/prettyp.ml index b448df3375..b7b1d67f03 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -35,7 +35,7 @@ type object_pr = { print_syntactic_def : kernel_name -> std_ppcmds; print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; - print_named_decl : Id.t * constr option * types -> std_ppcmds; + print_named_decl : Context.Named.Declaration.t -> std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds; @@ -132,7 +132,8 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in - let nprods = List.count (fun (_,b,_) -> Option.is_empty b) ctx in + let open Context.Rel.Declaration in + let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in List.exists is_status_implicit lastimpl @@ -168,8 +169,10 @@ type opacity = | FullyOpaque | TransparentMaybeOpacified of Conv_oracle.level -let opacity env = function - | VarRef v when not (Option.is_empty (pi2 (Environ.lookup_named v env))) -> +let opacity env = + let open Context.Named.Declaration in + function + | VarRef v when is_local_def (Environ.lookup_named v env) -> Some(TransparentMaybeOpacified (Conv_oracle.get_strategy (Environ.oracle env) (VarKey v))) | ConstRef cst -> @@ -440,11 +443,13 @@ let print_named_def name body typ = let print_named_assum name typ = str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" -let gallina_print_named_decl (id,c,typ) = - let s = Id.to_string id in - match c with - | Some body -> print_named_def s body typ - | None -> print_named_assum s typ +let gallina_print_named_decl = + let open Context.Named.Declaration in + function + | LocalAssum (id, typ) -> + print_named_assum (Id.to_string id) typ + | LocalDef (id, body, typ) -> + print_named_def (Id.to_string id) body typ let assumptions_for_print lna = List.fold_right (fun na env -> add_name na env) lna empty_names_context @@ -721,8 +726,8 @@ let print_any_name = function try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if not (DirPath.is_empty dir) then raise Not_found; - let (_,c,typ) = Global.lookup_named str in - (print_named_decl (str,c,typ)) + let open Context.Named.Declaration in + str |> Global.lookup_named |> set_id str |> print_named_decl with Not_found -> errorlabstrm "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") @@ -750,8 +755,8 @@ let print_opaque_name qid = let ty = Universes.unsafe_type_of_global gr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - let (_,c,ty) = lookup_named id env in - print_named_decl (id,c,ty) + let open Context.Named.Declaration in + lookup_named id env |> set_id id |> print_named_decl let print_about_any loc k = match k with diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 6f3556adba..0eab155796 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -66,7 +66,7 @@ type object_pr = { print_syntactic_def : kernel_name -> std_ppcmds; print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; - print_named_decl : Id.t * constr option * types -> std_ppcmds; + print_named_decl : Context.Named.Declaration.t -> std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds; diff --git a/printing/printer.ml b/printing/printer.ml index 93850e41fa..5f4371f2d0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -262,16 +262,19 @@ let pr_var_decl_skel pr_id env sigma (id,c,typ) = let ptyp = (str" : " ++ pt) in (pr_id id ++ hov 0 (pbody ++ ptyp)) -let pr_var_decl env sigma (id,c,typ) = - pr_var_decl_skel pr_id env sigma (id,c,typ) +let pr_var_decl env sigma d = + pr_var_decl_skel pr_id env sigma (Context.Named.Declaration.to_tuple d) let pr_var_list_decl env sigma (l,c,typ) = hov 0 (pr_var_decl_skel (fun ids -> prlist_with_sep pr_comma pr_id ids) env sigma (l,c,typ)) -let pr_rel_decl env sigma (na,c,typ) = - let pbody = match c with - | None -> mt () - | Some c -> +let pr_rel_decl env sigma decl = + let open Context.Rel.Declaration in + let na = get_name decl in + let typ = get_type decl in + let pbody = match decl with + | LocalAssum _ -> mt () + | LocalDef (_,c,_) -> (* Force evaluation *) let pb = pr_lconstr_env env sigma c in let pb = if isCast c then surround pb else pb in @@ -420,7 +423,8 @@ let pr_evgl_sign sigma evi = | None -> [], [] | Some f -> List.filter2 (fun b c -> not b) f (evar_context evi) in - let ids = List.rev_map pi1 l in + let open Context.Named.Declaration in + let ids = List.rev_map get_id l in let warn = if List.is_empty ids then mt () else (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)") diff --git a/proofs/goal.ml b/proofs/goal.ml index 1dd5be0e71..84ffee23c1 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -9,6 +9,7 @@ open Util open Pp open Term +open Context.Named.Declaration (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated @@ -73,7 +74,7 @@ module V82 = struct let (evars, evk) = Evarutil.new_pure_evar_full evars evi in let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (fun (id, _, _) -> mkVar id) ctxt in + let inst = Array.map_of_list (mkVar % get_id) ctxt in let ev = Term.mkEvar (evk,inst) in (evk, ev, evars) @@ -139,7 +140,7 @@ module V82 = struct let env = env sigma gl in let genv = Global.env () in let is_proof_var decl = - try ignore (Environ.lookup_named (Util.pi1 decl) genv); false + try ignore (Environ.lookup_named (get_id decl) genv); false with Not_found -> true in Environ.fold_named_context_reverse (fun t decl -> if is_proof_var decl then diff --git a/proofs/logic.ml b/proofs/logic.ml index 99e32db046..09f308abef 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -22,6 +22,7 @@ open Proof_type open Type_errors open Retyping open Misctypes +open Context.Named.Declaration type refiner_error = @@ -160,7 +161,8 @@ let reorder_context env sign ord = | _ -> (match ctxt_head with | [] -> error_no_such_hypothesis (List.hd ord) - | (x,_,_ as d) :: ctxt -> + | d :: ctxt -> + let x = get_id d in if Id.Set.mem x expected then step ord (Id.Set.remove x expected) ctxt (push_item x d moved_hyps) ctxt_tail @@ -175,7 +177,8 @@ let reorder_val_context env sign ord = -let check_decl_position env sign (x,_,_ as d) = +let check_decl_position env sign d = + let x = get_id d in let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if Id.List.mem x deps then @@ -200,16 +203,17 @@ let move_location_eq m1 m2 = match m1, m2 with let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h - | (hyp,_,_) :: right -> - if Id.equal hyp h then - match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveFirst + | d :: right -> + if Id.equal (get_id d) h then + match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst else get_hyp_after h right let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom - | (hyp,c,typ) as d :: right -> + | d :: right -> + let hyp,_,typ = to_tuple d in if Id.equal hyp hfrom then (left,right,d, toleft || move_location_eq hto MoveLast) else @@ -227,27 +231,28 @@ let hyp_of_move_location = function | MoveBefore id -> id | _ -> assert false -let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto = +let move_hyp toleft (left,declfrom,right) hto = let env = Global.env() in - let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) = + let test_dep d d2 = if toleft - then occur_var_in_decl env hyp2 d - else occur_var_in_decl env hyp d2 + then occur_var_in_decl env (get_id d2) d + else occur_var_in_decl env (get_id d) d2 in let rec moverec first middle = function | [] -> if match hto with MoveFirst | MoveLast -> false | _ -> true then error_no_such_hypothesis (hyp_of_move_location hto); List.rev first @ List.rev middle - | (hyp,_,_) :: _ as right when move_location_eq hto (MoveBefore hyp) -> + | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) -> List.rev first @ List.rev middle @ right - | (hyp,_,_) as d :: right -> + | d :: right -> + let hyp = get_id d in let (first',middle') = if List.exists (test_dep d) middle then if not (move_location_eq hto (MoveAfter hyp)) then (first, d::middle) else - errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++ + errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (get_id declfrom) ++ Miscprint.pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") @@ -483,12 +488,14 @@ and mk_casegoals sigma goal goalacc p c = (acc'',lbrty,conclty,sigma,p',c') -let convert_hyp check sign sigma (id,b,bt as d) = +let convert_hyp check sign sigma d = + let id,b,bt = to_tuple d in let env = Global.env() in let reorder = ref [] in let sign' = apply_to_hyp sign id - (fun _ (_,c,ct) _ -> + (fun _ d' _ -> + let _,c,ct = to_tuple d' in let env = Global.env_of_context sign in if check && not (is_conv env sigma bt ct) then errorlabstrm "Logic.convert_hyp" @@ -522,14 +529,14 @@ let prim_refiner r sigma goal = if replace then let nexthyp = get_hyp_after id (named_context_of_val sign) in let sign,t,cl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t cl in - move_hyp false ([],(id,None,t),named_context_of_val sign) + move_hyp false ([], LocalAssum (id,t),named_context_of_val sign) nexthyp, t,cl,sigma else (if !check && mem_named_context id (named_context_of_val sign) then errorlabstrm "Logic.prim_refiner" (str "Variable " ++ pr_id id ++ str " is already declared."); - push_named_context_val (id,None,t) sign,t,cl,sigma) in + push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in let oterm = Term.mkNamedLetIn id ev1 t ev2 in @@ -546,7 +553,8 @@ let prim_refiner r sigma goal = with Not_found -> error "Cannot do a fixpoint on a non inductive type." else - check_ind (push_rel (na,None,c1) env) (k-1) b + let open Context.Rel.Declaration in + check_ind (push_rel (LocalAssum (na,c1)) env) (k-1) b | _ -> error "Not enough products." in let ((sp,_),u) = check_ind env n cl in @@ -560,7 +568,7 @@ let prim_refiner r sigma goal = if !check && mem_named_context f (named_context_of_val sign) then errorlabstrm "Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); - mk_sign (push_named_context_val (f,None,ar) sign) oth + mk_sign (push_named_context_val (LocalAssum (f,ar)) sign) oth | [] -> Evd.Monad.List.map (fun (_,_,c) sigma -> let gl,ev,sig' = @@ -584,7 +592,8 @@ let prim_refiner r sigma goal = let rec check_is_coind env cl = let b = whd_betadeltaiota env sigma cl in match kind_of_term b with - | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b + | Prod (na,c1,b) -> let open Context.Rel.Declaration in + check_is_coind (push_rel (LocalAssum (na,c1)) env) b | _ -> try let _ = find_coinductive env sigma b in () @@ -601,7 +610,7 @@ let prim_refiner r sigma goal = error "Name already used in the environment.") with | Not_found -> - mk_sign (push_named_context_val (f,None,ar) sign) oth) + mk_sign (push_named_context_val (LocalAssum (f,ar)) sign) oth) | [] -> Evd.Monad.List.map (fun (_,c) sigma -> let gl,ev,sigma = diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index fc33e9a657..403a36141f 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -267,18 +267,19 @@ let _ = Goptions.declare_bool_option Goptions.optwrite = (fun b -> proof_using_auto_clear := b) } let set_used_variables l = + let open Context.Named.Declaration in let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in let ctx_set = - List.fold_right Id.Set.add (List.map pi1 ctx) Id.Set.empty in + List.fold_right Id.Set.add (List.map get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in let aux env entry (ctx, all_safe, to_clear as orig) = match entry with - | (x,None,_) -> + | LocalAssum (x,_) -> if Id.Set.mem x all_safe then orig else (ctx, all_safe, (Loc.ghost,x)::to_clear) - | (x,Some bo, ty) as decl -> + | LocalDef (x,bo, ty) as decl -> if Id.Set.mem x all_safe then orig else let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in if Id.Set.subset vars all_safe diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index a69645b116..681a7fa1ad 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -10,6 +10,7 @@ open Names open Environ open Util open Vernacexpr +open Context.Named.Declaration let to_string e = let rec aux = function @@ -33,7 +34,8 @@ let in_nameset = let rec close_fwd e s = let s' = - List.fold_left (fun s (id,b,ty) -> + List.fold_left (fun s decl -> + let (id,b,ty) = Context.Named.Declaration.to_tuple decl in let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in let vty = global_vars_set e ty in let vbty = Id.Set.union vb vty in @@ -61,13 +63,13 @@ and set_of_id env ty id = Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty else if Id.to_string id = "All" then - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty else if CList.mem_assoc_f Id.equal id !known_names then process_expr env (CList.assoc_f Id.equal id !known_names) [] else Id.Set.singleton id and full_set env = - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty let process_expr env e ty = let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in diff --git a/proofs/proofview.ml b/proofs/proofview.ml index ff8effcda4..ebce25d293 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -17,6 +17,7 @@ open Pp open Util open Proofview_monad open Sigma.Notations +open Context.Named.Declaration (** Main state of tactics *) type proofview = Proofview_monad.proofview @@ -750,9 +751,15 @@ module Progress = struct let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = let open Environ in let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in - let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = - Names.Id.equal i1 i2 && Option.equal (eq_constr sigma1 sigma2) c1 c2 - && (eq_constr sigma1 sigma2) t1 t2 + let eq_named_declaration d1 d2 = + match d1, d2 with + | LocalAssum (i1,t1), LocalAssum (i2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 + | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 + && eq_constr sigma1 sigma2 t1 t2 + | _ -> + false in List.equal eq_named_declaration c1 c2 let eq_evar_body sigma1 sigma2 b1 b2 = @@ -1075,12 +1082,13 @@ struct let typecheck_evar ev env sigma = let info = Evd.find sigma ev in (** Typecheck the hypotheses. *) - let type_hyp (sigma, env) (na, body, t as decl) = + let type_hyp (sigma, env) decl = + let t = get_type decl in let evdref = ref sigma in let _ = Typing.sort_of env evdref t in - let () = match body with - | None -> () - | Some body -> Typing.check env evdref body t + let () = match decl with + | LocalAssum _ -> () + | LocalDef (_,body,_) -> Typing.check env evdref body t in (!evdref, Environ.push_named decl env) in diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 8d6bdf6aec..186525e159 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -13,7 +13,7 @@ open Evd open Environ open Proof_type open Logic - +open Context.Named.Declaration let sig_it x = x.it let project x = x.sigma @@ -202,7 +202,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) let { it = gls; sigma = sigma; } = rslt in let hyps:Context.Named.t list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in - let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in + let cmp d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in let newhyps = List.map (fun hypl -> List.subtract cmp hypl oldhyps) @@ -215,7 +215,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) List.fold_left (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ") ^ (List.fold_left - (fun acc (nm,_,_) -> (Names.Id.to_string nm) ^ " " ^ acc) + (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc) "" lh)) "" newhyps in pp (str (emacs_str "") diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a1ebacea84..429bd27742 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -18,6 +18,7 @@ open Tacred open Proof_type open Logic open Refiner +open Context.Named.Declaration let re_sig it gc = { it = it; sigma = gc; } @@ -40,9 +41,11 @@ let pf_hyps = Refiner.pf_hyps let pf_concl gls = Goal.V82.concl (project gls) (sig_it gls) let pf_hyps_types gls = let sign = Environ.named_context (pf_env gls) in - List.map (fun (id,_,x) -> (id, x)) sign + List.map (function LocalAssum (id,x) + | LocalDef (id,_,x) -> id, x) + sign -let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id +let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id let pf_last_hyp gl = List.hd (pf_hyps gl) @@ -53,8 +56,7 @@ let pf_get_hyp gls id = raise (RefinerError (NoSuchHyp id)) let pf_get_hyp_typ gls id = - let (_,_,ty)= (pf_get_hyp gls id) in - ty + pf_get_hyp gls id |> get_type let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) @@ -204,13 +206,14 @@ module New = struct sign let pf_get_hyp_typ id gl = - let (_,_,ty) = pf_get_hyp id gl in - ty + pf_get_hyp id gl |> get_type let pf_hyps_types gl = let env = Proofview.Goal.env gl in let sign = Environ.named_context env in - List.map (fun (id,_,x) -> (id, x)) sign + List.map (function LocalAssum (id,x) + | LocalDef (id,_,x) -> id, x) + sign let pf_last_hyp gl = let hyps = Proofview.Goal.hyps gl in diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 845f83a401..ac54028eb7 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -31,6 +31,7 @@ open Reductionops open Constrexpr open Constrintern open Impargs +open Context.Rel.Declaration type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a let mk_hook hook = hook @@ -44,7 +45,8 @@ let call_hook fix_exn hook l c = let retrieve_first_recthm = function | VarRef id -> - (pi2 (Global.lookup_named id),variable_opacity id) + let open Context.Named.Declaration in + (get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in (Global.body_of_constant_body cb, is_opaque cb) @@ -107,11 +109,12 @@ let find_mutually_recursive_statements thms = (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c)) (Global.env()) hyps in let ind_hyps = - List.flatten (List.map_i (fun i (_,b,t) -> + List.flatten (List.map_i (fun i decl -> + let t = get_type decl in match kind_of_term t with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in - mind.mind_finite <> Decl_kinds.CoFinite && Option.is_empty b -> + mind.mind_finite <> Decl_kinds.CoFinite && is_local_assum decl -> [ind,x,i] | _ -> []) 0 (List.rev whnf_hyp_hds)) in @@ -450,7 +453,7 @@ let start_proof_com kind thms hook = let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in evdref := solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref); - let ids = List.map pi1 ctx in + let ids = List.map get_name ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), diff --git a/stm/stm.ml b/stm/stm.ml index e8b500a620..1503c0f8ab 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1477,10 +1477,8 @@ end = struct (* {{{ *) let g = Evd.find sigma0 r_goal in if not ( Evarutil.is_ground_term sigma0 Evd.(evar_concl g) && - List.for_all (fun (_,bo,ty) -> - Evarutil.is_ground_term sigma0 ty && - Option.cata (Evarutil.is_ground_term sigma0) true bo) - Evd.(evar_context g)) + List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) + Evd.(evar_context g)) then Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^ "goals only")) diff --git a/tactics/auto.ml b/tactics/auto.ml index 6caebf6c4f..86b71999b1 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -324,7 +324,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in - let hyp = Context.Named.Declaration.map nf decl in + let hyp = Context.Named.Declaration.map_constr nf decl in let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 40c0f7f9b0..ea598b61ca 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -133,7 +133,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = fun dir cstr tac gl -> let last_hyp_id = match Tacmach.pf_hyps gl with - (last_hyp_id,_,_)::_ -> last_hyp_id + d :: _ -> Context.Named.Declaration.get_id d | _ -> (* even the hypothesis id is missing *) raise (Logic.RefinerError (Logic.NoSuchHyp !id)) in @@ -142,7 +142,8 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = match gls with g::_ -> (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with - (lastid,_,_)::_ -> + d ::_ -> + let lastid = Context.Named.Declaration.get_id d in if not (Id.equal last_hyp_id lastid) then begin let gl'' = diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index c9b2c7cfde..7c05befddd 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -302,8 +302,10 @@ type ('a,'b) optionk2 = | Nonek2 of failure | Somek2 of 'a * 'b * ('a,'b) optionk2 fk -let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = - let cty = Evarutil.nf_evar sigma cty in +let make_resolve_hyp env sigma st flags only_classes pri decl = + let open Context.Named.Declaration in + let id = get_id decl in + let cty = Evarutil.nf_evar sigma (get_type decl) in let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with @@ -345,9 +347,10 @@ let make_hints g st only_classes sign = List.fold_left (fun (paths, hints) hyp -> let consider = - try let (_, b, t) = Global.lookup_named (pi1 hyp) in + let open Context.Named.Declaration in + try let t = Global.lookup_named (get_id hyp) |> get_type in (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (pi3 hyp)) + not (Term.eq_constr t (get_type hyp)) with Not_found -> true in if consider then diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index c4a23f6862..ab6fb37fd1 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -15,6 +15,7 @@ open Reductionops open Misctypes open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration (* Absurd *) @@ -47,7 +48,7 @@ let absurd c = absurd c let filter_hyp f tac = let rec seek = function | [] -> Proofview.tclZERO Not_found - | (id,_,t)::rest when f t -> tac id + | d::rest when f (get_type d) -> tac (get_id d) | _::rest -> seek rest in Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -60,8 +61,9 @@ let contradiction_context = let env = Proofview.Goal.env gl in let rec seek_neg l = match l with | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") - | (id,_,typ)::rest -> - let typ = nf_evar sigma typ in + | d :: rest -> + let id = get_id d in + let typ = nf_evar sigma (get_type d) in let typ = whd_betadeltaiota env sigma typ in if is_empty_type typ then simplest_elim (mkVar id) diff --git a/tactics/elim.ml b/tactics/elim.ml index 7767affccc..d441074f6a 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -16,6 +16,7 @@ open Tacmach.New open Tacticals.New open Tactics open Proofview.Notations +open Context.Named.Declaration (* Supposed to be called without as clause *) let introElimAssumsThen tac ba = @@ -137,7 +138,8 @@ let induction_trailer abs_i abs_j bargs = in let (hyps,_) = List.fold_left - (fun (bring_ids,leave_ids) (cid,_,_ as d) -> + (fun (bring_ids,leave_ids) d -> + let cid = get_id d in if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) else (bring_ids,cid::leave_ids)) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index e0bea77703..a03489c805 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -58,6 +58,7 @@ open Inductiveops open Ind_tables open Indrec open Sigma.Notations +open Context.Rel.Declaration let hid = Id.of_string "H" let xid = Id.of_string "X" @@ -104,7 +105,7 @@ let get_sym_eq_data env (ind,u) = error "Not an inductive type with a single constructor."; let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in - if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then + if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in @@ -139,7 +140,7 @@ let get_non_sym_eq_data env (ind,u) = error "Not an inductive type with a single constructor."; let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in - if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then + if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported"; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in @@ -173,7 +174,7 @@ let build_sym_scheme env ind = let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in let c = (my_it_mkLambda_or_LetIn paramsctxt @@ -232,7 +233,7 @@ let build_sym_involutive_scheme env ind = (Context.Rel.to_extended_vect (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in let c = (my_it_mkLambda_or_LetIn paramsctxt @@ -352,9 +353,9 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect 0 nrealargs]) in let realsign_P = lift_rel_context nrealargs realsign in let realsign_ind_P = - name_context env ((Name varH,None,applied_ind_P)::realsign_P) in + name_context env ((LocalAssum (Name varH,applied_ind_P))::realsign_P) in let realsign_ind_G = - name_context env ((Name varH,None,applied_ind_G):: + name_context env ((LocalAssum (Name varH,applied_ind_G)):: lift_rel_context (nrealargs+3) realsign) in let applied_sym_C n = mkApp(sym, @@ -465,9 +466,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = rel_vect (2*nrealargs+1) nrealargs]) in let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let realsign_ind_P n aP = - name_context env ((Name varH,None,aP)::realsign_P n) in + name_context env ((LocalAssum (Name varH,aP))::realsign_P n) in let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in @@ -545,7 +546,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in @@ -599,9 +600,9 @@ let fix_r2l_forward_rew_scheme (c, ctx') = | hp :: p :: ind :: indargs -> let c' = my_it_mkLambda_or_LetIn indargs - (mkLambda_or_LetIn (Context.Rel.Declaration.map (liftn (-1) 1) p) - (mkLambda_or_LetIn (Context.Rel.Declaration.map (liftn (-1) 2) hp) - (mkLambda_or_LetIn (Context.Rel.Declaration.map (lift 2) ind) + (mkLambda_or_LetIn (map_constr (liftn (-1) 1) p) + (mkLambda_or_LetIn (map_constr (liftn (-1) 2) hp) + (mkLambda_or_LetIn (map_constr (lift 2) ind) (Reductionops.whd_beta Evd.empty (applist (c, Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) @@ -737,10 +738,10 @@ let build_congr env (eq,refl,ctx) ind = let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in - if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then + if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in - let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in + let ty = get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt) then diff --git a/tactics/equality.ml b/tactics/equality.ml index 1e814e861c..d27dcd82a1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -43,6 +43,7 @@ open Misctypes open Sigma.Notations open Proofview.Notations open Unification +open Context.Named.Declaration (* Options *) @@ -960,7 +961,7 @@ let apply_on_clause (f,t) clause = let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = let e = next_ident_away eq_baseid (ids_of_context env) in - let e_env = push_named (e,None,t) env in + let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in let discriminator = build_discriminator e_env sigma dirn (mkVar e) sort cpath in let sigma,(pf, absurd_term), eff = @@ -1064,7 +1065,7 @@ let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in - let (na,_,_) = lookup_rel lind env in + let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) @@ -1335,7 +1336,7 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in - let e_env = push_named (e, None,t) env in + let e_env = push_named (LocalAssum (e,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try @@ -1612,14 +1613,14 @@ let unfold_body x = Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let (_, xval, _) = Context.Named.lookup x hyps in + let xval = Context.Named.lookup x hyps |> get_value in let xval = match xval with | None -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | Some xval -> pf_nf_evar gl xval in afterHyp x begin fun aft -> - let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in + let hl = List.fold_right (fun d cl -> (get_id d, InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in let reducth h = Proofview.V82.tactic (fun gl -> reduct_in_hyp rfun h gl) in @@ -1636,9 +1637,10 @@ let restrict_to_eq_and_identity eq = (* compatibility *) exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) -let is_eq_x gl x (id,_,c) = +let is_eq_x gl x d = + let id = get_id d in try - let c = pf_nf_evar gl c in + let c = pf_nf_evar gl (get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (Term.eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); if (Term.eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) @@ -1655,11 +1657,12 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in (* The set of hypotheses using x *) let dephyps = - List.rev (snd (List.fold_right (fun (id,b,_ as dcl) (deps,allhyps) -> + List.rev (snd (List.fold_right (fun dcl (deps,allhyps) -> + let id = get_id dcl in if not (Id.equal id hyp) && List.exists (fun y -> occur_var_in_decl env y dcl) deps then - ((if b = None then deps else id::deps), id::allhyps) + ((if is_local_assum dcl then deps else id::deps), id::allhyps) else (deps,allhyps)) hyps @@ -1683,7 +1686,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = let subst_one_var dep_proof_ok x = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in - let (_,xval,_) = pf_get_hyp x gl in + let xval = pf_get_hyp x gl |> get_value in (* If x has a body, simply replace x with body and clear x *) if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else (* x is a variable: *) @@ -1742,14 +1745,14 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let test (hyp,_,c) = + let test decl = try - let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with | Var z, _ | _, Var z when not (is_evaluable env (EvalVarRef z)) -> - Some hyp + Some (get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None @@ -1763,7 +1766,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let (_,_,c) = pf_get_hyp hyp gl in + let c = pf_get_hyp hyp gl |> get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else @@ -1831,10 +1834,11 @@ let cond_eq_term c t gl = let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with | [] -> error "No such assumption." - | (id,_,t) ::rest -> + | hyp ::rest -> + let id = get_id hyp in begin try - let dir = cond_eq_term t gl in + let dir = cond_eq_term (get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 97b5ba0cc5..f443837a41 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -16,6 +16,7 @@ open Evd open Locus open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration (* The instantiate tactic *) @@ -43,14 +44,14 @@ let instantiate_tac n c ido = match hloc with InHyp -> (match decl with - (_,None,typ) -> evar_list typ + | LocalAssum (_,typ) -> evar_list typ | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> - let (_, _, typ) = decl in evar_list typ + evar_list (get_type decl) | InHypValueOnly -> (match decl with - (_,Some body,_) -> evar_list body + | LocalDef (_,body,_) -> evar_list body | _ -> error "Not a defined hypothesis.") in if List.length evl < n then error "Not enough uninstantiated existential variables."; diff --git a/tactics/hints.ml b/tactics/hints.ml index c99e591fe6..730da147af 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -34,6 +34,7 @@ open Tacred open Printer open Vernacexpr open Sigma.Notations +open Context.Named.Declaration (****************************************) (* General functions *) @@ -727,11 +728,12 @@ let make_resolves env sigma flags pri poly ?name cr = ents (* used to add an hypothesis to the local hint database *) -let make_resolve_hyp env sigma (hname,_,htyp) = +let make_resolve_hyp env sigma decl = + let hname = get_id decl in try [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (mkVar hname, htyp, Univ.ContextSet.empty)] + (mkVar hname, get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -1061,7 +1063,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = (* Not clever enough to construct dependency graph of evars *) error "Not clever enough to deal with evars dependent in other evars."; raise (Found (c,t)) - | _ -> iter_constr find_next_evar c in + | _ -> Constr.iter find_next_evar c in let rec iter c = try find_next_evar c; c with Found (evar,t) -> diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 29d848ca13..bcec90f803 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -19,6 +19,7 @@ open Constr_matching open Coqlib open Declarations open Tacmach.New +open Context.Rel.Declaration (* I implemented the following functions which test whether a term t is an inductive but non-recursive type, a general conjuction, a @@ -101,13 +102,16 @@ let match_with_one_constructor style onlybinary allow_rec t = (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in if List.for_all - (fun (_,b,c) -> Option.is_empty b && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx + (fun decl -> let c = get_type decl in + is_local_assum decl && + isRel c && + Int.equal (destRel c) mib.mind_nparams) ctx then Some (hdapp,args) else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in - let cargs = List.map pi3 ((prod_assum ctyp)) in + let cargs = List.map get_type (prod_assum ctyp) in if not (is_lax_conjunction style) || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) @@ -152,7 +156,7 @@ let is_tuple t = let test_strict_disjunction n lc = Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i) + | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = diff --git a/tactics/inv.ml b/tactics/inv.ml index ded1e8076d..9bfbbc41b7 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -28,6 +28,7 @@ open Misctypes open Tacexpr open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration let clear hyps = Proofview.V82.tactic (clear hyps) @@ -181,9 +182,9 @@ let make_inv_predicate env evd indf realargs id status concl = let dependent_hyps env id idlist gl = let rec dep_rec =function | [] -> [] - | (id1,_,_)::l -> + | d::l -> (* Update the type of id1: it may have been subject to rewriting *) - let d = pf_get_hyp id1 gl in + let d = pf_get_hyp (get_id d) gl in if occur_var_in_decl env id d then d :: dep_rec l else dep_rec l @@ -192,8 +193,8 @@ let dependent_hyps env id idlist gl = let split_dep_and_nodep hyps gl = List.fold_right - (fun (id,_,_ as d) (l1,l2) -> - if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2)) + (fun d (l1,l2) -> + if var_occurs_in_pf gl (get_id d) then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) (* Computation of dids is late; must have been done in rewrite_equations*) @@ -296,8 +297,8 @@ let get_names (allow_conj,issimple) (loc, pat as x) = match pat with error "Discarding pattern not allowed for inversion equations." | IntroAction (IntroRewrite _) -> error "Rewriting pattern not allowed for inversion equations." - | IntroAction (IntroOrAndPattern (IntroAndPattern [] | IntroOrPattern [[]])) when allow_conj -> (None, []) - | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ])) + | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) + | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l))) when allow_conj -> (Some id,l) | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then @@ -384,7 +385,7 @@ let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.nf_enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in - let avoid = if as_mode then List.map pi1 nodepids else [] in + let avoid = if as_mode then List.map get_id nodepids else [] in match othin with | Some thin -> tclTHENLIST @@ -399,11 +400,11 @@ let rewrite_equations as_mode othin neqns names ba = (onLastHypId (fun id -> tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; - tclMAP (fun (id,_,_) -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) - let idopt = if as_mode then Some id else None in + tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) + let idopt = if as_mode then Some (get_id d) else None in intro_move idopt (if thin then MoveLast else !first_eq)) nodepids; - (tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids)] + (tclMAP (fun d -> tclTRY (clear [get_id d])) depids)] | None -> (* simple inversion *) if as_mode then diff --git a/tactics/leminv.ml b/tactics/leminv.ml index cdf38ae46a..70782ec648 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -27,6 +27,7 @@ open Tacticals.New open Tactics open Decl_kinds open Proofview.Notations +open Context.Named.Declaration let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ @@ -117,11 +118,11 @@ let rec add_prods_sign env sigma t = | Prod (na,c1,b) -> let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (id,None,c1) env) sigma b' + add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' | LetIn (na,c1,t1,b) -> let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (id,Some c1,t1) env) sigma b' + add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' | _ -> (env,t) (* [dep_option] indicates whether the inversion lemma is dependent or not. @@ -154,7 +155,8 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let ivars = global_vars env i in let revargs,ownsign = fold_named_context - (fun env (id,_,_ as d) (revargs,hyps) -> + (fun env d (revargs,hyps) -> + let id = get_id d in if Id.List.mem id ivars then ((mkVar id)::revargs, Context.Named.add d hyps) else @@ -166,7 +168,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = (pty,goal) in let npty = nf_betadeltaiota env sigma pty in - let extenv = push_named (p,None,npty) env in + let extenv = push_named (LocalAssum (p,npty)) env in extenv, goal (* [inversion_scheme sign I] @@ -203,8 +205,8 @@ let inversion_scheme env sigma t sort dep_option inv_op = let global_named_context = Global.named_context () in let ownSign = ref begin fold_named_context - (fun env (id,_,_ as d) sign -> - if mem_named_context id global_named_context then sign + (fun env d sign -> + if mem_named_context (get_id d) global_named_context then sign else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in @@ -217,9 +219,9 @@ let inversion_scheme env sigma t sort dep_option inv_op = let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := h::!avoid; - ownSign := Context.Named.add (h,None,ty) !ownSign; + ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; applist (mkVar h, inst) - | _ -> map_constr fill_holes c + | _ -> Constr.map fill_holes c in let c = fill_holes pfterm in (* warning: side-effect on ownSign *) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 29002af9e0..b39e34fc1b 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -36,6 +36,7 @@ open Termops open Libnames open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration (** Typeclass-based generalized rewriting. *) @@ -134,6 +135,7 @@ module GlobalBindings (M : sig val arrow : evars -> evars * constr end) = struct open M + open Context.Rel.Declaration let relation : evars -> evars * constr = find_global (fst relation) (snd relation) let reflexive_type = find_global relation_classes "Reflexive" @@ -219,8 +221,8 @@ end) = struct let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else - let (evars, b, arg, cstrs) = - aux (Environ.push_rel (na, None, ty) env) evars b cstrs + let (evars, b, arg, cstrs) = + aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs in let ty = Reductionops.nf_betaiota (goalevars evars) ty in let pred = mkLambda (na, ty, b) in @@ -318,7 +320,7 @@ end) = struct let evars, rb = aux evars env b' (pred n) in app_poly env evars pointwise_relation [| ty; b'; rb |] else - let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in + let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in app_poly env evars forall_relation [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] | _ -> raise Not_found @@ -469,6 +471,7 @@ let rec decompose_app_rel env evd t = | _ -> error "Cannot find a relation to rewrite." let decompose_applied_relation env sigma (c,l) = + let open Context.Rel.Declaration in let ctype = Retyping.get_type_of env sigma c in let find_rel ty = let sigma, cl = Clenv.make_evar_clause env sigma ty in @@ -491,7 +494,7 @@ let decompose_applied_relation env sigma (c,l) = | Some c -> c | None -> let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with | Some c -> c | None -> error "Cannot find an homogeneous relation to rewrite." @@ -766,9 +769,9 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation in Environ.push_named - (Id.of_string "do_subrelation", - Some (snd (app_poly_sort b env evars dosub [||])), - snd (app_poly_nocheck env evars appsub [||])) + (LocalDef (Id.of_string "do_subrelation", + snd (app_poly_sort b env evars dosub [||]), + snd (app_poly_nocheck env evars appsub [||]))) env in let evars, morph = new_cstr_evar evars env' app in @@ -1110,8 +1113,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in - let env' = Environ.push_rel (n', None, t) env in + let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let open Context.Rel.Declaration in + let env' = Environ.push_rel (LocalAssum (n', t)) env in let bty = Retyping.get_type_of env' (goalevars evars) b in let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in let state, b' = s.strategy { state ; env = env' ; unfresh ; @@ -1495,8 +1499,8 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul (** Insert a declaration after the last declaration it depends on *) let rec insert_dependent env decl accu hyps = match hyps with | [] -> List.rev_append accu [decl] -| (id, _, _ as ndecl) :: rem -> - if occur_var_in_decl env id decl then +| ndecl :: rem -> + if occur_var_in_decl env (get_id ndecl) decl then List.rev_append accu (decl :: hyps) else insert_dependent env decl (ndecl :: accu) rem @@ -1506,16 +1510,19 @@ let assert_replacing id newt tac = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let ctx = Environ.named_context env in - let after, before = List.split_when (fun (n, b, t) -> Id.equal n id) ctx in + let after, before = List.split_when (Id.equal id % get_id) ctx in let nc = match before with | [] -> assert false - | (id, b, _) :: rem -> insert_dependent env (id, None, newt) [] after @ rem + | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Proofview.Refine.refine ~unsafe:false { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in - let map (n, _, _) = if Id.equal n id then ev' else mkVar n in + let map d = + let n = get_id d in + if Id.equal n id then ev' else mkVar n + in let (e, _) = destEvar ev in Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) end } @@ -1543,7 +1550,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = assert_replacing id newt tac | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (id, None, newt) + convert_hyp_no_check (LocalAssum (id, newt)) | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> Proofview.Goal.enter { enter = begin fun gl -> @@ -2053,7 +2060,8 @@ let setoid_proof ty fn fallback = try let rel, _, _ = decompose_app_rel env sigma concl in let evm = sigma in - let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.unsafe_type_of env evm rel)))) in + let open Context.Rel.Declaration in + let car = get_type (List.hd (fst (Reduction.dest_prod env (Typing.unsafe_type_of env evm rel)))) in (try init_setoid () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 1112da4a0d..30a9071fda 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -42,6 +42,7 @@ open Tacintern open Taccoerce open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> let Val.Dyn (t, _) = v in @@ -444,14 +445,13 @@ let interp_reference ist env sigma = function try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id) with Not_found -> try - let (v, _, _) = Environ.lookup_named id env in - VarRef v + VarRef (get_id (Environ.lookup_named id env)) with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in match v with - | (_, Some _, _) -> EvalVarRef id + | LocalDef _ -> EvalVarRef id | _ -> error_not_evaluable (VarRef id) let interp_evaluable ist env sigma = function diff --git a/tactics/tactic_matching.ml b/tactics/tactic_matching.ml index 80786058d9..2144b75e74 100644 --- a/tactics/tactic_matching.ml +++ b/tactics/tactic_matching.ml @@ -11,6 +11,7 @@ open Names open Tacexpr +open Context.Named.Declaration (** [t] is the type of matching successes. It ultimately contains a {!Tacexpr.glob_tactic_expr} representing the left-hand side of the @@ -278,9 +279,10 @@ module PatternMatching (E:StaticEnvironment) = struct [hyps]. Tries the hypotheses in order. For each success returns the name of the matched hypothesis. *) let hyp_match_type hypname pat hyps = - pick hyps >>= fun (id,b,hyp) -> - let refresh = not (Option.is_empty b) in - pattern_match_term refresh pat hyp () <*> + pick hyps >>= fun decl -> + let id = get_id decl in + let refresh = is_local_def decl in + pattern_match_term refresh pat (get_type decl) () <*> put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> return id @@ -290,12 +292,12 @@ module PatternMatching (E:StaticEnvironment) = struct success returns the name of the matched hypothesis. *) let hyp_match_body_and_type hypname bodypat typepat hyps = pick hyps >>= function - | (id,Some body,hyp) -> + | LocalDef (id,body,hyp) -> pattern_match_term false bodypat body () <*> pattern_match_term true typepat hyp () <*> put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> return id - | (id,None,hyp) -> fail + | LocalAssum (id,hyp) -> fail (** [hyp_match pat hyps] dispatches to {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether @@ -317,7 +319,7 @@ module PatternMatching (E:StaticEnvironment) = struct (* spiwack: alternatively it is possible to return the list with the matched hypothesis removed directly in [hyp_match]. *) - let select_matched_hyp (id,_,_) = Id.equal id matched_hyp in + let select_matched_hyp decl = Id.equal (get_id decl) matched_hyp in let hyps = CList.remove_first select_matched_hyp hyps in hyp_pattern_list_match pats hyps lhs | [] -> return lhs diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index d79de4913c..7f904a561d 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -16,6 +16,7 @@ open Declarations open Tacmach open Clenv open Sigma.Notations +open Context.Named.Declaration (************************************************************************) (* Tacticals re-exported from the Refiner module *) @@ -69,7 +70,7 @@ let nthDecl m gl = try List.nth (pf_hyps gl) (m-1) with Failure _ -> error "No such assumption." -let nthHypId m gl = pi1 (nthDecl m gl) +let nthHypId m gl = nthDecl m gl |> get_id let nthHyp m gl = mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl @@ -80,7 +81,7 @@ let nLastDecls n gl = try List.firstn n (pf_hyps gl) with Failure _ -> error "Not enough hypotheses in the goal." -let nLastHypsId n gl = List.map pi1 (nLastDecls n gl) +let nLastHypsId n gl = List.map get_id (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) let onNthDecl m tac gl = tac (nthDecl m gl) gl @@ -98,7 +99,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac let onNLastHyps n tac = onHyps (nLastHyps n) tac let afterHyp id gl = - fst (List.split_when (fun (hyp,_,_) -> Id.equal hyp id) (pf_hyps gl)) + fst (List.split_when (Id.equal id % get_id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) @@ -552,8 +553,7 @@ module New = struct let nthHypId m gl = (** We only use [id] *) let gl = Proofview.Goal.assume gl in - let (id,_,_) = nthDecl m gl in - id + nthDecl m gl |> get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -585,7 +585,7 @@ module New = struct let afterHyp id tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps gl in - let rem, _ = List.split_when (fun (hyp,_,_) -> Id.equal hyp id) hyps in + let rem, _ = List.split_when (Id.equal id % get_id) hyps in tac rem end } diff --git a/tactics/tactics.ml b/tactics/tactics.ml index aeb3726a0c..8f30df5c04 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -161,19 +161,21 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) -let unsafe_intro env store (id, c, t) b = +let unsafe_intro env store decl b = + let open Context.Named.Declaration in Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let ctx = named_context_val env in - let nctx = push_named_context_val (id, c, t) ctx in - let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in + let nctx = push_named_context_val decl ctx in + let inst = List.map (mkVar % get_id) (named_context env) in let ninst = mkRel 1 :: inst in - let nb = subst1 (mkVar id) b in + let nb = subst1 (mkVar (get_id decl)) b in let sigma, ev = new_evar_instance nctx sigma nb ~principal:true ~store ninst in - Sigma.Unsafe.of_pair (mkNamedLambda_or_LetIn (id, c, t) ev, sigma) + Sigma.Unsafe.of_pair (mkNamedLambda_or_LetIn decl ev, sigma) end } let introduction ?(check=true) id = + let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in @@ -186,8 +188,8 @@ let introduction ?(check=true) id = (str "Variable " ++ pr_id id ++ str " is already declared.") in match kind_of_term (whd_evar sigma concl) with - | Prod (_, t, b) -> unsafe_intro env store (id, None, t) b - | LetIn (_, c, t, b) -> unsafe_intro env store (id, Some c, t) b + | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b + | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) end } @@ -296,6 +298,7 @@ let move_hyp id dest gl = Tacmach.move_hyp id dest gl (* Renaming hypotheses *) let rename_hyp repl = + let open Context.Named.Declaration in let fold accu (src, dst) = match accu with | None -> None | Some (srcs, dsts) -> @@ -317,7 +320,7 @@ let rename_hyp repl = let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in (** Check that we do not mess variables *) - let fold accu (id, _, _) = Id.Set.add id accu in + let fold accu decl = Id.Set.add (get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then @@ -335,14 +338,14 @@ let rename_hyp repl = let make_subst (src, dst) = (src, mkVar dst) in let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in - let map (id, body, t) = - let id = try List.assoc_f Id.equal id repl with Not_found -> id in - (id, Option.map subst body, subst t) + let map decl = + decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) + |> map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in - let instance = List.map (fun (id, _, _) -> mkVar id) hyps in + let instance = List.map (mkVar % get_id) hyps in Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = Evarutil.new_evar_instance nctx sigma nconcl ~store instance in @@ -370,11 +373,13 @@ let id_of_name_with_default id = function let default_id_of_sort s = if Sorts.is_small s then default_small_ident else default_type_ident -let default_id env sigma = function - | (name,None,t) -> +let default_id env sigma decl = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (name,t) -> let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in id_of_name_with_default dft name - | (name,Some b,_) -> id_of_name_using_hdchar env b name + | LocalDef (name,b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by intro_then_gen There is possibly renaming, with possibly names to avoid and @@ -409,8 +414,9 @@ let find_name mayrepl decl naming gl = match naming with (**************************************************************) let assert_before_then_gen b naming t tac = + let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (Anonymous,None,t) naming gl in + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> @@ -427,8 +433,9 @@ let assert_before na = assert_before_gen false (naming_of_name na) let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) let assert_after_then_gen b naming t tac = + let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (Anonymous,None,t) naming gl in + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> @@ -472,17 +479,18 @@ let cofix ido gl = match ido with type tactic_reduction = env -> evar_map -> constr -> constr -let pf_reduce_decl redfun where (id,c,ty) gl = +let pf_reduce_decl redfun where decl gl = + let open Context.Named.Declaration in let redfun' = Tacmach.pf_reduce redfun gl in - match c with - | None -> + match decl with + | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); - (id,None,redfun' ty) - | Some b -> + LocalAssum (id,redfun' ty) + | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in let ty' = if where != InHypValueOnly then redfun' ty else ty in - (id,Some b',ty') + LocalDef (id,b',ty') (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) @@ -568,19 +576,20 @@ let reduct_option ?(check=false) redfun = function (** Tactic reduction modulo evars (for universes essentially) *) -let pf_e_reduce_decl redfun where (id,c,ty) gl = +let pf_e_reduce_decl redfun where decl gl = + let open Context.Named.Declaration in let sigma = project gl in let redfun = redfun (pf_env gl) in - match c with - | None -> + match decl with + | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); let sigma, ty' = redfun sigma ty in - sigma, (id,None,ty') - | Some b -> + sigma, LocalAssum (id,ty') + | LocalDef (id,b,ty) -> let sigma, b' = if where != InHypTypeOnly then redfun sigma b else sigma, b in let sigma, ty' = if where != InHypValueOnly then redfun sigma ty else sigma, ty in - sigma, (id,Some b',ty') + sigma, LocalDef (id,b',ty') let e_reduct_in_concl (redfun,sty) gl = Proofview.V82.of_tactic @@ -609,21 +618,22 @@ let e_change_in_concl (redfun,sty) = Sigma.Unsafe.of_pair (convert_concl_no_check c sty, sigma) end } -let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma = - match c with - | None -> +let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); let sigma',ty' = redfun false env sigma ty in - sigma', (id,None,ty') - | Some b -> + sigma', LocalAssum (id,ty') + | LocalDef (id,b,ty) -> let sigma',b' = if where != InHypTypeOnly then redfun true env sigma b else sigma, b in let sigma',ty' = if where != InHypValueOnly then redfun false env sigma' ty else sigma', ty in - sigma', (id,Some b',ty') + sigma', LocalDef (id,b',ty') let e_change_in_hyp redfun (id,where) = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -767,10 +777,9 @@ let unfold_constr = function let find_intro_names ctxt gl = let _, res = List.fold_right (fun decl acc -> - let wantedname,x,typdecl = decl in let env,idl = acc in let name = fresh_id idl (default_id env gl.sigma decl) gl in - let newenv = push_rel (wantedname,x,typdecl) env in + let newenv = push_rel decl env in (newenv,(name::idl))) ctxt (pf_env gl , []) in List.rev res @@ -782,15 +791,16 @@ let build_intro_tac id dest tac = match dest with Proofview.V82.tactic (move_hyp id dest); tac id] let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = + let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let concl = nf_evar (Tacmach.New.project gl) concl in match kind_of_term concl with | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) -> - let name = find_name false (name,None,t) name_flag gl in + let name = find_name false (LocalAssum (name,t)) name_flag gl in build_intro_tac name move_flag tac | LetIn (name,b,t,u) when not dep_flag || (dependent (mkRel 1) u) -> - let name = find_name false (name,Some b,t) name_flag gl in + let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct) @@ -853,21 +863,24 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = aux n [] let get_next_hyp_position id gl = + let open Context.Named.Declaration in let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) - | (hyp,_,_) :: right -> - if Id.equal hyp id then - match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveLast + | decl :: right -> + if Id.equal (get_id decl) id then + match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast else aux right in aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let get_previous_hyp_position id gl = + let open Context.Named.Declaration in let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) - | (hyp,_,_) :: right -> - if Id.equal hyp id then dest else aux (MoveAfter hyp) right + | decl :: right -> + let hyp = get_id decl in + if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) @@ -1146,6 +1159,7 @@ let index_of_ind_arg t = in aux None 0 t let enforce_prop_bound_names rename tac = + let open Context.Rel.Declaration in match rename with | Some (isrec,nn) when Namegen.use_h_based_elimination_names () -> (* Rename dependent arguments in Prop with name "H" *) @@ -1165,11 +1179,11 @@ let enforce_prop_bound_names rename tac = Name (add_suffix Namegen.default_prop_ident s) else na in - mkProd (na,t,aux (push_rel (na,None,t) env) sigma (i-1) t') + mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t') | Prod (Anonymous,t,t') -> - mkProd (Anonymous,t,aux (push_rel (Anonymous,None,t) env) sigma (i-1) t') + mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> - mkLetIn (na,c,t,aux (push_rel (na,Some c,t) env) sigma (i-1) t') + mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> print_int i; Pp.msg (print_constr t); assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> @@ -1391,11 +1405,13 @@ type conjunction_status = | NotADefinedRecordUseScheme of constr let make_projection env sigma params cstr sign elim i n c u = + let open Context.Rel.Declaration in let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) - let (na,b,t) = List.nth cstr.cs_args i in - let b = match b with None -> mkRel (i+1) | Some b -> b in + let decl = List.nth cstr.cs_args i in + let t = get_type decl in + let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if (* excludes dependent projection types *) @@ -1651,6 +1667,7 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) = let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = + let open Context.Rel.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1658,7 +1675,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming if with_delta then default_unify_flags () else default_no_delta_unify_flags () in let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in - let targetid = find_name true (Anonymous,None,t') naming gl in + let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1770,13 +1787,15 @@ let exact_proof c gl = in tclTHEN (tclEVARUNIVCONTEXT ctx) (Tacmach.refine_no_check c) gl let assumption = + let open Context.Named.Declaration in let rec arec gl only_eq = function | [] -> if only_eq then let hyps = Proofview.Goal.hyps gl in arec gl false hyps else Tacticals.New.tclZEROMSG (str "No such assumption.") - | (id, c, t)::rest -> + | decl::rest -> + let t = get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = @@ -1787,7 +1806,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar id) h } + Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar (get_id decl)) h } else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -1822,40 +1841,43 @@ let check_is_type env ty msg = with e when Errors.noncritical e -> msg e -let check_decl env (_, c, ty) msg = +let check_decl env decl msg = + let open Context.Named.Declaration in + let ty = get_type decl in Proofview.tclEVARMAP >>= fun sigma -> let evdref = ref sigma in try let _ = Typing.sort_of env evdref ty in - let _ = match c with - | None -> () - | Some c -> Typing.check env evdref c ty + let _ = match decl with + | LocalAssum _ -> () + | LocalDef (_,c,_) -> Typing.check env evdref c ty in Proofview.Unsafe.tclEVARS !evdref with e when Errors.noncritical e -> msg e let clear_body ids = + let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let ctx = named_context env in - let map (id, body, t as decl) = match body with - | None -> + let map = function + | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl - | Some _ -> - if List.mem_f Id.equal id ids then (id, None, t) else decl + | LocalDef (id,_,t) as decl -> + if List.mem_f Id.equal id ids then LocalAssum (id, t) else decl in let ctx = List.map map ctx in let base_env = reset_context env in let env = push_named_context ctx base_env in let check_hyps = - let check env (id, _, _ as decl) = + let check env decl = let msg _ = Tacticals.New.tclZEROMSG - (str "Hypothesis " ++ pr_id id ++ on_the_bodies ids) + (str "Hypothesis " ++ pr_id (get_id decl) ++ on_the_bodies ids) in check_decl env decl msg <*> Proofview.tclUNIT (push_named decl env) in @@ -1897,11 +1919,13 @@ let rec intros_clearing = function (* Keeping only a few hypotheses *) let keep hyps = + let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = - fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> + fold_named_context_reverse (fun (clear,keep) decl -> + let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env hyp) keep || occur_var env hyp ccl @@ -2442,20 +2466,24 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = end } let insert_before decls lasthyp env = + let open Context.Named.Declaration in match lasthyp with | None -> push_named_context decls env | Some id -> Environ.fold_named_context - (fun _ (id',_,_ as d) env -> - let env = if Id.equal id id' then push_named_context decls env else env in + (fun _ d env -> + let env = if Id.equal id (get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env (* unsafe *) let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = - let body = if dep then Some c else None in + let open Context.Named.Declaration in let t = match ty with Some t -> t | _ -> typ_of env sigma c in + let decl = if dep then LocalDef (id,c,t) + else LocalAssum (id,t) + in match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with @@ -2471,11 +2499,11 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let newenv = insert_before [heq,None,eq;id,body,t] lastlhyp env in + let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> - let newenv = insert_before [id,body,t] lastlhyp env in + let newenv = insert_before [decl] lastlhyp env in let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t x, sigma, p) @@ -2557,12 +2585,17 @@ let generalized_name c t ids cl = function but only those at [occs] in [T] *) let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = + let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t ids cl' na in - mkProd_or_LetIn (na,b,t) cl', sigma' + let decl = match b with + | None -> LocalAssum (na,t) + | Some b -> LocalDef (na,b,t) + in + mkProd_or_LetIn decl cl', sigma' let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let env = Tacmach.pf_env gl in @@ -2571,18 +2604,19 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = generalize_goal_gen env sigma ids i o t cl let generalize_dep ?(with_let=false) c gl = + let open Context.Named.Declaration in let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in - let seek d toquant = - if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant + let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = + if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant || dependent_in_decl c d then d::toquant else toquant in let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in - let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in + let qhyps = List.map get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with @@ -2594,7 +2628,7 @@ let generalize_dep ?(with_let=false) c gl = let body = if with_let then match kind_of_term c with - | Var id -> pi2 (Tacmach.pf_get_hyp gl id) + | Var id -> Tacmach.pf_get_hyp gl id |> get_value | _ -> None else None in @@ -2720,14 +2754,15 @@ let specialize (c,lbind) = (* The two following functions should already exist, but found nowhere *) (* Unfolds x by its definition everywhere *) let unfold_body x gl = + let open Context.Named.Declaration in let hyps = pf_hyps gl in let xval = match Context.Named.lookup x hyps with - (_,Some xval,_) -> xval + | LocalDef (_,xval,_) -> xval | _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") in let aft = afterHyp x gl in - let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in + let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in tclTHENLIST @@ -3041,6 +3076,7 @@ exception Shunt of Id.t move_location let cook_sign hyp0_opt inhyps indvars env = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) + let open Context.Named.Declaration in let toclear = ref [] in let avoid = ref [] in let decldeps = ref [] in @@ -3049,7 +3085,8 @@ let cook_sign hyp0_opt inhyps indvars env = let lstatus = ref [] in let before = ref true in let maindep = ref false in - let seek_deps env (hyp,_,_ as decl) rhyp = + let seek_deps env decl rhyp = + let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin before:=false; @@ -3068,7 +3105,7 @@ let cook_sign hyp0_opt inhyps indvars env = in let depother = List.is_empty inhyps && (List.exists (fun id -> occur_var_in_decl env id decl) indvars || - List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps) + List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother @@ -3090,7 +3127,8 @@ let cook_sign hyp0_opt inhyps indvars env = in let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) - let compute_lstatus lhyp (hyp,_,_) = + let compute_lstatus lhyp decl = + let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then raise (Shunt lhyp); if Id.List.mem hyp !ldeps then begin @@ -3280,6 +3318,7 @@ let mk_term_eq env sigma ty t ty' t' = mkHEq ty t ty' t', mkHRefl ty' t' let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = + let open Context.Rel.Declaration in Proofview.Refine.refine { run = begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) @@ -3291,9 +3330,13 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) - let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in + let decl = match body with + | None -> LocalAssum (Name id, c) + | Some body -> LocalDef (Name id, body, c) + in (* Abstract by the "generalized" hypothesis. *) - let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in + let genarg = mkProd_or_LetIn decl abseqs in (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) @@ -3309,11 +3352,13 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = end } let hyps_of_vars env sign nogen hyps = + let open Context.Named.Declaration in if Id.Set.is_empty hyps then [] else let (_,lh) = Context.Named.fold_inside - (fun (hs,hl) (x,_,_ as d) -> + (fun (hs,hl) d -> + let x = get_id d in if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else @@ -3342,11 +3387,12 @@ let linear vars args = true with Seen -> false -let is_defined_variable env id = match lookup_named id env with -| (_, None, _) -> false -| (_, Some _, _) -> true +let is_defined_variable env id = + let open Context.Named.Declaration in + lookup_named id env |> is_local_def let abstract_args gl generalize_vars dep id defined f args = + let open Context.Rel.Declaration in let sigma = ref (Tacmach.project gl) in let env = Tacmach.pf_env gl in let concl = Tacmach.pf_concl gl in @@ -3363,9 +3409,10 @@ let abstract_args gl generalize_vars dep id defined f args = eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = - let (name, _, ty), arity = + let name, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in - List.hd rel, c + let decl = List.hd rel in + get_name decl, get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in @@ -3379,7 +3426,7 @@ let abstract_args gl generalize_vars dep id defined f args = Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in - let decl = (Name name, None, ty) in + let decl = LocalAssum (Name name, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in @@ -3430,15 +3477,15 @@ let abstract_args gl generalize_vars dep id defined f args = else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = + let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in - let (_, b, t) = Tacmach.New.pf_get_hyp id gl in - match b with - | None -> let f, args = decompose_app t in + match Tacmach.New.pf_get_hyp id gl with + | LocalAssum (_,t) -> let f, args = decompose_app t in (f, args, false, id, oldid) - | Some t -> + | LocalDef (_,t,_) -> let f, args = decompose_app t in (f, args, true, id, oldid) in @@ -3473,6 +3520,7 @@ let rec compare_upto_variables x y = else compare_constr compare_upto_variables x y let specialize_eqs id gl = + let open Context.Rel.Declaration in let env = Tacmach.pf_env gl in let ty = Tacmach.pf_get_hyp_typ gl id in let evars = ref (project gl) in @@ -3501,15 +3549,14 @@ let specialize_eqs id gl = if in_eqs then acc, in_eqs, ctx, ty else let e = e_new_evar (push_rel_context ctx env) evars t in - aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in - let ctx'' = List.map (fun (n,b,t as decl) -> - match b with - | Some k when isEvar k -> (n,None,t) - | b -> decl) ctx' + let ctx'' = List.map (function + | LocalDef (n,k,t) when isEvar k -> LocalAssum (n,t) + | decl -> decl) ctx' in let ty' = it_mkProd_or_LetIn ty ctx'' in let acc' = it_mkLambda_or_LetIn acc ctx'' in @@ -3543,18 +3590,19 @@ let occur_rel n c = We also return the conclusion. *) let decompose_paramspred_branch_args elimt = - let rec cut_noccur elimt acc2 : Context.Rel.t * Context.Rel.t * types = + let open Context.Rel.Declaration in + let rec cut_noccur elimt acc2 = match kind_of_term elimt with | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in if not (occur_rel 1 elimt') && isRel hd_tpe - then cut_noccur elimt' ((nme,None,tpe)::acc2) + then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in - let rec cut_occur elimt acc1 : Context.Rel.t * Context.Rel.t * Context.Rel.t * types = + let rec cut_occur elimt acc1 = match kind_of_term elimt with - | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c ((nme,None,tpe)::acc1) + | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl | App(_, _) | Rel _ -> acc1,[],[],elimt | _ -> error_ind_scheme "" in @@ -3596,6 +3644,7 @@ let exchange_hd_app subst_hd t = - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) let compute_elim_sig ?elimc elimt = + let open Context.Rel.Declaration in let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in @@ -3629,8 +3678,8 @@ let compute_elim_sig ?elimc elimt = (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with - | hiname,Some _,hi -> error_ind_scheme "" - | hiname,None,hi -> + | LocalDef (hiname,_,hi) -> error_ind_scheme "" + | LocalAssum (hiname,hi) -> let hi_ind, hi_args = decompose_app hi in let hi_is_ind = (* hi est d'un type globalisable *) match kind_of_term hi_ind with @@ -3654,24 +3703,25 @@ let compute_elim_sig ?elimc elimt = with Exit -> (* Ending by computing indref: *) match !res.indarg with | None -> !res (* No indref *) - | Some ( _,Some _,_) -> error_ind_scheme "" - | Some ( _,None,ind) -> + | Some (LocalDef _) -> error_ind_scheme "" + | Some (LocalAssum (_,ind)) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } with e when Errors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature scheme names_info ind_type_guess = + let open Context.Rel.Declaration in let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) let cond, check_concl = match scheme.indarg with - | Some (_,Some _,_) -> + | Some (LocalDef _) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) let cond hd = Term.eq_constr hd ind_type_guess && not scheme.farg_in_concl in (cond, fun _ _ -> ()) - | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) + | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in let cond hd = Term.eq_constr hd indhd in let check_concl is_pred p = @@ -3703,7 +3753,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = in let rec find_branches p lbrch = match lbrch with - | (_,None,t)::brs -> + | LocalAssum (_,t) :: brs -> (try let lchck_brch = check_branch p t in let n = List.fold_left @@ -3716,7 +3766,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit-> error_ind_scheme "the branches of") - | (_,Some _,_)::_ -> error_ind_scheme "the branches of" + | LocalDef _ :: _ -> error_ind_scheme "the branches of" | [] -> check_concl is_pred p; [] in Array.of_list (find_branches 0 (List.rev scheme.branches)) @@ -3797,13 +3847,15 @@ let is_functional_induction elimc gl = (* Wait the last moment to guess the eliminator so as to know if we need a dependent one or not *) -let get_eliminator elim dep s gl = match elim with +let get_eliminator elim dep s gl = + let open Context.Rel.Declaration in + match elim with | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun (_,b,c) -> assert (b=None); pi1 (decompose_prod_letin c)) (List.rev s.branches) in + let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (List.rev s.branches) in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts @@ -3864,6 +3916,7 @@ let induction_tac with_evars params indvars elim gl = induction applies with the induction hypotheses *) let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = + let open Context.Named.Declaration in Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -3876,7 +3929,7 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left - (fun a (id,b,_) -> if Option.is_empty b then (mkVar id)::a else a) [] deps in + (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in @@ -3956,6 +4009,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls gl = + let open Context.Named.Declaration in if occur_var (Tacmach.pf_env gl) id (Tacmach.pf_concl gl) && cls.concl_occs == NoOccurrences then errorlabstrm "" @@ -3963,7 +4017,8 @@ let clear_unselected_context id inhyps cls gl = ++ str "."); match cls.onhyps with | Some hyps -> - let to_erase (id',_,_ as d) = + let to_erase d = + let id' = get_id d in if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) @@ -4536,39 +4591,45 @@ let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) is solved by tac *) (** d1 is the section variable in the global context, d2 in the goal context *) -let interpretable_as_section_decl evd d1 d2 = match d2,d1 with - | (_,Some _,_), (_,None,_) -> false - | (_,Some b1,t1), (_,Some b2,t2) -> +let interpretable_as_section_decl evd d1 d2 = + let open Context.Named.Declaration in + match d2, d1 with + | LocalDef _, LocalAssum _ -> false + | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 - | (_,None,t1), (_,_,t2) -> e_eq_constr_univs evd t1 t2 + | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2) let rec decompose len c t accu = + let open Context.Rel.Declaration in if len = 0 then (c, t, accu) else match kind_of_term c, kind_of_term t with | Lambda (na, u, c), Prod (_, _, t) -> - decompose (pred len) c t ((na, None, u) :: accu) + decompose (pred len) c t (LocalAssum (na, u) :: accu) | LetIn (na, b, u, c), LetIn (_, _, _, t) -> - decompose (pred len) c t ((na, Some b, u) :: accu) + decompose (pred len) c t (LocalDef (na, b, u) :: accu) | _ -> assert false -let rec shrink ctx sign c t accu = match ctx, sign with -| [], [] -> (c, t, accu) -| p :: ctx, (id, _, _) :: sign -> - if noccurn 1 c then - let c = subst1 mkProp c in - let t = subst1 mkProp t in - shrink ctx sign c t accu - else - let c = mkLambda_or_LetIn p c in - let t = mkProd_or_LetIn p t in - let accu = match p with - | (_, None, _) -> mkVar id :: accu - | (_, Some _, _) -> accu +let rec shrink ctx sign c t accu = + let open Context.Rel.Declaration in + match ctx, sign with + | [], [] -> (c, t, accu) + | p :: ctx, decl :: sign -> + if noccurn 1 c then + let c = subst1 mkProp c in + let t = subst1 mkProp t in + shrink ctx sign c t accu + else + let c = mkLambda_or_LetIn p c in + let t = mkProd_or_LetIn p t in + let accu = if is_local_assum p then let open Context.Named.Declaration in + mkVar (get_id decl) :: accu + else accu in shrink ctx sign c t accu | _ -> assert false let shrink_entry sign const = + let open Context.Named.Declaration in let open Entries in let typ = match const.const_entry_type with | None -> assert false @@ -4589,6 +4650,7 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in + let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context() @@ -4597,7 +4659,8 @@ let abstract_subproof id gk tac = let evdref = ref sigma in let sign,secsign = List.fold_right - (fun (id,_,_ as d) (s1,s2) -> + (fun d (s1,s2) -> + let id = get_id d in if mem_named_context id current_sign && interpretable_as_section_decl evdref (Context.Named.lookup id current_sign) d then (s1,push_named_context_val d s2) diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index cddc55515f..b29ceb78bd 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -23,6 +23,7 @@ open Declarations open Mod_subst open Globnames open Printer +open Context.Named.Declaration (** For a constant c in a module sealed by an interface (M:T and not M<:T), [Global.lookup_constant] may return a [constant_body] @@ -145,7 +146,7 @@ let push (r : Context.Rel.Declaration.t) (ctx : Context.Rel.t) = r :: ctx let rec traverse current ctx accu t = match kind_of_term t with | Var id -> - let body () = match Global.lookup_named id with (_, body, _) -> body in + let body () = Global.lookup_named id |> get_value in traverse_object accu body (VarRef id) | Const (kn, _) -> let body () = Global.body_of_constant_body (lookup_constant kn) in @@ -208,8 +209,8 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let (_, graph, ax2ty) = traverse (label_of gr) t in let fold obj _ accu = match obj with | VarRef id -> - let (_, body, t) = Global.lookup_named id in - if Option.is_empty body then ContextObjectMap.add (Variable id) t accu + let decl = Global.lookup_named id in + if is_local_assum decl then ContextObjectMap.add (Variable id) t accu else accu | ConstRef kn -> let cb = lookup_constant kn in diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index f0c7a39613..0755f8bcfd 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -25,6 +25,7 @@ open Tactics open Ind_tables open Misctypes open Proofview.Notations +open Context.Rel.Declaration let out_punivs = Univ.out_punivs @@ -146,17 +147,17 @@ let build_beq_scheme mode kn = ) ext_rel_list in let eq_input = List.fold_left2 - ( fun a b (n,_,_) -> (* mkLambda(n,b,a) ) *) + ( fun a b decl -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName n) b a ) + mkNamedLambda (eqName (get_name decl)) b a ) c (List.rev eqs_typ) lnamesparrec in - List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *) + List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) (* Same here , hoping the auto renaming will do something good ;) *) mkNamedLambda - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let make_one_eq cur = let u = Univ.Instance.empty in @@ -248,7 +249,7 @@ let build_beq_scheme mode kn = | 0 -> Lazy.force tt | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in for ndx = 0 to nb_cstr_args-1 do - let _,_,cc = List.nth constrsi.(i).cs_args ndx in + let cc = get_type (List.nth constrsi.(i).cs_args ndx) in let eqA, eff' = compute_A_equality rel_list nparrec (nparrec+3+2*nb_cstr_args) @@ -267,14 +268,14 @@ let build_beq_scheme mode kn = (Array.sub eqs 1 (nb_cstr_args - 1)) ) in - (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) cc + (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) cc (constrsj.(j).cs_args) ) - else ar2.(j) <- (List.fold_left (fun a (p,q,r) -> - mkLambda (p,r,a)) (Lazy.force ff) (constrsj.(j).cs_args) ) + else ar2.(j) <- (List.fold_left (fun a decl -> + mkLambda (get_name decl, get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) done; - ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) + ar.(i) <- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) @@ -487,8 +488,8 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = create, from a list of ids [i1,i2,...,in] the list [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )] *) -let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = - match n with +let list_id l = List.fold_left ( fun a decl -> let s' = + match get_name decl with Name s -> Id.to_string s | Anonymous -> "A" in (Id.of_string s',Id.of_string ("eq_"^s'), @@ -535,9 +536,9 @@ let compute_bl_goal ind lnamesparrec nparrec = let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + List.fold_left (fun a decl -> mkNamedProd + (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in @@ -678,9 +679,9 @@ let compute_lb_goal ind lnamesparrec nparrec = let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + List.fold_left (fun a decl -> mkNamedProd + (match (get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in @@ -819,9 +820,9 @@ let compute_dec_goal ind lnamesparrec nparrec = let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + List.fold_left (fun a decl -> mkNamedProd + (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 6bb047af0d..2089bc9443 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -21,6 +21,7 @@ open Globnames open Constrintern open Constrexpr open Sigma.Notations +open Context.Rel.Declaration (*i*) open Decl_kinds @@ -75,14 +76,14 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m let type_ctx_instance evars env ctx inst subst = let rec aux (subst, instctx) l = function - (na, b, t) :: ctx -> - let t' = substl subst t in + decl :: ctx -> + let t' = substl subst (get_type decl) in let c', l = - match b with - | None -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l - | Some b -> substl subst b, l + match decl with + | LocalAssum _ -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l + | LocalDef (_,b,_) -> substl subst b, l in - let d = na, Some c', t' in + let d = get_name decl, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst in aux (subst, []) inst (List.rev ctx) @@ -131,7 +132,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro match bk with | Implicit -> Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false - (fun avoid (clname, (id, _, t)) -> + (fun avoid (clname, _) -> match clname with | Some (cl, b) -> let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in @@ -154,10 +155,11 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let k, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in let cl, u = Typeclasses.typeclass_univ_instance k in let _, args = - List.fold_right (fun (na, b, t) (args, args') -> - match b with - | None -> (List.tl args, List.hd args :: args') - | Some b -> (args, substl args' b :: args')) + List.fold_right (fun decl (args, args') -> + let open Context.Rel.Declaration in + match decl with + | LocalAssum _ -> (List.tl args, List.hd args :: args') + | LocalDef (_,b,_) -> (args, substl args' b :: args')) (snd cl.cl_context) (args, []) in cl, u, c', ctx', ctx, len, imps, args @@ -180,7 +182,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro if abstract then begin let subst = List.fold_left2 - (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') + (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (snd k.cl_context) in let (_, ty_constr) = instance_constructor (k,u) subst in @@ -224,10 +226,10 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro in let props, rest = List.fold_left - (fun (props, rest) (id,b,_) -> - if Option.is_empty b then + (fun (props, rest) decl -> + if is_local_assum decl then try - let is_id (id', _) = match id, get_id id' with + let is_id (id', _) = match get_name decl, get_id id' with | Name id, (_, id') -> Id.equal id id' | Anonymous, _ -> false in @@ -261,7 +263,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro None, termtype | Some (Inl subst) -> let subst = List.fold_left2 - (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') + (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in let (app, ty_constr) = instance_constructor (k,u) subst in @@ -344,9 +346,11 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let named_of_rel_context l = let acc, ctx = List.fold_right - (fun (na, b, t) (subst, ctx) -> - let id = match na with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in - let d = (id, Option.map (substl subst) b, substl subst t) in + (fun decl (subst, ctx) -> + let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in + let d = match decl with + | LocalAssum (_,t) -> id, None, substl subst t + | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in (mkVar id :: subst, d :: ctx)) l ([], []) in ctx @@ -358,7 +362,7 @@ let context poly l = let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in let fullctx = Context.Rel.map subst fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in - let () = List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx in + let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in let ctx = try named_of_rel_context fullctx with e when Errors.noncritical e -> diff --git a/toplevel/command.ml b/toplevel/command.ml index 18b2b1444d..02f29b155f 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -36,6 +36,7 @@ open Evarconv open Indschemes open Misctypes open Vernacexpr +open Context.Rel.Declaration let do_universe poly l = Declare.do_universe poly l let do_constraint poly l = Declare.do_constraint poly l @@ -44,9 +45,9 @@ let rec under_binders env sigma f n c = if Int.equal n 0 then snd (f env sigma c) else match kind_of_term c with | Lambda (x,t,c) -> - mkLambda (x,t,under_binders (push_rel (x,None,t) env) sigma f (n-1) c) + mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c) | LetIn (x,b,t,c) -> - mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) sigma f (n-1) c) + mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c) | _ -> assert false let rec complete_conclusion a cs = function @@ -259,6 +260,7 @@ let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl = List.rev refs, status let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = + let open Context.Named.Declaration in let env = Global.env () in let evdref = ref (Evd.from_env env) in let l = @@ -273,7 +275,7 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> let (t,ctx),imps = interp_assumption evdref env ienv [] c in let env = - push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in + push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in let ienv = List.fold_right (fun (_,id) ienv -> let impls = compute_internalization_data env Variable t imps in Id.Map.add id impls ienv) idl ienv in @@ -335,7 +337,7 @@ let do_assumptions kind nl l = match l with (* 3b| Mutual inductive definitions *) let push_types env idl tl = - List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env) + List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) env idl tl type structured_one_inductive_expr = { @@ -378,8 +380,8 @@ let mk_mltype_data evdref env assums arity indname = (is_ml_type,indname,assums) let prepare_param = function - | (na,None,t) -> out_name na, LocalAssum t - | (na,Some b,_) -> out_name na, LocalDef b + | LocalAssum (na,t) -> out_name na, Entries.LocalAssum t + | LocalDef (na,b,_) -> out_name na, Entries.LocalDef b (** Make the arity conclusion flexible to avoid generating an upper bound universe now, only if the universe does not appear anywhere else. @@ -433,12 +435,12 @@ let interp_cstrs evdref env impls mldata arity ind = let sign_level env evd sign = fst (List.fold_right - (fun (_,b,t as d) (lev,env) -> - match b with - | Some _ -> (lev, push_rel d env) - | None -> + (fun d (lev,env) -> + match d with + | LocalDef _ -> lev, push_rel d env + | LocalAssum _ -> let s = destSort (Reduction.whd_betadeltaiota env - (nf_evar evd (Retyping.get_type_of env evd t))) + (nf_evar evd (Retyping.get_type_of env evd (get_type d)))) in let u = univ_of_sort s in (Univ.sup u lev, push_rel d env)) @@ -449,7 +451,7 @@ let sup_list min = List.fold_left Univ.sup min let extract_level env evd min tys = let sorts = List.map (fun ty -> let ctx, concl = Reduction.dest_prod_assum env ty in - sign_level env evd ((Anonymous, None, concl) :: ctx)) tys + sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys in sup_list min sorts let is_flexible_sort evd u = @@ -555,8 +557,8 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let indnames = List.map (fun ind -> ind.ind_name) indl in (* Names of parameters as arguments of the inductive type (defs removed) *) - let assums = List.filter(fun (_,b,_) -> Option.is_empty b) ctx_params in - let params = List.map (fun (na,_,_) -> out_name na) assums in + let assums = List.filter is_local_assum ctx_params in + let params = List.map (fun decl -> out_name (get_name decl)) assums in (* Interpret the arities *) let arities = List.map (interp_ind_arity env_params evdref) indl in @@ -876,12 +878,13 @@ let lt_ref = make_qref "Init.Peano.lt" let rec telescope = function | [] -> assert false - | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1 - | (n, None, t) :: tl -> + | [LocalAssum (n, t)] -> t, [LocalDef (n, mkRel 1, t)], mkRel 1 + | LocalAssum (n, t) :: tl -> let ty, tys, (k, constr) = List.fold_left - (fun (ty, tys, (k, constr)) (n, b, t) -> - let pred = mkLambda (n, t, ty) in + (fun (ty, tys, (k, constr)) decl -> + let t = get_type decl in + let pred = mkLambda (get_name decl, t, ty) in let ty = Universes.constr_of_global (Lazy.force sigT).typ in let intro = Universes.constr_of_global (Lazy.force sigT).intro in let sigty = mkApp (ty, [|t; pred|]) in @@ -890,21 +893,21 @@ let rec telescope = function (t, [], (2, mkRel 1)) tl in let (last, subst) = List.fold_right2 - (fun pred (n, b, t) (prev, subst) -> + (fun pred decl (prev, subst) -> + let t = get_type decl in let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in let proj1 = applistc p1 [t; pred; prev] in let proj2 = applistc p2 [t; pred; prev] in - (lift 1 proj2, (n, Some proj1, t) :: subst)) + (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) - in ty, ((n, Some last, t) :: subst), constr + in ty, (LocalDef (n, last, t) :: subst), constr - | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in - ty, ((n, Some b, t) :: subst), lift 1 term + | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in + ty, (LocalDef (n, b, t) :: subst), lift 1 term let nf_evar_context sigma ctx = - List.map (fun (n, b, t) -> - (n, Option.map (Evarutil.nf_evar sigma) b, Evarutil.nf_evar sigma t)) ctx + List.map (map_constr (Evarutil.nf_evar sigma)) ctx let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = Coqlib.check_required_library ["Coq";"Program";"Wf"]; @@ -918,7 +921,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let full_arity = it_mkProd_or_LetIn top_arity binders_rel in let argtyp, letbinders, make = telescope binders_rel in let argname = Id.of_string "recarg" in - let arg = (Name argname, None, argtyp) in + let arg = LocalAssum (Name argname, argtyp) in let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in let rel, _ = interp_constr_evars_impls env evdref r in @@ -933,7 +936,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = try let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in match ctx, kind_of_term ar with - | [(_, None, t); (_, None, u)], Sort (Prop Null) + | [LocalAssum (_,t); LocalAssum (_,u)], Sort (Prop Null) when Reductionops.is_conv env !evdref t u -> t | _, _ -> error () with e when Errors.noncritical e -> error () @@ -953,9 +956,9 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in let argid' = Id.of_string (Id.to_string argname ^ "'") in - let wfarg len = (Name argid', None, - mkSubset (Name argid') argtyp - (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) + let wfarg len = LocalAssum (Name argid', + mkSubset (Name argid') argtyp + (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in @@ -969,22 +972,22 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = (* substitute the projection of wfarg for something, now intern_arity is in wfarg :: arg *) let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in - let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in + let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in let intro = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro in let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in - let lam = (Name (Id.of_string "recproof"), None, rcurry) in + let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in - (Name recname, Some body, ty) + LocalDef (Name recname, body, ty) in let fun_bl = intern_fun_binder :: [arg] in let lift_lets = Termops.lift_rel_context 1 letbinders in let intern_body = - let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in + let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in let (r, l, impls, scopes) = Constrintern.compute_internalization_data env Constrintern.Recursive full_arity impls @@ -1046,6 +1049,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = + let open Context.Named.Declaration in let env = Global.env() in let fixnames = List.map (fun fix -> fix.fix_name) fixl in @@ -1081,8 +1085,8 @@ let interp_recursive isfix fixl notations = Typing.solve_evars env evdref app with e when Errors.noncritical e -> t in - (id,None,fixprot) :: env' - else (id,None,t) :: env') + LocalAssum (id,fixprot) :: env' + else LocalAssum (id,t) :: env') [] fixnames fixtypes in let env_rec = push_named_context rec_sign env in @@ -1104,7 +1108,7 @@ let interp_recursive isfix fixl notations = let evd, nf = nf_evars_and_universes evd in let fixdefs = List.map (Option.map nf) fixdefs in let fixtypes = List.map nf fixtypes in - let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in + let fixctxnames = List.map (fun (_,ctx) -> List.map get_name ctx) fixctxs in (* Build the fix declaration block *) (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 61a6e10948..5fa51e06e4 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -14,14 +14,16 @@ open Vars open Entries open Declarations open Cooking +open Context.Rel.Declaration (********************************) (* Discharging mutual inductive *) -let detype_param = function - | (Name id,None,p) -> id, LocalAssum p - | (Name id,Some p,_) -> id, LocalDef p - | (Anonymous,_,_) -> anomaly (Pp.str "Unnamed inductive local variable") +let detype_param = + function + | LocalAssum (Name id, p) -> id, Entries.LocalAssum p + | LocalDef (Name id, p,_) -> id, Entries.LocalDef p + | _ -> anomaly (Pp.str "Unnamed inductive local variable") (* Replace @@ -52,7 +54,7 @@ let abstract_inductive hyps nparams inds = (* To be sure to be the same as before, should probably be moved to process_inductive *) let params' = let (_,arity,_,_,_) = List.hd inds' in let (params,_) = decompose_prod_n_assum nparams' arity in - List.map detype_param params + List.map detype_param params in let ind'' = List.map diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 4a5f14917f..4a145481f7 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -23,22 +23,26 @@ open Cases open Logic open Printer open Evd +open Context.Rel.Declaration (* This simplifies the typing context of Cases clauses *) (* hope it does not disturb other typing contexts *) let contract env lc = let l = ref [] in - let contract_context (na,c,t) env = - match c with - | Some c' when isRel c' -> + let contract_context decl env = + match decl with + | LocalDef (_,c',_) when isRel c' -> l := (Vars.substl !l c') :: !l; env | _ -> - let t' = Vars.substl !l t in - let c' = Option.map (Vars.substl !l) c in - let na' = named_hd env t' na in + let t' = Vars.substl !l (get_type decl) in + let c' = Option.map (Vars.substl !l) (get_value decl) in + let na' = named_hd env t' (get_name decl) in l := (mkRel 1) :: List.map (Vars.lift 1) !l; - push_rel (na',c',t') env in + match c' with + | None -> push_rel (LocalAssum (na',t')) env + | Some c' -> push_rel (LocalDef (na',c',t')) env + in let env = process_rel_context contract_context env in (env, List.map (Vars.substl !l) lc) @@ -136,9 +140,9 @@ let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags let pr_db env i = try - match lookup_rel i env with - Name id, _, _ -> pr_id id - | Anonymous, _, _ -> str "<>" + match lookup_rel i env |> get_name with + | Name id -> pr_id id + | Anonymous -> str "<>" with Not_found -> str "UNBOUND_REL_" ++ int i let explain_unbound_rel env sigma n = diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index c4ac0e4112..251d14af79 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -38,6 +38,7 @@ open Ind_tables open Auto_ind_decl open Eqschemes open Elimschemes +open Context.Rel.Declaration (* Flags governing automatic synthesis of schemes *) @@ -463,7 +464,7 @@ let build_combined_scheme env schemes = in let ctx, _ = list_split_rev_at prods - (List.rev_map (fun (x, y) -> x, None, y) ctx) in + (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in let typ = it_mkProd_wo_LetIn concl_typ ctx in let body = it_mkLambda_or_LetIn concl_bod ctx in (body, typ) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 0ea9f959f6..0e8d224e42 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -54,7 +54,8 @@ type oblinfo = (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) -let subst_evar_constr evs n idf t = +let subst_evar_constr evs n idf t = + let open Context.Named.Declaration in let seen = ref Int.Set.empty in let transparent = ref Id.Set.empty in let evar_info id = List.assoc_f Evar.equal id evs in @@ -78,9 +79,9 @@ let subst_evar_constr evs n idf t = let args = let rec aux hyps args acc = match hyps, args with - ((_, None, _) :: tlh), (c :: tla) -> + (LocalAssum _ :: tlh), (c :: tla) -> aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | ((_, Some _, _) :: tlh), (_ :: tla) -> + | (LocalDef _ :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) @@ -116,22 +117,23 @@ let subst_vars acc n t = Changes evars and hypothesis references to variable references. *) let etype_of_evar evs hyps concl = + let open Context.Named.Declaration in let rec aux acc n = function - (id, copt, t) :: tl -> - let t', s, trans = subst_evar_constr evs n mkVar t in + decl :: tl -> + let t', s, trans = subst_evar_constr evs n mkVar (get_type decl) in let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (id :: acc) (succ n) tl in + let rest, s', trans' = aux (get_id decl :: acc) (succ n) tl in let s' = Int.Set.union s s' in let trans' = Id.Set.union trans trans' in - (match copt with - Some c -> + (match decl with + | LocalDef (id,c,_) -> let c', s'', trans'' = subst_evar_constr evs n mkVar c in let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (id, Some c', t'') rest, + mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, Int.Set.union s'' s', Id.Set.union trans'' trans' - | None -> - mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') + | LocalAssum (id,_) -> + mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evs n mkVar concl in subst_vars acc 0 t', s, trans @@ -589,15 +591,16 @@ let declare_mutual_definition l = Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx; List.iter progmap_remove l; kn -let shrink_body c = +let shrink_body c = + let open Context.Rel.Declaration in let ctx, b = decompose_lam_assum c in let b', n, args = - List.fold_left (fun (b, i, args) (n, u, t) -> + List.fold_left (fun (b, i, args) decl -> if noccurn 1 b then subst1 mkProp b, succ i, args else - let args = if Option.is_empty u then mkRel i :: args else args in - mkLambda_or_LetIn (n, u, t) b, succ i, args) + let args = if is_local_assum decl then mkRel i :: args else args in + mkLambda_or_LetIn decl b, succ i, args) (b, 1, []) ctx in ctx, b', Array.of_list args diff --git a/toplevel/record.ml b/toplevel/record.ml index 7ae2030343..facc8b75d5 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -24,6 +24,7 @@ open Type_errors open Constrexpr open Constrexpr_ops open Goptions +open Context.Rel.Declaration (********** definition d'un record (structure) **************) @@ -68,16 +69,19 @@ let interp_fields_evars env evars impls_env nots l = | Anonymous -> impls | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls in - let d = (i,b',t') in + let d = match b' with + | None -> LocalAssum (i,t') + | Some b' -> LocalDef (i,b',t') + in List.iter (Metasyntax.set_notation_for_interpretation impls) no; (push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], impls_env) nots l let compute_constructor_level evars env l = - List.fold_right (fun (n,b,t as d) (env, univ) -> + List.fold_right (fun d (env, univ) -> let univ = - if b = None then - let s = Retyping.get_sort_of env evars t in + if is_local_assum d then + let s = Retyping.get_sort_of env evars (get_type d) in Univ.sup (univ_of_sort s) univ else univ in (push_rel d env, univ)) @@ -122,7 +126,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), false in let fullarity = it_mkProd_or_LetIn t' newps in - let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in + let env_ar = push_rel_context newps (push_rel (LocalAssum (Name id,fullarity)) env0) in let env2,impls,newfs,data = interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs) in @@ -150,17 +154,17 @@ let typecheck_params_and_fields def id pl t ps nots fs = let newps = Context.Rel.map nf newps in let newfs = Context.Rel.map nf newfs in let ce t = Evarutil.check_evars env0 Evd.empty evars t in - List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); - List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); + List.iter (iter_constr ce) (List.rev newps); + List.iter (iter_constr ce) (List.rev newfs); Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs -let degenerate_decl (na,b,t) = - let id = match na with +let degenerate_decl decl = + let id = match get_name decl with | Name id -> id | Anonymous -> anomaly (Pp.str "Unnamed record variable") in - match b with - | None -> (id, LocalAssum t) - | Some b -> (id, LocalDef b) + match decl with + | LocalAssum (_,t) -> (id, Entries.LocalAssum t) + | LocalDef (_,b,_) -> (id, Entries.LocalDef b) type record_error = | MissingProj of Id.t * Id.t list @@ -264,23 +268,25 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field in let (_,_,kinds,sp_projs,_) = List.fold_left3 - (fun (nfi,i,kinds,sp_projs,subst) coe (fi,optci,ti) impls -> + (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> + let fi = get_name decl in + let ti = get_type decl in let (sp_projs,i,subst) = match fi with | Anonymous -> (None::sp_projs,i,NoProjection fi::subst) | Name fid -> try let kn, term = - if optci = None && primitive then + if is_local_assum decl && primitive then (** Already defined in the kernel silently *) let kn = destConstRef (Nametab.locate (Libnames.qualid_of_ident fid)) in Declare.definition_message fid; kn, mkProj (Projection.make kn false,mkRel 1) else let ccl = subst_projection fid subst ti in - let body = match optci with - | Some ci -> subst_projection fid subst ci - | None -> + let body = match decl with + | LocalDef (_,ci,_) -> subst_projection fid subst ci + | LocalAssum _ -> (* [ccl] is defined in context [params;x:rp] *) (* [ccl'] is defined in context [params;x:rp;x:rp] *) let ccl' = liftn 1 2 ccl in @@ -322,28 +328,28 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let cl = Class.class_of_global (IndRef indsp) in Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl end; - let i = if Option.is_empty optci then i+1 else i in + let i = if is_local_assum decl then i+1 else i in (Some kn::sp_projs, i, Projection term::subst) with NotDefinable why -> warning_or_error coe indsp why; (None::sp_projs,i,NoProjection fi::subst) in - (nfi-1,i,(fi, Option.is_empty optci)::kinds,sp_projs,subst)) + (nfi-1,i,(fi, is_local_assum decl)::kinds,sp_projs,subst)) (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) let structure_signature ctx = let rec deps_to_evar evm l = match l with [] -> Evd.empty - | [(_,_,typ)] -> + | [decl] -> let env = Environ.empty_named_context_val in - let (evm, _) = Evarutil.new_pure_evar env evm typ in + let (evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in evm - | (_,_,typ)::tl -> + | decl::tl -> let env = Environ.empty_named_context_val in - let (evm, ev) = Evarutil.new_pure_evar env evm typ in + let (evm, ev) = Evarutil.new_pure_evar env evm (get_type decl) in let new_tl = Util.List.map_i - (fun pos (n,c,t) -> n,c, - Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in + (fun pos decl -> + map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in deps_to_evar evm new_tl in deps_to_evar Evd.empty (List.rev ctx) @@ -391,7 +397,7 @@ let implicits_of_context ctx = | Name n -> Some n | Anonymous -> None in ExplByPos (i, explname), (true, true, true)) - 1 (List.rev (Anonymous :: (List.map pi1 ctx))) + 1 (List.rev (Anonymous :: (List.map get_name ctx))) let declare_class finite def poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign = @@ -404,7 +410,7 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in let impl, projs = match fields with - | [(Name proj_name, _, field)] when def -> + | [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def -> let class_body = it_mkLambda_or_LetIn field params in let _class_type = it_mkProd_or_LetIn arity params in let class_entry = @@ -445,13 +451,13 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity if b then Backward, pri else Forward, pri) coe) coers priorities in - let l = List.map3 (fun (id, _, _) b y -> (id, b, y)) + let l = List.map3 (fun decl b y -> get_name decl, b, y) (List.rev fields) coers (Recordops.lookup_projections ind) in IndRef ind, l in let ctx_context = - List.map (fun (na, b, t) -> - match Typeclasses.class_of_constr t with + List.map (fun decl -> + match Typeclasses.class_of_constr (get_type decl) with | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) | None -> None) params, params @@ -473,7 +479,7 @@ let add_constant_class cst = let tc = { cl_impl = ConstRef cst; cl_context = (List.map (const None) ctx, ctx); - cl_props = [(Anonymous, None, arity)]; + cl_props = [LocalAssum (Anonymous, arity)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique @@ -487,8 +493,8 @@ let add_inductive_class ind = let ctx = oneind.mind_arity_ctxt in let inst = Univ.UContext.instance mind.mind_universes in let map = function - | (_, Some _, _) -> None - | (_, None, t) -> Some (lazy t) + | LocalDef _ -> None + | LocalAssum (_, t) -> Some (lazy t) in let args = List.map_filter map ctx in let ty = Inductive.type_of_inductive_knowing_parameters @@ -498,7 +504,7 @@ let add_inductive_class ind = in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; - cl_props = [Anonymous, None, ty]; + cl_props = [LocalAssum (Anonymous, ty)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } diff --git a/toplevel/search.ml b/toplevel/search.ml index 89e0eb88ac..646e2e08ac 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -67,7 +67,9 @@ let iter_constructors indsp u fn env nconstr = fn (ConstructRef (indsp, i)) env typ done -let iter_named_context_name_type f = List.iter (fun (nme,_,typ) -> f nme typ) +let iter_named_context_name_type f = + let open Context.Named.Declaration in + List.iter (fun decl -> f (get_id decl) (get_type decl)) (* General search over hypothesis of a goal *) let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = @@ -79,12 +81,13 @@ let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = (* General search over declarations *) let iter_declarations (fn : global_reference -> env -> constr -> unit) = + let open Context.Named.Declaration in let env = Global.env () in let iter_obj (sp, kn) lobj = match object_tag lobj with | "VARIABLE" -> begin try - let (id, _, typ) = Global.lookup_named (basename sp) in - fn (VarRef id) env typ + let decl = Global.lookup_named (basename sp) in + fn (VarRef (get_id decl)) env (get_type decl) with Not_found -> (* we are in a section *) () end | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 0f81943e2c..8b3e118485 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -871,13 +871,14 @@ let vernac_set_end_tac tac = (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) let vernac_set_used_variables e = + let open Context.Named.Declaration in let env = Global.env () in let tys = List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in List.iter (fun id -> - if not (List.exists (fun (id',_,_) -> Id.equal id id') vars) then + if not (List.exists (Id.equal id % get_id) vars) then errorlabstrm "vernac_set_used_variables" (str "Unknown variable: " ++ pr_id id)) l; @@ -1568,6 +1569,7 @@ exception NoHyp We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) let print_about_hyp_globs ref_or_by_not glnumopt = + let open Context.Named.Declaration in try let gl,id = match glnumopt,ref_or_by_not with @@ -1580,11 +1582,11 @@ let print_about_hyp_globs ref_or_by_not glnumopt = (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in - let (id,bdyopt,typ) = Context.Named.lookup id hyps in - let natureofid = match bdyopt with - | None -> "Hypothesis" - | Some bdy ->"Constant (let in)" in - v 0 (pr_id id ++ str":" ++ pr_constr typ ++ fnl() ++ fnl() + let decl = Context.Named.lookup id hyps in + let natureofid = match decl with + | LocalAssum _ -> "Hypothesis" + | LocalDef (_,bdy,_) ->"Constant (let in)" in + v 0 (pr_id id ++ str":" ++ pr_constr (get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> print_about ref_or_by_not -- cgit v1.2.3 From 5dfb5d5e48c86dabd17ee2167c6fd5304c788474 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 9 Feb 2016 18:07:53 +0100 Subject: REFORMATTING: kernel/context.ml{,i} --- kernel/context.ml | 718 +++++++++++++++++++++++++++-------------------------- kernel/context.mli | 8 +- 2 files changed, 364 insertions(+), 362 deletions(-) diff --git a/kernel/context.ml b/kernel/context.ml index cc1e6f1762..4e53b73a28 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -32,380 +32,382 @@ open Names (** Representation of contexts that can capture anonymous as well as non-anonymous variables. Individual declarations are then designated by de Bruijn indexes. *) module Rel = +struct + (** Representation of {e local declarations}. *) + module Declaration = struct - (** Representation of {e local declarations}. *) - module Declaration = - struct - (* local declaration *) - type t = LocalAssum of Name.t * Constr.t (* local assumption *) - | LocalDef of Name.t * Constr.t * Constr.t (* local definition *) - - (** Return the name bound by a given declaration. *) - let get_name = function - | LocalAssum (na,_) - | LocalDef (na,_,_) -> na - - (** Return [Some value] for local-declarations and [None] for local-assumptions. *) - let get_value = function - | LocalAssum _ -> None - | LocalDef (_,v,_) -> Some v - - (** Return the type of the name bound by a given declaration. *) - let get_type = function - | LocalAssum (_,ty) - | LocalDef (_,_,ty) -> ty - - (** Set the name that is bound by a given declaration. *) - let set_name na = function - | LocalAssum (_,ty) -> LocalAssum (na, ty) - | LocalDef (_,v,ty) -> LocalDef (na, v, ty) - - (** Set the type of the bound variable in a given declaration. *) - let set_type ty = function - | LocalAssum (na,_) -> LocalAssum (na, ty) - | LocalDef (na,v,_) -> LocalDef (na, v, ty) - - (** Return [true] iff a given declaration is a local assumption. *) - let is_local_assum = function - | LocalAssum _ -> true - | LocalDef _ -> false - - (** Return [true] iff a given declaration is a local definition. *) - let is_local_def = function - | LocalAssum _ -> false - | LocalDef _ -> true - - (** Check whether any term in a given declaration satisfies a given predicate. *) - let exists f = function - | LocalAssum (_, ty) -> f ty - | LocalDef (_, v, ty) -> f v || f ty - - (** Check whether all terms in a given declaration satisfy a given predicate. *) - let for_all f = function - | LocalAssum (_, ty) -> f ty - | LocalDef (_, v, ty) -> f v && f ty - - (** Check whether the two given declarations are equal. *) - let equal decl1 decl2 = - match decl1, decl2 with - | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> - Name.equal n1 n2 && Constr.equal ty1 ty2 - | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> - Name.equal n1 n2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 - | _ -> - false - - (** Map the name bound by a given declaration. *) - let map_name f = function - | LocalAssum (na, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalAssum (na', ty) - | LocalDef (na, v, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalDef (na', v, ty) - - (** For local assumptions, this function returns the original local assumptions. - For local definitions, this function maps the value in the local definition. *) - let map_value f = function - | LocalAssum _ as decl -> decl - | LocalDef (na, v, t) as decl -> - let v' = f v in - if v == v' then decl else LocalDef (na, v', t) - - (** Map the type of the name bound by a given declaration. *) - let map_type f = function - | LocalAssum (na, ty) as decl -> - let ty' = f ty in - if ty == ty' then decl else LocalAssum (na, ty') - | LocalDef (na, v, ty) as decl -> - let ty' = f ty in - if ty == ty' then decl else LocalDef (na, v, ty') - - (** Map all terms in a given declaration. *) - let map_constr f = function - | LocalAssum (na, ty) as decl -> - let ty' = f ty in - if ty == ty' then decl else LocalAssum (na, ty') - | LocalDef (na, v, ty) as decl -> - let v' = f v in - let ty' = f ty in - if v == v' && ty == ty' then decl else LocalDef (na, v', ty') - - (** Perform a given action on all terms in a given declaration. *) - let iter_constr f = function - | LocalAssum (_,ty) -> f ty - | LocalDef (_,v,ty) -> f v; f ty - - (** Reduce all terms in a given declaration to a single value. *) - let fold f decl acc = - match decl with - | LocalAssum (n,ty) -> f ty acc - | LocalDef (n,v,ty) -> f ty (f v acc) - - let to_tuple = function - | LocalAssum (na, ty) -> na, None, ty - | LocalDef (na, v, ty) -> na, Some v, ty - - let of_tuple = function - | n, None, ty -> LocalAssum (n,ty) - | n, Some v, ty -> LocalDef (n,v,ty) - end - - (** Rel-context is represented as a list of declarations. - Inner-most declarations are at the beginning of the list. - Outer-most declarations are at the end of the list. *) - type t = Declaration.t list + (* local declaration *) + type t = + | LocalAssum of Name.t * Constr.t (** name, type *) + | LocalDef of Name.t * Constr.t * Constr.t (** name, value, type *) + + (** Return the name bound by a given declaration. *) + let get_name = function + | LocalAssum (na,_) + | LocalDef (na,_,_) -> na + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + let get_value = function + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some v + + (** Return the type of the name bound by a given declaration. *) + let get_type = function + | LocalAssum (_,ty) + | LocalDef (_,_,ty) -> ty + + (** Set the name that is bound by a given declaration. *) + let set_name na = function + | LocalAssum (_,ty) -> LocalAssum (na, ty) + | LocalDef (_,v,ty) -> LocalDef (na, v, ty) + + (** Set the type of the bound variable in a given declaration. *) + let set_type ty = function + | LocalAssum (na,_) -> LocalAssum (na, ty) + | LocalDef (na,v,_) -> LocalDef (na, v, ty) + + (** Return [true] iff a given declaration is a local assumption. *) + let is_local_assum = function + | LocalAssum _ -> true + | LocalDef _ -> false + + (** Return [true] iff a given declaration is a local definition. *) + let is_local_def = function + | LocalAssum _ -> false + | LocalDef _ -> true + + (** Check whether any term in a given declaration satisfies a given predicate. *) + let exists f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v || f ty + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + let for_all f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v && f ty + + (** Check whether the two given declarations are equal. *) + let equal decl1 decl2 = + match decl1, decl2 with + | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> + Name.equal n1 n2 && Constr.equal ty1 ty2 + | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> + Name.equal n1 n2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 + | _ -> + false + + (** Map the name bound by a given declaration. *) + let map_name f = function + | LocalAssum (na, ty) as decl -> + let na' = f na in + if na == na' then decl else LocalAssum (na', ty) + | LocalDef (na, v, ty) as decl -> + let na' = f na in + if na == na' then decl else LocalDef (na', v, ty) + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + let map_value f = function + | LocalAssum _ as decl -> decl + | LocalDef (na, v, t) as decl -> + let v' = f v in + if v == v' then decl else LocalDef (na, v', t) + + (** Map the type of the name bound by a given declaration. *) + let map_type f = function + | LocalAssum (na, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (na, ty') + | LocalDef (na, v, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalDef (na, v, ty') - (** empty rel-context *) - let empty = [] - - (** Return a new rel-context enriched by with a given inner-most declaration. *) - let add d ctx = d :: ctx - - (** Return the number of {e local declarations} in a given context. *) - let length = List.length - - (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] - with n = |Δ| and with the local definitions of [Γ] skipped in - [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) - let nhyps = - let open Declaration in - let rec nhyps acc = function - | [] -> acc - | LocalAssum _ :: hyps -> nhyps (succ acc) hyps - | LocalDef _ :: hyps -> nhyps acc hyps - in - nhyps 0 - - (** Return a declaration designated by a given de Bruijn index. - @raise Not_found if the designated de Bruijn index is not present in the designated rel-context. *) - let rec lookup n ctx = - match n, ctx with - | 1, decl :: _ -> decl - | n, _ :: sign -> lookup (n-1) sign - | _, [] -> raise Not_found - - (** Check whether given two rel-contexts are equal. *) - let equal = List.equal Declaration.equal - - (** Map all terms in a given rel-context. *) - let map f = List.smartmap (Declaration.map_constr f) - - (** Perform a given action on every declaration in a given rel-context. *) - let iter f = List.iter (Declaration.iter_constr f) - - (** Reduce all terms in a given rel-context to a single value. - Innermost declarations are processed first. *) - let fold_inside f ~init = List.fold_left f init - - (** Reduce all terms in a given rel-context to a single value. - Outermost declarations are processed first. *) - let fold_outside f l ~init = List.fold_right f l init - - (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] - and each {e local definition} is mapped to [false]. *) - let to_tags = - let rec aux l = function - | [] -> l - | Declaration.LocalDef _ :: ctx -> aux (true::l) ctx - | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx - in aux [] - - (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] - with n = |Δ| and with the {e local definitions} of [Γ] skipped in - [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) - let to_extended_list n = - let rec reln l p = function - | Declaration.LocalAssum _ :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps - | Declaration.LocalDef _ :: hyps -> reln l (p+1) hyps - | [] -> l - in - reln [] 1 - - (** [extended_vect n Γ] does the same, returning instead an array. *) - let to_extended_vect n hyps = Array.of_list (to_extended_list n hyps) + (** Map all terms in a given declaration. *) + let map_constr f = function + | LocalAssum (na, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (na, ty') + | LocalDef (na, v, ty) as decl -> + let v' = f v in + let ty' = f ty in + if v == v' && ty == ty' then decl else LocalDef (na, v', ty') + + (** Perform a given action on all terms in a given declaration. *) + let iter_constr f = function + | LocalAssum (_,ty) -> f ty + | LocalDef (_,v,ty) -> f v; f ty + + (** Reduce all terms in a given declaration to a single value. *) + let fold f decl acc = + match decl with + | LocalAssum (n,ty) -> f ty acc + | LocalDef (n,v,ty) -> f ty (f v acc) + + let to_tuple = function + | LocalAssum (na, ty) -> na, None, ty + | LocalDef (na, v, ty) -> na, Some v, ty + + let of_tuple = function + | n, None, ty -> LocalAssum (n,ty) + | n, Some v, ty -> LocalDef (n,v,ty) end + (** Rel-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list + + (** empty rel-context *) + let empty = [] + + (** Return a new rel-context enriched by with a given inner-most declaration. *) + let add d ctx = d :: ctx + + (** Return the number of {e local declarations} in a given context. *) + let length = List.length + + (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the local definitions of [Γ] skipped in + [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + let nhyps = + let open Declaration in + let rec nhyps acc = function + | [] -> acc + | LocalAssum _ :: hyps -> nhyps (succ acc) hyps + | LocalDef _ :: hyps -> nhyps acc hyps + in + nhyps 0 + + (** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated de Bruijn index is not present in the designated rel-context. *) + let rec lookup n ctx = + match n, ctx with + | 1, decl :: _ -> decl + | n, _ :: sign -> lookup (n-1) sign + | _, [] -> raise Not_found + + (** Check whether given two rel-contexts are equal. *) + let equal = List.equal Declaration.equal + + (** Map all terms in a given rel-context. *) + let map f = List.smartmap (Declaration.map_constr f) + + (** Perform a given action on every declaration in a given rel-context. *) + let iter f = List.iter (Declaration.iter_constr f) + + (** Reduce all terms in a given rel-context to a single value. + Innermost declarations are processed first. *) + let fold_inside f ~init = List.fold_left f init + + (** Reduce all terms in a given rel-context to a single value. + Outermost declarations are processed first. *) + let fold_outside f l ~init = List.fold_right f l init + + (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] + and each {e local definition} is mapped to [false]. *) + let to_tags = + let rec aux l = function + | [] -> l + | Declaration.LocalDef _ :: ctx -> aux (true::l) ctx + | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx + in aux [] + + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the {e local definitions} of [Γ] skipped in + [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + let to_extended_list n = + let rec reln l p = function + | Declaration.LocalAssum _ :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps + | Declaration.LocalDef _ :: hyps -> reln l (p+1) hyps + | [] -> l + in + reln [] 1 + + (** [extended_vect n Γ] does the same, returning instead an array. *) + let to_extended_vect n hyps = Array.of_list (to_extended_list n hyps) +end + (** This module represents contexts that can capture non-anonymous variables. Individual declarations are then designated by the identifiers they bind. *) module Named = +struct + (** Representation of {e local declarations}. *) + module Declaration = struct - (** Representation of {e local declarations}. *) - module Declaration = - struct - (** local declaration *) - type t = LocalAssum of Id.t * Constr.t - | LocalDef of Id.t * Constr.t * Constr.t - - (** Return the identifier bound by a given declaration. *) - let get_id = function - | LocalAssum (id,_) -> id - | LocalDef (id,_,_) -> id - - (** Return [Some value] for local-declarations and [None] for local-assumptions. *) - let get_value = function - | LocalAssum _ -> None - | LocalDef (_,v,_) -> Some v - - (** Return the type of the name bound by a given declaration. *) - let get_type = function - | LocalAssum (_,ty) - | LocalDef (_,_,ty) -> ty - - (** Set the identifier that is bound by a given declaration. *) - let set_id id = function - | LocalAssum (_,ty) -> LocalAssum (id, ty) - | LocalDef (_, v, ty) -> LocalDef (id, v, ty) - - (** Set the type of the bound variable in a given declaration. *) - let set_type ty = function - | LocalAssum (id,_) -> LocalAssum (id, ty) - | LocalDef (id,v,_) -> LocalDef (id, v, ty) - - (** Return [true] iff a given declaration is a local assumption. *) - let is_local_assum = function - | LocalAssum _ -> true - | LocalDef _ -> false - - (** Return [true] iff a given declaration is a local definition. *) - let is_local_def = function - | LocalDef _ -> true - | LocalAssum _ -> false - - (** Check whether any term in a given declaration satisfies a given predicate. *) - let exists f = function - | LocalAssum (_, ty) -> f ty - | LocalDef (_, v, ty) -> f v || f ty - - (** Check whether all terms in a given declaration satisfy a given predicate. *) - let for_all f = function - | LocalAssum (_, ty) -> f ty - | LocalDef (_, v, ty) -> f v && f ty - - (** Check whether the two given declarations are equal. *) - let equal decl1 decl2 = - match decl1, decl2 with - | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> - Id.equal id1 id2 && Constr.equal ty1 ty2 - | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> - Id.equal id1 id2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 - | _ -> - false - - (** Map the identifier bound by a given declaration. *) - let map_id f = function - | LocalAssum (id, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalAssum (id', ty) - | LocalDef (id, v, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalDef (id', v, ty) - - (** For local assumptions, this function returns the original local assumptions. - For local definitions, this function maps the value in the local definition. *) - let map_value f = function - | LocalAssum _ as decl -> decl - | LocalDef (na, v, t) as decl -> - let v' = f v in - if v == v' then decl else LocalDef (na, v', t) - - (** Map the type of the name bound by a given declaration. *) - let map_type f = function - | LocalAssum (id, ty) as decl -> - let ty' = f ty in - if ty == ty' then decl else LocalAssum (id, ty') - | LocalDef (id, v, ty) as decl -> - let ty' = f ty in - if ty == ty' then decl else LocalDef (id, v, ty') - - (** Map all terms in a given declaration. *) - let map_constr f = function - | LocalAssum (id, ty) as decl -> - let ty' = f ty in - if ty == ty' then decl else LocalAssum (id, ty') - | LocalDef (id, v, ty) as decl -> - let v' = f v in - let ty' = f ty in - if v == v' && ty == ty' then decl else LocalDef (id, v', ty') - - (** Perform a given action on all terms in a given declaration. *) - let iter_constr f = function - | LocalAssum (_, ty) -> f ty - | LocalDef (_, v, ty) -> f v; f ty - - (** Reduce all terms in a given declaration to a single value. *) - let fold f decl a = - match decl with - | LocalAssum (_, ty) -> f ty a - | LocalDef (_, v, ty) -> a |> f v |> f ty - - let to_tuple = function - | LocalAssum (id, ty) -> id, None, ty - | LocalDef (id, v, ty) -> id, Some v, ty - - let of_tuple = function - | id, None, ty -> LocalAssum (id, ty) - | id, Some v, ty -> LocalDef (id, v, ty) - end - - (** Named-context is represented as a list of declarations. - Inner-most declarations are at the beginning of the list. - Outer-most declarations are at the end of the list. *) - type t = Declaration.t list - - (** empty named-context *) - let empty = [] - - (** empty named-context *) - let add d ctx = d :: ctx - - (** Return the number of {e local declarations} in a given named-context. *) - let length = List.length - - (** Return a declaration designated by a given de Bruijn index. - @raise Not_found if the designated identifier is not present in the designated named-context. *) let rec lookup id = function - | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl - | _ :: sign -> lookup id sign - | [] -> raise Not_found - - (** Check whether given two named-contexts are equal. *) - let equal = List.equal Declaration.equal - - (** Map all terms in a given named-context. *) - let map f = List.smartmap (Declaration.map_constr f) - - (** Perform a given action on every declaration in a given named-context. *) - let iter f = List.iter (Declaration.iter_constr f) - - (** Reduce all terms in a given named-context to a single value. - Innermost declarations are processed first. *) - let fold_inside f ~init = List.fold_left f init - - (** Reduce all terms in a given named-context to a single value. - Outermost declarations are processed first. *) - let fold_outside f l ~init = List.fold_right f l init + (** local declaration *) + type t = + | LocalAssum of Id.t * Constr.t (** identifier, type *) + | LocalDef of Id.t * Constr.t * Constr.t (** identifier, value, type *) + + (** Return the identifier bound by a given declaration. *) + let get_id = function + | LocalAssum (id,_) -> id + | LocalDef (id,_,_) -> id + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + let get_value = function + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some v + + (** Return the type of the name bound by a given declaration. *) + let get_type = function + | LocalAssum (_,ty) + | LocalDef (_,_,ty) -> ty + + (** Set the identifier that is bound by a given declaration. *) + let set_id id = function + | LocalAssum (_,ty) -> LocalAssum (id, ty) + | LocalDef (_, v, ty) -> LocalDef (id, v, ty) + + (** Set the type of the bound variable in a given declaration. *) + let set_type ty = function + | LocalAssum (id,_) -> LocalAssum (id, ty) + | LocalDef (id,v,_) -> LocalDef (id, v, ty) + + (** Return [true] iff a given declaration is a local assumption. *) + let is_local_assum = function + | LocalAssum _ -> true + | LocalDef _ -> false + + (** Return [true] iff a given declaration is a local definition. *) + let is_local_def = function + | LocalDef _ -> true + | LocalAssum _ -> false + + (** Check whether any term in a given declaration satisfies a given predicate. *) + let exists f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v || f ty + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + let for_all f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v && f ty + + (** Check whether the two given declarations are equal. *) + let equal decl1 decl2 = + match decl1, decl2 with + | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> + Id.equal id1 id2 && Constr.equal ty1 ty2 + | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> + Id.equal id1 id2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 + | _ -> + false + + (** Map the identifier bound by a given declaration. *) + let map_id f = function + | LocalAssum (id, ty) as decl -> + let id' = f id in + if id == id' then decl else LocalAssum (id', ty) + | LocalDef (id, v, ty) as decl -> + let id' = f id in + if id == id' then decl else LocalDef (id', v, ty) + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + let map_value f = function + | LocalAssum _ as decl -> decl + | LocalDef (na, v, t) as decl -> + let v' = f v in + if v == v' then decl else LocalDef (na, v', t) + + (** Map the type of the name bound by a given declaration. *) + let map_type f = function + | LocalAssum (id, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (id, ty') + | LocalDef (id, v, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalDef (id, v, ty') - (** Return the set of all identifiers bound in a given named-context. *) - let to_vars = - List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty + (** Map all terms in a given declaration. *) + let map_constr f = function + | LocalAssum (id, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (id, ty') + | LocalDef (id, v, ty) as decl -> + let v' = f v in + let ty' = f ty in + if v == v' && ty == ty' then decl else LocalDef (id, v', ty') + + (** Perform a given action on all terms in a given declaration. *) + let iter_constr f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v; f ty + + (** Reduce all terms in a given declaration to a single value. *) + let fold f decl a = + match decl with + | LocalAssum (_, ty) -> f ty a + | LocalDef (_, v, ty) -> a |> f v |> f ty + + let to_tuple = function + | LocalAssum (id, ty) -> id, None, ty + | LocalDef (id, v, ty) -> id, Some v, ty + + let of_tuple = function + | id, None, ty -> LocalAssum (id, ty) + | id, Some v, ty -> LocalDef (id, v, ty) + end - (** [instance_from_named_context Ω] builds an instance [args] such - that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local - definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it - gives [Var id1, Var id3]. All [idj] are supposed distinct. *) - let to_instance = - let filter = function - | Declaration.LocalAssum (id, _) -> Some (Constr.mkVar id) - | _ -> None - in - List.map_filter filter + (** Named-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list + + (** empty named-context *) + let empty = [] + + (** empty named-context *) + let add d ctx = d :: ctx + + (** Return the number of {e local declarations} in a given named-context. *) + let length = List.length + +(** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated identifier is not present in the designated named-context. *) let rec lookup id = function + | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl + | _ :: sign -> lookup id sign + | [] -> raise Not_found + + (** Check whether given two named-contexts are equal. *) + let equal = List.equal Declaration.equal + + (** Map all terms in a given named-context. *) + let map f = List.smartmap (Declaration.map_constr f) + + (** Perform a given action on every declaration in a given named-context. *) + let iter f = List.iter (Declaration.iter_constr f) + + (** Reduce all terms in a given named-context to a single value. + Innermost declarations are processed first. *) + let fold_inside f ~init = List.fold_left f init + + (** Reduce all terms in a given named-context to a single value. + Outermost declarations are processed first. *) + let fold_outside f l ~init = List.fold_right f l init + + (** Return the set of all identifiers bound in a given named-context. *) + let to_vars = + List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty + + (** [instance_from_named_context Ω] builds an instance [args] such + that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local + definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it + gives [Var id1, Var id3]. All [idj] are supposed distinct. *) + let to_instance = + let filter = function + | Declaration.LocalAssum (id, _) -> Some (Constr.mkVar id) + | _ -> None + in + List.map_filter filter end module NamedList = struct module Declaration = struct - type t = Id.t list * Constr.t option * Constr.t + type t = Id.t list * Constr.t option * Constr.t let map_constr f (ids, copt, ty as decl) = let copt' = Option.map f copt in diff --git a/kernel/context.mli b/kernel/context.mli index a69754cc29..b5f3904d22 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -29,8 +29,8 @@ sig module Declaration : sig (* local declaration *) - type t = LocalAssum of Name.t * Constr.t (* local assumption *) - | LocalDef of Name.t * Constr.t * Constr.t (* local definition *) + type t = LocalAssum of Name.t * Constr.t (** name, type *) + | LocalDef of Name.t * Constr.t * Constr.t (** name, value, type *) (** Return the name bound by a given declaration. *) val get_name : t -> Name.t @@ -143,8 +143,8 @@ sig (** Representation of {e local declarations}. *) module Declaration : sig - type t = LocalAssum of Id.t * Constr.t - | LocalDef of Id.t * Constr.t * Constr.t + type t = LocalAssum of Id.t * Constr.t (** identifier, type *) + | LocalDef of Id.t * Constr.t * Constr.t (** identifier, value, type *) (** Return the identifier bound by a given declaration. *) val get_id : t -> Id.t -- cgit v1.2.3 From 5f29a92c0648afd4d9e46de79ab00d0c4b901ff0 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 9 Feb 2016 16:36:05 +0100 Subject: Don't fail fatally if PATH is not set. This fixes micromega in certain environments. --- lib/system.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index 9bdcecef19..0ad43a7423 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -149,10 +149,12 @@ let is_in_path lpath filename = with Not_found -> false let is_in_system_path filename = - let path = try Sys.getenv "PATH" - with Not_found -> error "system variable PATH not found" in - let lpath = CUnix.path_to_list path in - is_in_path lpath filename + try + let lpath = CUnix.path_to_list (Sys.getenv "PATH") in + is_in_path lpath filename + with Not_found -> + msg_warning (str "system variable PATH not found"); + false let open_trapping_failure name = try open_out_bin name -- cgit v1.2.3 From 22ab7fff908c259d6e433da246bebac519009905 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 10 Feb 2016 17:54:25 +0100 Subject: STM: not delegate proofs that contain Vernac(Module|Require|Import), #4530 --- stm/stm.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/stm/stm.ml b/stm/stm.ml index d8b2de4a2c..5ad1aead61 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1686,6 +1686,13 @@ let collect_proof keep cur hd brkind id = | _ -> false in let may_pierce_opaque = function | { expr = VernacPrint (PrintName _) } -> true + (* These do not exactly pierce opaque, but are anyway impossible to properly + * delegate *) + | { expr = (VernacDeclareModule _ + | VernacDefineModule _ + | VernacDeclareModuleType _ + | VernacInclude _) } -> true + | { expr = (VernacRequire _ | VernacImport _) } -> true | _ -> false in let parent = function Some (p, _) -> p | None -> assert false in let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in -- cgit v1.2.3 From df6bb883920e3a03044d09f10b57a44a2e7c5196 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 10 Feb 2016 17:59:14 +0100 Subject: STM: always stock in vio files the first node (state) of a proof It used not to be the case when the proof contains Sideff, since the code was picking the last known state and not necessarily the first one. Because of side effects the last known state could be the one corresponding to the side effect (that was executed to, say, change the parser). This is also related to bug #4530 --- stm/stm.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/stm/stm.ml b/stm/stm.ml index 5ad1aead61..56dcda6a4a 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -513,7 +513,10 @@ end = struct (* {{{ *) let rec fill id = if (get_info id).state = None then fill (Vcs_aux.visit v id).next else copy_info_w_state v id in - fill stop + let v = fill stop in + (* We put in the new dag the first state (since Qed shall run on it, + * see check_task_aux) *) + copy_info_w_state v start let nodes_in_slice ~start ~stop = List.rev (List.map fst (nodes_in_slice ~start ~stop)) -- cgit v1.2.3 From f46a5686853353f8de733ae7fbd21a3a61977bc7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 15:32:58 +0100 Subject: Do not give a name to anonymous evars anymore. See bug #4547. The current solution may not be totally ideal though. We generate names for anonymous evars on the fly at printing time, based on the Evar_kind data they are wearing. This means in particular that the printed name of an anonymous evar may change in the future because some unrelate evar has been solved or introduced. --- interp/constrextern.ml | 5 +- pretyping/detyping.ml | 5 +- pretyping/evarutil.ml | 9 +--- pretyping/evd.ml | 103 +++++++++++++++++++++++-------------- pretyping/evd.mli | 4 +- printing/printer.ml | 2 +- proofs/goal.ml | 5 +- proofs/proofview.ml | 5 +- test-suite/bugs/closed/3068.v | 2 +- test-suite/output/Existentials.out | 3 +- test-suite/output/Notations.out | 14 ++--- test-suite/output/inference.out | 8 +-- test-suite/success/apply.v | 2 +- test-suite/success/destruct.v | 8 +-- 14 files changed, 102 insertions(+), 73 deletions(-) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 9df8f9c233..cc5d189e04 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -988,7 +988,10 @@ let rec glob_of_pat env sigma = function | PEvar (evk,l) -> let test (id,_,_) = function PVar id' -> Id.equal id id' | _ -> false in let l = Evd.evar_instance_array test (Evd.find sigma evk) l in - let id = Evd.evar_ident evk sigma in + let id = match Evd.evar_ident evk sigma with + | None -> Id.of_string "__" + | Some id -> id + in GEvar (loc,id,List.map (on_snd (glob_of_pat env sigma)) l) | PRel n -> let id = try match lookup_name_of_rel n env with diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index c3877c56e4..0c487ced81 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -518,7 +518,10 @@ let rec detype flags avoid env sigma t = with Not_found -> isVarId id c in let id,l = try - let id = Evd.evar_ident evk sigma in + let id = match Evd.evar_ident evk sigma with + | None -> Evd.pr_evar_suggested_name evk sigma + | Some id -> id + in let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index e23e5a53a7..759e0e4d6d 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -365,14 +365,7 @@ let new_pure_evar_full evd evi = (evd, evk) let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ = - let default_naming = - if principal then - (* waiting for a more principled approach - (unnamed evars, private names?) *) - Misctypes.IntroFresh (Names.Id.of_string "tmp_goal") - else - Misctypes.IntroAnonymous - in + let default_naming = Misctypes.IntroAnonymous in let naming = Option.default default_naming naming in let newevk = new_untyped_evar() in let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 8be09a7821..0bc688aacf 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -208,15 +208,6 @@ let map_evar_info f evi = evar_concl = f evi.evar_concl; evar_candidates = Option.map (List.map f) evi.evar_candidates } -let evar_ident_info evi = - match evi.evar_source with - | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id - | _,Evar_kinds.VarInstance id -> id - | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" - | _ -> - let env = reset_with_named_context evi.evar_hyps (Global.env()) in - Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous - (* This exception is raised by *.existential_value *) exception NotInstantiatedEvar @@ -588,7 +579,7 @@ val add_name_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t - val remove_name_defined : Evar.t -> t -> t val rename : Evar.t -> Id.t -> t -> t val reassign_name_defined : Evar.t -> Evar.t -> t -> t -val ident : Evar.t -> t -> Id.t +val ident : Evar.t -> t -> Id.t option val key : Id.t -> t -> Evar.t end = @@ -598,21 +589,21 @@ type t = Id.t EvMap.t * existential_key Idmap.t let empty = (EvMap.empty, Idmap.empty) -let add_name_newly_undefined naming evk evi (evtoid,idtoev) = +let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) = let id = match naming with - | Misctypes.IntroAnonymous -> - let id = evar_ident_info evi in - Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) + | Misctypes.IntroAnonymous -> None | Misctypes.IntroIdentifier id -> - let id' = - Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in - if not (Names.Id.equal id id') then - user_err_loc - (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); - id' + if Idmap.mem id idtoev then + user_err_loc + (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); + Some id | Misctypes.IntroFresh id -> - Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in - (EvMap.add evk id evtoid, Idmap.add id evk idtoev) + let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in + Some id + in + match id with + | None -> names + | Some id -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) = if EvMap.mem evk evtoid then @@ -620,25 +611,30 @@ let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) = else add_name_newly_undefined naming evk evi evar_names -let remove_name_defined evk (evtoid,idtoev) = - let id = EvMap.find evk evtoid in - (EvMap.remove evk evtoid, Idmap.remove id idtoev) +let remove_name_defined evk (evtoid, idtoev as names) = + let id = try Some (EvMap.find evk evtoid) with Not_found -> None in + match id with + | None -> names + | Some id -> (EvMap.remove evk evtoid, Idmap.remove id idtoev) let rename evk id (evtoid, idtoev) = - let id' = EvMap.find evk evtoid in - if Idmap.mem id idtoev then anomaly (str "Evar name already in use"); - (EvMap.add evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev)) - -let reassign_name_defined evk evk' (evtoid,idtoev) = - let id = EvMap.find evk evtoid in - (EvMap.add evk' id (EvMap.remove evk evtoid), - Idmap.add id evk' (Idmap.remove id idtoev)) + let id' = try Some (EvMap.find evk evtoid) with Not_found -> None in + match id' with + | None -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) + | Some id' -> + if Idmap.mem id idtoev then anomaly (str "Evar name already in use"); + (EvMap.update evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev)) + +let reassign_name_defined evk evk' (evtoid, idtoev as names) = + let id = try Some (EvMap.find evk evtoid) with Not_found -> None in + match id with + | None -> names (** evk' must not be defined *) + | Some id -> + (EvMap.add evk' id (EvMap.remove evk evtoid), + Idmap.add id evk' (Idmap.remove id idtoev)) let ident evk (evtoid, _) = - try EvMap.find evk evtoid - with Not_found -> - (* Unnamed (non-dependent) evar *) - add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk)) + try Some (EvMap.find evk evtoid) with Not_found -> None let key id (_, idtoev) = Idmap.find id idtoev @@ -682,7 +678,7 @@ let add d e i = match i.evar_body with let evar_names = EvNames.add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in { d with undf_evars = EvMap.add e i d.undf_evars; evar_names } | Evar_defined _ -> - let evar_names = try EvNames.remove_name_defined e d.evar_names with Not_found -> d.evar_names in + let evar_names = EvNames.remove_name_defined e d.evar_names in { d with defn_evars = EvMap.add e i d.defn_evars; evar_names } let remove d e = @@ -1706,7 +1702,34 @@ type unsolvability_explanation = SeveralInstancesFound of int (**********************************************************) (* Pretty-printing *) -let pr_existential_key sigma evk = str "?" ++ pr_id (evar_ident evk sigma) +let pr_evar_suggested_name evk sigma = + let base_id evk' evi = + match evar_ident evk' sigma with + | Some id -> id + | None -> match evi.evar_source with + | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id + | _,Evar_kinds.VarInstance id -> id + | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" + | _ -> + let env = reset_with_named_context evi.evar_hyps (Global.env()) in + Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous + in + let names = EvMap.mapi base_id sigma.undf_evars in + let id = EvMap.find evk names in + let fold evk' id' (seen, n) = + if seen then (seen, n) + else if Evar.equal evk evk' then (true, n) + else if Id.equal id id' then (seen, succ n) + else (seen, n) + in + let (_, n) = EvMap.fold fold names (false, 0) in + if n = 0 then id else Nameops.add_suffix id (string_of_int (pred n)) + +let pr_existential_key sigma evk = match evar_ident evk sigma with +| None -> + str "?" ++ pr_id (pr_evar_suggested_name evk sigma) +| Some id -> + str "?" ++ pr_id id let pr_instance_status (sc,typ) = begin match sc with @@ -1895,7 +1918,7 @@ let pr_evar_list sigma l = h 0 (str (string_of_existential ev) ++ str "==" ++ pr_evar_info evi ++ (if evi.evar_body == Evar_empty - then str " {" ++ pr_id (evar_ident ev sigma) ++ str "}" + then str " {" ++ pr_existential_key sigma ev ++ str "}" else mt ())) in h 0 (prlist_with_sep fnl pr l) diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 9cfca02ed8..d2479c1229 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -249,7 +249,7 @@ val evar_source : existential_key -> evar_map -> Evar_kinds.t located (** Convenience function. Wrapper around {!find} to recover the source of an evar in a given evar map. *) -val evar_ident : existential_key -> evar_map -> Id.t +val evar_ident : existential_key -> evar_map -> Id.t option val rename : existential_key -> Id.t -> evar_map -> evar_map @@ -603,6 +603,8 @@ type unsolvability_explanation = SeveralInstancesFound of int val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds +val pr_evar_suggested_name : existential_key -> evar_map -> Id.t + (** {5 Debug pretty-printers} *) val pr_evar_info : evar_info -> Pp.std_ppcmds diff --git a/printing/printer.ml b/printing/printer.ml index 5ad0e45319..63755d7ff7 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -400,7 +400,7 @@ let display_name = false (* display a goal name *) let pr_goal_name sigma g = - if display_name then str " " ++ Pp.surround (pr_id (Evd.evar_ident g sigma)) + if display_name then str " " ++ Pp.surround (pr_existential_key sigma g) else mt () (* display the conclusion of a goal *) diff --git a/proofs/goal.ml b/proofs/goal.ml index 1dd5be0e71..43a3024e50 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -89,7 +89,10 @@ module V82 = struct (* Instantiates a goal with an open term, using name of goal for evk' *) let partial_solution_to sigma evk evk' c = let id = Evd.evar_ident evk sigma in - Evd.rename evk' id (partial_solution sigma evk c) + let sigma = partial_solution sigma evk c in + match id with + | None -> sigma + | Some id -> Evd.rename evk' id sigma (* Parts of the progress tactical *) let same_goal evars1 gl1 evars2 gl2 = diff --git a/proofs/proofview.ml b/proofs/proofview.ml index a6d9735f14..49228c93ac 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1093,7 +1093,10 @@ struct | None -> Evd.define gl.Goal.self c sigma | Some evk -> let id = Evd.evar_ident gl.Goal.self sigma in - Evd.rename evk id (Evd.define gl.Goal.self c sigma) + let sigma = Evd.define gl.Goal.self c sigma in + match id with + | None -> sigma + | Some id -> Evd.rename evk id sigma in (** Restore the [future goals] state. *) let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v index ced6d95949..79671ce930 100644 --- a/test-suite/bugs/closed/3068.v +++ b/test-suite/bugs/closed/3068.v @@ -56,7 +56,7 @@ Section Finite_nat_set. subst fs1. apply iff_refl. intros H. - eapply counted_list_equal_nth_char. + eapply (counted_list_equal_nth_char _ _ _ _ ?[def]). intros i. destruct (counted_def_nth fs1 i _ ) eqn:H0. (* This was not part of the initial bug report; this is to check that diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out index 52e1e0ed01..9680d2bbff 100644 --- a/test-suite/output/Existentials.out +++ b/test-suite/output/Existentials.out @@ -1,5 +1,4 @@ -Existential 1 = -?Goal1 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] +Existential 1 = ?Goal : [p : nat q := S p : nat n : nat m : nat |- ?y = m] Existential 2 = ?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) Existential 3 = ?Goal0 : [q : nat n : nat m : nat |- n = ?y] diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index b1558dab1c..26eaca8272 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -111,14 +111,14 @@ fun x : option Z => match x with | NONE2 => 0 end : option Z -> Z -fun x : list ?T1 => match x with - | NIL => NONE2 - | (_ :') t => SOME2 t - end - : list ?T1 -> option (list ?T1) +fun x : list ?T => match x with + | NIL => NONE2 + | (_ :') t => SOME2 t + end + : list ?T -> option (list ?T) where -?T1 : [x : list ?T1 x1 : list ?T1 x0 := x1 : list ?T1 |- Type] (x, x1, - x0 cannot be used) +?T : [x : list ?T x1 : list ?T x0 := x1 : list ?T |- Type] (x, x1, + x0 cannot be used) s : s 10 diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index f2d1447785..4512e2c5ce 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -9,10 +9,10 @@ fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H fun n : nat => let x := A n in ?y ?y0 : T n : forall n : nat, T n where -?y : [n : nat x := A n : T n |- ?T0 -> T n] -?y0 : [n : nat x := A n : T n |- ?T0] +?y : [n : nat x := A n : T n |- ?T -> T n] +?y0 : [n : nat x := A n : T n |- ?T] fun n : nat => ?y ?y0 : T n : forall n : nat, T n where -?y : [n : nat |- ?T0 -> T n] -?y0 : [n : nat |- ?T0] +?y : [n : nat |- ?T -> T n] +?y0 : [n : nat |- ?T] diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index 55b666b723..02e043bc36 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -543,7 +543,7 @@ Qed. Lemma bar (X: nat -> nat -> Prop) (foo:forall x, X x x) (a: unit) (H: tt = a): exists x, exists y, X x y. Proof. -intros; eexists; eexists; case H. +intros; eexists; eexists ?[y]; case H. apply (foo ?y). Grab Existential Variables. exact 0. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 9f091e3996..90a60daa66 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -96,21 +96,21 @@ Abort. (* Check that subterm selection does not solve existing evars *) Goal exists x, S x = S 0. -eexists. +eexists ?[x]. Show x. (* Incidentally test Show on a named goal *) destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S 0). Abort. Goal exists x, S 0 = S x. -eexists. +eexists ?[x]. destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S ?x). [x]: exact 0. (* Incidentally test applying a tactic to a goal on the shelve *) Abort. Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. -do 2 eexists. +eexists ?[n]; eexists ?[p]. destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *) change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n). Abort. @@ -426,7 +426,7 @@ destruct b eqn:H. (* Check natural instantiation behavior when the goal has already an evar *) Goal exists x, S x = x. -eexists. +eexists ?[x]. destruct (S _). change (0 = ?x). Abort. -- cgit v1.2.3 From 968dfdb15cc11d48783017b2a91147b25c854ad6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Dec 2015 19:45:01 +0100 Subject: Monotonizing the Evarutil module. Some functions were left in the old paradigm because they are only used by the unification algorithms, so they are not worthwhile to change for now. --- engine/sigma.ml | 12 +++++++++ engine/sigma.mli | 7 +++++ plugins/firstorder/instances.ml | 5 +++- pretyping/cases.ml | 5 +++- pretyping/evarconv.ml | 4 ++- pretyping/evarsolve.ml | 13 ++++++--- pretyping/evarutil.ml | 60 +++++++++++++++++++++++++---------------- pretyping/evarutil.mli | 26 +++++++++--------- pretyping/pretyping.ml | 12 ++++++--- pretyping/tacred.ml | 5 +++- proofs/goal.ml | 11 +++++--- tactics/rewrite.ml | 22 ++++++++++----- tactics/tactics.ml | 9 +++---- toplevel/record.ml | 9 +++++-- 14 files changed, 136 insertions(+), 64 deletions(-) diff --git a/engine/sigma.ml b/engine/sigma.ml index e886b0d1e7..c25aac0c14 100644 --- a/engine/sigma.ml +++ b/engine/sigma.ml @@ -36,6 +36,18 @@ let new_evar sigma ?naming info = let define evk c sigma = Sigma ((), Evd.define evk c sigma, ()) +let new_univ_level_variable ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_univ_level_variable ?name ?predicative rigid sigma in + Sigma (u, sigma, ()) + +let new_univ_variable ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_univ_variable ?name ?predicative rigid sigma in + Sigma (u, sigma, ()) + +let new_sort_variable ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_sort_variable ?name ?predicative rigid sigma in + Sigma (u, sigma, ()) + let fresh_sort_in_family ?rigid env sigma s = let (sigma, s) = Evd.fresh_sort_in_family ?rigid env sigma s in Sigma (s, sigma, ()) diff --git a/engine/sigma.mli b/engine/sigma.mli index cb948dba59..d7ae2e4ac9 100644 --- a/engine/sigma.mli +++ b/engine/sigma.mli @@ -66,6 +66,13 @@ val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma (** Polymorphic universes *) +val new_univ_level_variable : ?name:string -> ?predicative:bool -> Evd.rigid -> + 'r t -> (Univ.universe_level, 'r) sigma +val new_univ_variable : ?name:string -> ?predicative:bool -> Evd.rigid -> + 'r t -> (Univ.universe, 'r) sigma +val new_sort_variable : ?name:string -> ?predicative:bool -> Evd.rigid -> + 'r t -> (Sorts.t, 'r) sigma + val fresh_sort_in_family : ?rigid:Evd.rigid -> Environ.env -> 'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma val fresh_constant_instance : diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index a717cc91ea..fcbad46d46 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -22,6 +22,7 @@ open Formula open Sequent open Names open Misctypes +open Sigma.Notations let compare_instance inst1 inst2= match inst1,inst2 with @@ -116,7 +117,9 @@ let mk_open_instance id idc gl m t= let rec aux n avoid env evmap decls = if Int.equal n 0 then evmap, decls else let nid=(fresh_id avoid var_id gl) in - let evmap, (c, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + let evmap = Sigma.Unsafe.of_evar_map evmap in + let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + let evmap = Sigma.to_evar_map evmap in let decl = (Name nid,None,c) in aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 2cbf3a2650..91bf11eb52 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -28,6 +28,7 @@ open Evarutil open Evarsolve open Evarconv open Evd +open Sigma.Notations (* Pattern-matching errors *) @@ -1947,8 +1948,10 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let sigma,t = match tycon with | Some t -> sigma,t | None -> - let sigma, (t, _) = + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((t, _), sigma, _) = new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in + let sigma = Sigma.to_evar_map sigma in sigma, t in (* First strategy: we build an "inversion" predicate *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 99e51330ef..f3ff26876c 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1007,7 +1007,9 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | None -> let evty = set_holes evdref cty subst in let instance = Filter.filter_list filter instance in - let evd,ev = new_evar_instance sign !evdref evty ~filter instance in + let evd = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in + let evd = Sigma.to_evar_map evd in evdref := evd; evsref := (fst (destEvar ev),evty)::!evsref; ev in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 0dd0ad2e08..518f4df408 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -19,6 +19,7 @@ open Retyping open Reductionops open Evarutil open Pretype_errors +open Sigma.Notations let normalize_evar evd ev = match kind_of_term (whd_evar evd (mkEvar ev)) with @@ -180,7 +181,9 @@ let restrict_evar_key evd evk filter candidates = let candidates = match candidates with | NoUpdate -> evi.evar_candidates | UpdateWith c -> Some c in - restrict_evar evd evk filter candidates + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in + (Sigma.to_evar_map sigma, evk) end (* Restrict an applied evar and returns its restriction in the same context *) @@ -570,7 +573,9 @@ let make_projectable_subst aliases sigma evi args = *) let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = - let evd,evar_in_env = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in + let evd = Sigma.to_evar_map evd in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in let ctxt = named_context_of_val sign in @@ -631,8 +636,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in - let evd,ev2_in_sign = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (ev2_in_sign, evd, _) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in + let evd = Sigma.to_evar_map evd in let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index cd5188cd75..2ed557683e 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -19,6 +19,7 @@ open Environ open Evd open Reductionops open Pretype_errors +open Sigma.Notations (** Combinators *) @@ -41,7 +42,7 @@ let e_new_global evdref x = evd_comb1 (Evd.fresh_global (Global.env())) evdref x let new_global evd x = - Evd.fresh_global (Global.env()) evd x + Sigma.fresh_global (Global.env()) evd x (****************************************************) (* Expanding/testing/exposing existential variables *) @@ -342,15 +343,18 @@ let push_rel_context_to_named_context env typ = let default_source = (Loc.ghost,Evar_kinds.InternalHole) let restrict_evar evd evk filter candidates = + let evd = Sigma.to_evar_map evd in let evd, evk' = Evd.restrict evk filter ?candidates evd in - Evd.declare_future_goal evk' evd, evk' + Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) let new_pure_evar_full evd evi = + let evd = Sigma.to_evar_map evd in let (evd, evk) = Evd.new_evar evd evi in let evd = Evd.declare_future_goal evk evd in - (evd, evk) + Sigma.Unsafe.of_pair (evk, evd) let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = + let evd = Sigma.to_evar_map evd in let default_naming = Misctypes.IntroAnonymous in let naming = Option.default default_naming naming in let evi = { @@ -367,17 +371,17 @@ let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?ca if principal then Evd.declare_principal_goal newevk evd else Evd.declare_future_goal newevk evd in - (evd,newevk) + Sigma.Unsafe.of_pair (newevk, evd) let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); - let evd,newevk = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in - (evd,mkEvar (newevk,Array.of_list instance)) + let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in + Sigma (mkEvar (newevk,Array.of_list instance), evd, p) (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) -let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = +let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in let instance = @@ -386,24 +390,26 @@ let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal t | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance -let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let evd = Sigma.to_evar_map evd in - let (sigma, c) = new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ in - Sigma.Unsafe.of_pair (c, sigma) +let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in + (Sigma.to_evar_map evd, evk) let new_type_evar env evd ?src ?filter ?naming ?principal rigid = - let evd', s = new_sort_variable rigid evd in - let evd', e = new_evar_unsafe env evd' ?src ?filter ?naming ?principal (mkSort s) in - evd', (e, s) + let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in + let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in + Sigma ((e, s), evd', p +> q) let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = - let evd', c = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in - evdref := evd'; + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in + let sigma = Sigma.to_evar_map sigma in + evdref := sigma; c let new_Type ?(rigid=Evd.univ_flexible) env evd = - let evd', s = new_sort_variable rigid evd in - evd', mkSort s + let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in + Sigma (mkSort s, sigma, p) let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = let evd', s = new_sort_variable rigid !evdref in @@ -501,7 +507,9 @@ let rec check_and_clear_in_constr env evdref err ids c = else let origfilter = Evd.evar_filter evi in let filter = Evd.Filter.apply_subfilter origfilter filter in - let evd,_ = restrict_evar !evdref evk filter None in + let evd = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (_, evd, _) = restrict_evar evd evk filter None in + let evd = Sigma.to_evar_map evd in evdref := evd; (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) let evi = Evd.find !evdref evk in @@ -708,7 +716,10 @@ let define_pure_evar_as_product evd evk = let concl = whd_betadeltaiota evenv evd evi.evar_concl in let s = destSort concl in let evd1,(dom,u1) = - new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in + (Sigma.to_evar_map evd1, e) + in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in @@ -719,7 +730,10 @@ let define_pure_evar_as_product evd evk = else let status = univ_flexible_alg in let evd3, (rng, srng) = - new_type_evar newenv evd1 status ~src ~filter in + let evd1 = Sigma.Unsafe.of_evar_map evd1 in + let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in + (Sigma.to_evar_map evd3, e) + in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in evd3, rng @@ -798,8 +812,8 @@ let define_evar_as_sort env evd (ev,args) = any type has type Type. May cause some trouble, but not so far... *) let judge_of_new_Type evd = - let evd', s = new_univ_variable univ_rigid evd in - evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } + let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in + Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index d87c7ef8d1..bc4c37a918 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -27,12 +27,12 @@ val new_evar : ?principal:bool -> types -> (constr, 'r) Sigma.sigma val new_pure_evar : - named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> evar_map * evar + ?principal:bool -> types -> (evar, 'r) Sigma.sigma -val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar +val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma (** the same with side-effects *) val e_new_evar : @@ -44,23 +44,23 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> - evar_map * (constr * sorts) + (constr * sorts, 'r) Sigma.sigma val e_new_type_evar : env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts -val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr +val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr -val restrict_evar : evar_map -> existential_key -> Filter.t -> - constr list option -> evar_map * existential_key +val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> + constr list option -> (existential_key, 'r) Sigma.sigma (** Polymorphic constants *) -val new_global : evar_map -> Globnames.global_reference -> evar_map * constr +val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: @@ -70,11 +70,11 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : - named_context_val -> evar_map -> types -> - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> + named_context_val -> 'r Sigma.t -> types -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> - constr list -> evar_map * constr + constr list -> (constr, 'r) Sigma.sigma val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list @@ -138,7 +138,7 @@ val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool (** {6 Value/Type constraints} *) -val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment +val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma type type_constraint = types option type val_constraint = constr option diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 11fba7b941..835dc2f808 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -42,6 +42,7 @@ open Glob_ops open Evarconv open Pattern open Misctypes +open Sigma.Notations type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = constr_under_binders Id.Map.t @@ -444,10 +445,13 @@ let pretype_sort evdref = function | GType s -> evd_comb1 judge_of_Type evdref s let new_type_evar env evdref loc = - let e, s = - evd_comb0 (fun evd -> Evarutil.new_type_evar env evd - univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref - in e + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma ((e, _), sigma, _) = + Evarutil.new_type_evar env sigma + univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) + in + evdref := Sigma.to_evar_map sigma; + e let (f_genarg_interp, genarg_interp_hook) = Hook.make () diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index bd46911c92..085aaf78a1 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -23,6 +23,7 @@ open Reductionops open Cbv open Patternops open Locus +open Sigma.Notations (* Errors *) @@ -385,7 +386,9 @@ let substl_with_function subst sigma constr = if i <= k + Array.length v then match v.(i-k-1) with | (fx, Some (min, ref)) -> - let (sigma, evk) = Evarutil.new_pure_evar venv !evd dummy in + let sigma = Sigma.Unsafe.of_evar_map !evd in + let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in + let sigma = Sigma.to_evar_map sigma in evd := sigma; minargs := Evar.Map.add evk min !minargs; lift k (mkEvar (evk, [|fx;ref|])) diff --git a/proofs/goal.ml b/proofs/goal.ml index 43a3024e50..1251dacd5d 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -9,6 +9,7 @@ open Util open Pp open Term +open Sigma.Notations (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated @@ -70,7 +71,9 @@ module V82 = struct Evd.evar_extra = extra } in let evi = Typeclasses.mark_unresolvable evi in - let (evars, evk) = Evarutil.new_pure_evar_full evars evi in + let evars = Sigma.Unsafe.of_evar_map evars in + let Sigma (evk, evars, _) = Evarutil.new_pure_evar_full evars evi in + let evars = Sigma.to_evar_map evars in let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in let ctxt = Environ.named_context_of_val hyps in let inst = Array.map_of_list (fun (id, _, _) -> mkVar id) ctxt in @@ -126,8 +129,10 @@ module V82 = struct let new_evi = { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in - let (new_sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in - { Evd.it = evk ; sigma = new_sigma; } + let sigma = Sigma.Unsafe.of_evar_map Evd.empty in + let Sigma (evk, sigma, _) = Evarutil.new_pure_evar_full sigma new_evi in + let sigma = Sigma.to_evar_map sigma in + { Evd.it = evk ; sigma = sigma; } (* Used by the compatibility layer and typeclasses *) let nf_evar sigma gl = diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 29002af9e0..c50535a17a 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -64,8 +64,10 @@ type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = let gr = lazy (try_find_global_reference dir s) in - fun (evd,cstrs) -> - let evd, c = Evarutil.new_global evd (Lazy.force gr) in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in + let evd = Sigma.to_evar_map sigma in (evd, cstrs), c (** Utility for dealing with polymorphic applications *) @@ -172,13 +174,17 @@ end) = struct let proper_type = let l = lazy (Lazy.force proper_class).cl_impl in fun (evd,cstrs) -> - let evd, c = Evarutil.new_global evd (Lazy.force l) in + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in (evd, cstrs), c let proper_proxy_type = let l = lazy (Lazy.force proper_proxy_class).cl_impl in fun (evd,cstrs) -> - let evd, c = Evarutil.new_global evd (Lazy.force l) in + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in (evd, cstrs), c let proper_proof env evars carrier relation x = @@ -347,7 +353,9 @@ end) = struct (try let params, args = Array.chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in - let evars, (evar, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let evars = Sigma.to_evar_map sigma in let evars, inst = app_poly env (evars,Evar.Set.empty) rewrite_relation_class [| evar; mkApp (c, params) |] in @@ -407,7 +415,9 @@ module TypeGlobal = struct let inverse env (evd,cstrs) car rel = - let evd, sort = Evarutil.new_Type ~rigid:Evd.univ_flexible env evd in + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in + let evd = Sigma.to_evar_map sigma in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index aeb3726a0c..46e8798543 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -163,14 +163,13 @@ let _ = does not check anything. *) let unsafe_intro env store (id, c, t) b = Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in let ctx = named_context_val env in let nctx = push_named_context_val (id, c, t) ctx in let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar id) b in - let sigma, ev = new_evar_instance nctx sigma nb ~principal:true ~store ninst in - Sigma.Unsafe.of_pair (mkNamedLambda_or_LetIn (id, c, t) ev, sigma) + let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in + Sigma (mkNamedLambda_or_LetIn (id, c, t) ev, sigma, p) end } let introduction ?(check=true) id = @@ -344,9 +343,7 @@ let rename_hyp repl = let nctx = Environ.val_of_named_context nhyps in let instance = List.map (fun (id, _, _) -> mkVar id) hyps in Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = Evarutil.new_evar_instance nctx sigma nconcl ~store instance in - Sigma.Unsafe.of_pair (c, sigma) + Evarutil.new_evar_instance nctx sigma nconcl ~store instance end } end } diff --git a/toplevel/record.ml b/toplevel/record.ml index 7ae2030343..480e97169c 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -24,6 +24,7 @@ open Type_errors open Constrexpr open Constrexpr_ops open Goptions +open Sigma.Notations (********** definition d'un record (structure) **************) @@ -336,11 +337,15 @@ let structure_signature ctx = match l with [] -> Evd.empty | [(_,_,typ)] -> let env = Environ.empty_named_context_val in - let (evm, _) = Evarutil.new_pure_evar env evm typ in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm typ in + let evm = Sigma.to_evar_map evm in evm | (_,_,typ)::tl -> let env = Environ.empty_named_context_val in - let (evm, ev) = Evarutil.new_pure_evar env evm typ in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm typ in + let evm = Sigma.to_evar_map evm in let new_tl = Util.List.map_i (fun pos (n,c,t) -> n,c, Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in -- cgit v1.2.3 From 1a8c37ca352c95b4cd530efbbf47f0e7671d1fb3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 13:31:54 +0100 Subject: Renaming functions in Typing to stick to the standard e_* scheme. --- plugins/cc/cctac.ml | 2 +- plugins/decl_mode/decl_proof_instr.ml | 4 ++-- plugins/micromega/coq_micromega.ml | 2 +- plugins/setoid_ring/newring.ml | 8 ++++---- pretyping/coercion.ml | 2 +- pretyping/typing.ml | 8 ++++---- pretyping/typing.mli | 6 +++--- proofs/proofview.ml | 8 ++++---- tactics/evar_tactics.ml | 2 +- tactics/rewrite.ml | 4 ++-- tactics/tacinterp.ml | 2 +- tactics/tactics.ml | 6 +++--- toplevel/command.ml | 4 ++-- 13 files changed, 29 insertions(+), 29 deletions(-) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 09d9cf0195..bea449c31a 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -47,7 +47,7 @@ let whd_delta env= (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = sort_of env (ref sigma) c +let sf_of env sigma c = e_sort_of env (ref sigma) c let rec decompose_term env sigma t= match kind_of_term (whd env t) with diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index f47b355417..47d8eeca28 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -404,7 +404,7 @@ let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in - let sort = family_of_sort (Typing.sort_of env (ref evd) concl) in + let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in let rec aux env avoid subst = function [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") | (n,typ)::rest -> @@ -412,7 +412,7 @@ let concl_refiner metas body gls = let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (_x,None,_A) env in - let asort = family_of_sort (Typing.sort_of nenv (ref evd) _A) in + let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) _A) in let nsubst = (n,mkVar _x)::subst in if List.is_empty rest then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 1dd53a3fd8..27daa7e3c6 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1170,7 +1170,7 @@ struct let is_prop term = let ty = Typing.unsafe_type_of (Tacmach.pf_env gl) (Tacmach.project gl) term in - let sort = Typing.sort_of (Tacmach.pf_env gl) (ref (Tacmach.project gl)) ty in + let sort = Typing.e_sort_of (Tacmach.pf_env gl) (ref (Tacmach.project gl)) ty in Term.is_prop_sort sort in let rec xparse_formula env tg term = diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index e203b9f651..ed6db90d63 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -527,8 +527,8 @@ let ring_equality env evd (r,add,mul,opp,req) = match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let setoid = Typing.solve_evars env evd setoid in - let op_morph = Typing.solve_evars env evd op_morph in + let setoid = Typing.e_solve_evars env evd setoid in + let op_morph = Typing.e_solve_evars env evd op_morph in (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in @@ -627,7 +627,7 @@ let make_hyp_list env evd lH = (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH (plapp evd coq_nil [|carrier|]) in - let l' = Typing.solve_evars env evd l in + let l' = Typing.e_solve_evars env evd l in Evarutil.nf_evars_universes !evd l' let interp_power env evd pow = @@ -753,7 +753,7 @@ let make_term_list env evd carrier rl = let l = List.fold_right (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl (plapp evd coq_nil [|carrier|]) - in Typing.solve_evars env evd l + in Typing.e_solve_evars env evd l let carg = Tacinterp.Value.of_constr let tacarg expr = diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 489a311bc6..8dae311a9f 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -187,7 +187,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some (fun x -> let term = co x in - Typing.solve_evars env evdref term) + Typing.e_solve_evars env evdref term) in if isEvar c || isEvar c' then (* Second-order unification needed. *) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index fb0c49320f..022c85340a 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -267,7 +267,7 @@ and execute_recdef env evdref (names,lar,vdef) = and execute_array env evdref = Array.map (execute env evdref) -let check env evdref c t = +let e_check env evdref c t = let env = enrich_env env evdref in let j = execute env evdref c in if not (Evarconv.e_cumul env evdref j.uj_type t) then @@ -283,7 +283,7 @@ let unsafe_type_of env evd c = (* Sort of a type *) -let sort_of env evdref c = +let e_sort_of env evdref c = let env = enrich_env env evdref in let j = execute env evdref c in let a = e_type_judgment env evdref j in @@ -310,10 +310,10 @@ let e_type_of ?(refresh=false) env evdref c = c else j.uj_type -let solve_evars env evdref c = +let e_solve_evars env evdref c = let env = enrich_env env evdref in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) nf_evar !evdref c -let _ = Evarconv.set_solve_evars solve_evars +let _ = Evarconv.set_solve_evars e_solve_evars diff --git a/pretyping/typing.mli b/pretyping/typing.mli index dafd75231a..e524edcca8 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -24,16 +24,16 @@ val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types (** Typecheck a type and return its sort *) -val sort_of : env -> evar_map ref -> types -> sorts +val e_sort_of : env -> evar_map ref -> types -> sorts (** Typecheck a term has a given type (assuming the type is OK) *) -val check : env -> evar_map ref -> constr -> types -> unit +val e_check : env -> evar_map ref -> constr -> types -> unit (** Returns the instantiated type of a metavariable *) val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) -val solve_evars : env -> evar_map ref -> constr -> constr +val e_solve_evars : env -> evar_map ref -> constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 8008b00253..38e9cafad1 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1077,10 +1077,10 @@ struct (** Typecheck the hypotheses. *) let type_hyp (sigma, env) (na, body, t as decl) = let evdref = ref sigma in - let _ = Typing.sort_of env evdref t in + let _ = Typing.e_sort_of env evdref t in let () = match body with | None -> () - | Some body -> Typing.check env evdref body t + | Some body -> Typing.e_check env evdref body t in (!evdref, Environ.push_named decl env) in @@ -1089,12 +1089,12 @@ struct let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in (** Typecheck the conclusion *) let evdref = ref sigma in - let _ = Typing.sort_of env evdref (Evd.evar_concl info) in + let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in !evdref let typecheck_proof c concl env sigma = let evdref = ref sigma in - let () = Typing.check env evdref c concl in + let () = Typing.e_check env evdref c concl in !evdref let (pr_constrv,pr_constr) = diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 97b5ba0cc5..30e157ffd3 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -74,7 +74,7 @@ let let_evar name typ = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let sigma = ref sigma in - let _ = Typing.sort_of env sigma typ in + let _ = Typing.e_sort_of env sigma typ in let sigma = Sigma.Unsafe.of_evar_map !sigma in let id = match name with | Names.Anonymous -> diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index c50535a17a..d0a090e5c1 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -107,7 +107,7 @@ let extends_undefined evars evars' = let app_poly_check env evars f args = let (evars, cstrs), fc = f evars in let evdref = ref evars in - let t = Typing.solve_evars env evdref (mkApp (fc, args)) in + let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in (!evdref, cstrs), t let app_poly_nocheck env evars f args = @@ -1452,7 +1452,7 @@ type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = let evdref = ref sigma in - let sort = Typing.sort_of env evdref concl in + let sort = Typing.e_sort_of env evdref concl in let evars = (!evdref, Evar.Set.empty) in let evars, cstr = let prop, (evars, arrow) = diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 1112da4a0d..91711c2f74 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -812,7 +812,7 @@ let interp_may_eval f ist env sigma = function let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in let evdref = ref sigma in let c = subst_meta [Constr_matching.special_meta,ic] ctxt in - let c = Typing.solve_evars env evdref c in + let c = Typing.e_solve_evars env evdref c in !evdref , c with | Not_found -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 46e8798543..f76f4f6e20 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1814,7 +1814,7 @@ let check_is_type env ty msg = Proofview.tclEVARMAP >>= fun sigma -> let evdref = ref sigma in try - let _ = Typing.sort_of env evdref ty in + let _ = Typing.e_sort_of env evdref ty in Proofview.Unsafe.tclEVARS !evdref with e when Errors.noncritical e -> msg e @@ -1823,10 +1823,10 @@ let check_decl env (_, c, ty) msg = Proofview.tclEVARMAP >>= fun sigma -> let evdref = ref sigma in try - let _ = Typing.sort_of env evdref ty in + let _ = Typing.e_sort_of env evdref ty in let _ = match c with | None -> () - | Some c -> Typing.check env evdref c ty + | Some c -> Typing.e_check env evdref c ty in Proofview.Unsafe.tclEVARS !evdref with e when Errors.noncritical e -> diff --git a/toplevel/command.ml b/toplevel/command.ml index 18b2b1444d..b6313cdbab 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -1004,7 +1004,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; prop |]) in - let def = Typing.solve_evars env evdref def in + let def = Typing.e_solve_evars env evdref def in let _ = evdref := Evarutil.nf_evar_map !evdref in let def = mkApp (def, [|intern_body_lam|]) in let binders_rel = nf_evar_context !evdref binders_rel in @@ -1078,7 +1078,7 @@ let interp_recursive isfix fixl notations = let fixprot = try let app = mkApp (delayed_force fix_proto, [|sort; t|]) in - Typing.solve_evars env evdref app + Typing.e_solve_evars env evdref app with e when Errors.noncritical e -> t in (id,None,fixprot) :: env' -- cgit v1.2.3 From 15b28f0ae1e31506f3fb153fc6e50bc861717eb9 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 14:26:43 +0100 Subject: Moving conversion functions to the new tactic API. --- plugins/btauto/refl_btauto.ml | 2 +- plugins/firstorder/rules.ml | 4 +-- plugins/funind/functional_principles_proofs.ml | 4 +-- plugins/funind/invfun.ml | 10 +++--- plugins/funind/recdef.ml | 14 ++++---- plugins/omega/coq_omega.ml | 46 +++++++++++++------------- plugins/romega/refl_omega.ml | 2 +- plugins/setoid_ring/newring.ml | 4 +-- tactics/class_tactics.ml | 2 +- tactics/eauto.ml4 | 2 +- tactics/eqdecide.ml | 2 +- tactics/equality.ml | 4 +-- tactics/rewrite.ml | 4 +-- tactics/tactics.ml | 21 +++++++----- tactics/tactics.mli | 40 +++++++++++----------- toplevel/auto_ind_decl.ml | 6 ++-- 16 files changed, 85 insertions(+), 82 deletions(-) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 5a49fc8f45..57eb80f5fb 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -250,7 +250,7 @@ module Btauto = struct Tacticals.New.tclTHENLIST [ Tactics.change_concl changed_gl; Tactics.apply (Lazy.force soundness); - Proofview.V82.tactic (Tactics.normalise_vm_in_concl); + Tactics.normalise_vm_in_concl; try_unification env ] | _ -> diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index e676a8a936..d539eda579 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -210,6 +210,6 @@ let defined_connectives=lazy let normalize_evaluables= onAllHypsAndConcl (function - None->unfold_in_concl (Lazy.force defined_connectives) + None-> Proofview.V82.of_tactic (unfold_in_concl (Lazy.force defined_connectives)) | Some id -> - unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) + Proofview.V82.of_tactic (unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 4eab5f9126..aa89f89b74 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1334,7 +1334,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]; + [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); let do_prove = build_proof interactive_proof @@ -1460,7 +1460,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (fun g -> if is_mes then - unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g else tclIDTAC g ); observe_tac "rew_and_finish" diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 0c9d3bb819..ae2091a227 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -484,15 +484,15 @@ and intros_with_rewrite_aux : tactic = tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) then tclTHENSEQ[ - unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]; - tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) )) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) then tclTHENSEQ[ - unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]; - tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) )) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g @@ -703,7 +703,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = thin ids ] else - unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))] + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]) in (* The proof of each branche itself *) let ind_number = ref 0 in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index b096783412..834d0aceac 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -276,8 +276,8 @@ let tclUSER tac is_mes l g = if is_mes then observe_tclTHENLIST (str "tclUSER2") [ - unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))]; + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref))]); tac ] else tac @@ -564,8 +564,8 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = h_intros [k;h';def]; observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl); observe_tac (str "unfold functional") - (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference infos.func)]); + (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference infos.func)])); ( observe_tclTHENLIST (str "test")[ list_rewrite true @@ -904,8 +904,8 @@ let make_rewrite expr_info l hp max = (observe_tclTHENLIST (str "make_rewrite")[ simpl_iter Locusops.onConcl; observe_tac (str "unfold functional") - (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference expr_info.func)]); + (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference expr_info.func)])); (list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs)); @@ -1425,7 +1425,7 @@ let start_equation (f:global_reference) (term_f:global_reference) let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; - unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]; + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); observe_tac (str "simplest_case") (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))); diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 7e38109d67..ad63c90f27 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -927,15 +927,15 @@ let rec transform p t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in - unfold sp_Zminus :: tac,t + Proofview.V82.of_tactic (unfold sp_Zminus) :: tac,t | Kapp(Zsucc,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer one |])) in - unfold sp_Zsucc :: tac,t + Proofview.V82.of_tactic (unfold sp_Zsucc) :: tac,t | Kapp(Zpred,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer negone |])) in - unfold sp_Zpred :: tac,t + Proofview.V82.of_tactic (unfold sp_Zpred) :: tac,t | Kapp(Zmult,[t1;t2]) -> let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in @@ -1091,8 +1091,8 @@ let replay_history tactic_normalisation = in Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zle); - Proofview.V82.tactic (simpl_in_concl); + unfold sp_Zle; + simpl_in_concl; intro; (absurd not_sup_sup) ]) [ assumption ; reflexivity ] @@ -1135,10 +1135,10 @@ let replay_history tactic_normalisation = (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ - (Proofview.V82.tactic (unfold sp_Zgt)); - (Proofview.V82.tactic simpl_in_concl); + (unfold sp_Zgt); + simpl_in_concl; reflexivity ] ]; - Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (unfold sp_Zgt); Proofview.V82.tactic simpl_in_concl; reflexivity ] + Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] @@ -1160,18 +1160,18 @@ let replay_history tactic_normalisation = [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); Proofview.V82.tactic (clear [aux1;aux2]); - Proofview.V82.tactic (unfold sp_not); + unfold sp_not; (intros_using [aux]); Proofview.V82.tactic (resolve_id aux); Proofview.V82.tactic (mk_then tac); assumption ] ; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ] | EXACT_DIVIDE (e1,k) :: l -> let id = hyp_of_tag e1.id in @@ -1208,8 +1208,8 @@ let replay_history tactic_normalisation = (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] | (MERGE_EQ(e3,e1,e2)) :: l -> @@ -1329,12 +1329,12 @@ let replay_history tactic_normalisation = (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> Tacticals.New.tclTHEN (Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl @@ -1343,9 +1343,9 @@ let replay_history tactic_normalisation = | CONSTANT_NEG(e,k) :: l -> Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)]); - Proofview.V82.tactic (unfold sp_Zle); - Proofview.V82.tactic simpl_in_concl; - Proofview.V82.tactic (unfold sp_not); + unfold sp_Zle; + simpl_in_concl; + unfold sp_not; (intros_using [aux]); Proofview.V82.tactic (resolve_id aux); reflexivity @@ -1839,7 +1839,7 @@ let destructure_goal = match destructurate_prop t with | Kapp(Not,[t]) -> (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (Proofview.V82.tactic (unfold sp_not)) intro) + (Tacticals.New.tclTHEN (unfold sp_not) intro) destructure_hyps) | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 560e6a899e..177c870b3c 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -1285,7 +1285,7 @@ let resolution env full_reified_goal systems_list = Proofview.V82.of_tactic (Tactics.change_concl reified) >> Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> show_goal >> - Tactics.normalise_vm_in_concl >> + Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >> (*i Alternatives to the previous line: - Normalisation without VM: Tactics.normalise_in_concl diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index ed6db90d63..a67cc7cb87 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -99,10 +99,10 @@ let protect_red map env sigma c = (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; + Proofview.V82.of_tactic (Tactics.reduct_option (protect_red map,DEFAULTcast) None);; let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));; + Proofview.V82.of_tactic (Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)));; (****************************************************************************) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index c9b2c7cfde..3ac3daef9a 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -245,7 +245,7 @@ and e_my_find_search db_list local_db hdc complete sigma concl = Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) - | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c])) + | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]))) | Extern tacast -> conclPattern concl p tacast in let tac = Proofview.V82.of_tactic (run_hint t tac) in diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 6117c8b432..ae85f02d59 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -503,7 +503,7 @@ let autounfolds db occs cls gl = let ids = Idset.filter (fun id -> List.mem id hyps) ids in Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in unfold_option unfolds cls gl + in Proofview.V82.of_tactic (unfold_option unfolds cls) gl let autounfold db cls gl = let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index be4b135974..7c821ddcb5 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -123,7 +123,7 @@ let diseqCase hyps eqonleft = (tclTHEN (intro_using diseq) (tclTHEN (choose_noteq eqonleft) (tclTHEN (rewrite_and_clear (List.rev hyps)) - (tclTHEN (Proofview.V82.tactic red_in_concl) + (tclTHEN (red_in_concl) (tclTHEN (intro_using absurd) (tclTHEN (Simple.apply (mkVar diseq)) (tclTHEN (Extratactics.injHyp absurd) diff --git a/tactics/equality.ml b/tactics/equality.ml index 1e814e861c..c9ecc55d18 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1622,8 +1622,8 @@ let unfold_body x = let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in - let reducth h = Proofview.V82.tactic (fun gl -> reduct_in_hyp rfun h gl) in - let reductc = Proofview.V82.tactic (fun gl -> reduct_in_concl (rfun, DEFAULTcast) gl) in + let reducth h = reduct_in_hyp rfun h in + let reductc = reduct_in_concl (rfun, DEFAULTcast) in tclTHENLIST [tclMAP reducth hl; reductc] end end } diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index d0a090e5c1..8b71affffa 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1569,10 +1569,10 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = convert_concl_no_check newt DEFAULTcast in let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in - let beta = Proofview.V82.tactic (Tactics.reduct_in_concl (beta_red, DEFAULTcast)) in + let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in let opt_beta = match clause with | None -> Proofview.tclUNIT () - | Some id -> Proofview.V82.tactic (Tactics.reduct_in_hyp beta_red (id, InHyp)) + | Some id -> Tactics.reduct_in_hyp beta_red (id, InHyp) in Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f76f4f6e20..28d3ed18a1 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -470,7 +470,7 @@ let cofix ido gl = match ido with type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where (id,c,ty) gl = - let redfun' = Tacmach.pf_reduce redfun gl in + let redfun' = Tacmach.New.pf_apply redfun gl in match c with | None -> if where == InHypValueOnly then @@ -549,12 +549,15 @@ let bind_red_expr_occurrences occs nbcl redexp = reduction function either to the conclusion or to a certain hypothesis *) -let reduct_in_concl (redfun,sty) gl = - Proofview.V82.of_tactic (convert_concl_no_check (Tacmach.pf_reduce redfun gl (Tacmach.pf_concl gl)) sty) gl +let reduct_in_concl (redfun,sty) = + Proofview.Goal.nf_enter { enter = begin fun gl -> + convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty + end } -let reduct_in_hyp ?(check=false) redfun (id,where) gl = - Proofview.V82.of_tactic (convert_hyp ~check - (pf_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl)) gl +let reduct_in_hyp ?(check=false) redfun (id,where) = + Proofview.Goal.nf_enter { enter = begin fun gl -> + convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) + end } let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r @@ -798,7 +801,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = else Proofview.tclUNIT () end <*> Proofview.tclORELSE - (Tacticals.New.tclTHEN (Proofview.V82.tactic hnf_in_concl) + (Tacticals.New.tclTHEN hnf_in_concl (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with | RefinerError IntroNeedsProduct -> @@ -2728,8 +2731,8 @@ let unfold_body x gl = let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in tclTHENLIST - [tclMAP (fun h -> reduct_in_hyp rfun h) hl; - reduct_in_concl (rfun,DEFAULTcast)] gl + [tclMAP (fun h -> Proofview.V82.of_tactic (reduct_in_hyp rfun h)) hl; + Proofview.V82.of_tactic (reduct_in_concl (rfun,DEFAULTcast))] gl (* Either unfold and clear if defined or simply clear if not a definition *) let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id]) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 5564b61c37..657367e36c 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -128,38 +128,38 @@ type tactic_reduction = env -> evar_map -> constr -> constr type change_arg = patvar_map -> constr Sigma.run val make_change_arg : constr -> change_arg -val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> tactic -val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> tactic -val reduct_in_concl : tactic_reduction * cast_kind -> tactic +val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic +val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic +val reduct_in_concl : tactic_reduction * cast_kind -> unit Proofview.tactic val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic -val red_in_concl : tactic -val red_in_hyp : hyp_location -> tactic -val red_option : goal_location -> tactic -val hnf_in_concl : tactic -val hnf_in_hyp : hyp_location -> tactic -val hnf_option : goal_location -> tactic -val simpl_in_concl : tactic -val simpl_in_hyp : hyp_location -> tactic -val simpl_option : goal_location -> tactic -val normalise_in_concl : tactic -val normalise_in_hyp : hyp_location -> tactic -val normalise_option : goal_location -> tactic -val normalise_vm_in_concl : tactic +val red_in_concl : unit Proofview.tactic +val red_in_hyp : hyp_location -> unit Proofview.tactic +val red_option : goal_location -> unit Proofview.tactic +val hnf_in_concl : unit Proofview.tactic +val hnf_in_hyp : hyp_location -> unit Proofview.tactic +val hnf_option : goal_location -> unit Proofview.tactic +val simpl_in_concl : unit Proofview.tactic +val simpl_in_hyp : hyp_location -> unit Proofview.tactic +val simpl_option : goal_location -> unit Proofview.tactic +val normalise_in_concl : unit Proofview.tactic +val normalise_in_hyp : hyp_location -> unit Proofview.tactic +val normalise_option : goal_location -> unit Proofview.tactic +val normalise_vm_in_concl : unit Proofview.tactic val unfold_in_concl : - (occurrences * evaluable_global_reference) list -> tactic + (occurrences * evaluable_global_reference) list -> unit Proofview.tactic val unfold_in_hyp : - (occurrences * evaluable_global_reference) list -> hyp_location -> tactic + (occurrences * evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic val unfold_option : - (occurrences * evaluable_global_reference) list -> goal_location -> tactic + (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : constr_pattern option -> change_arg -> clause -> tactic val pattern_option : (occurrences * constr) list -> goal_location -> tactic val reduce : red_expr -> clause -> tactic -val unfold_constr : global_reference -> tactic +val unfold_constr : global_reference -> unit Proofview.tactic (** {6 Modification of the local context. } *) diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index f0c7a39613..c143243b1d 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -580,7 +580,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclTRY ( Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) ); - Proofview.V82.tactic (simpl_in_hyp (freshz,Locus.InHyp)); + simpl_in_hyp (freshz,Locus.InHyp); (* repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). *) @@ -724,7 +724,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) ); Equality.inj None false None (mkVar freshz,NoBindings); - intros; (Proofview.V82.tactic simpl_in_concl); + intros; simpl_in_concl; Auto.default_auto; Tacticals.New.tclREPEAT ( Tacticals.New.tclTHENLIST [apply (andb_true_intro()); @@ -901,7 +901,7 @@ let compute_dec_tact ind lnamesparrec nparrec = let freshH3 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENLIST [ simplest_right ; - Proofview.V82.tactic (unfold_constr (Lazy.force Coqlib.coq_not_ref)); + unfold_constr (Lazy.force Coqlib.coq_not_ref); intro; Equality.subst_all (); assert_by (Name freshH3) -- cgit v1.2.3 From 4ea9b3193eaced958bb277c0723fb54d661ff520 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 15:17:05 +0100 Subject: More conversion functions in the new tactic API. --- plugins/funind/functional_principles_proofs.ml | 8 ++--- plugins/funind/indfun.ml | 2 +- plugins/funind/invfun.ml | 16 +++++----- plugins/funind/recdef.ml | 4 +-- tactics/auto.ml | 2 +- tactics/eauto.ml4 | 2 +- tactics/tacinterp.ml | 2 +- tactics/tactics.ml | 42 ++++++++++++++------------ tactics/tactics.mli | 4 +-- 9 files changed, 42 insertions(+), 40 deletions(-) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index aa89f89b74..86302dc6ce 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -371,12 +371,12 @@ let isLetIn t = | _ -> false -let h_reduce_with_zeta = - reduce +let h_reduce_with_zeta cl = + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; - }) + }) cl) @@ -707,7 +707,7 @@ let build_proof [ generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; - pattern_option [Locus.AllOccurrencesBut [1],t] None; + Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); (fun g -> observe_tac "toto" ( tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d1e1098259..41fd0bd18e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -113,7 +113,7 @@ let functional_induction with_clean c princl pat = in Tacticals.tclTHEN (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) - (Tactics.reduce flag Locusops.allHypsAndConcl) + (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl)) g else Tacticals.tclIDTAC g in diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index ae2091a227..2b45206bb4 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -363,14 +363,14 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* unfolding of all the defined variables introduced by this branch *) (* observe_tac "unfolding" pre_tac; *) (* $zeta$ normalizing of the conclusion *) - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false ; Genredexpr.rConst = [] } ) - Locusops.onConcl; + Locusops.onConcl); observe_tac ("toto ") tclIDTAC; (* introducing the the result of the graph and the equality hypothesis *) @@ -532,12 +532,12 @@ and intros_with_rewrite_aux : tactic = ] g | LetIn _ -> tclTHENSEQ[ - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) - Locusops.onConcl + Locusops.onConcl) ; intros_with_rewrite ] g @@ -547,12 +547,12 @@ and intros_with_rewrite_aux : tactic = end | LetIn _ -> tclTHENSEQ[ - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) - Locusops.onConcl + Locusops.onConcl) ; intros_with_rewrite ] g @@ -692,12 +692,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) - Locusops.onConcl + Locusops.onConcl) ; generalize (List.map mkVar ids); thin ids diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 834d0aceac..6c6caa6284 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -562,7 +562,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = observe_tclTHENLIST (str "destruct_bounds_aux2")[ observe_tac (str "clearing k ") (clear [id]); h_intros [k;h';def]; - observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl); + observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); observe_tac (str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference infos.func)])); @@ -902,7 +902,7 @@ let make_rewrite expr_info l hp max = [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ - simpl_iter Locusops.onConcl; + Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); observe_tac (str "unfold functional") (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference expr_info.func)])); diff --git a/tactics/auto.ml b/tactics/auto.ml index 6caebf6c4f..1d6cd8e99b 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -390,7 +390,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) | Unfold_nth c -> Proofview.V82.tactic (fun gl -> if exists_evaluable_reference (pf_env gl) c then - tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) gl + tclPROGRESS (Proofview.V82.of_tactic (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl)) gl else tclFAIL 0 (str"Unbound reference") gl) | Extern tacast -> conclPattern concl p tacast diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index ae85f02d59..f2d26ec86b 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -198,7 +198,7 @@ and e_my_find_search db_list local_db hdc concl = | Res_pf_THEN_trivial_fail (term,cl) -> Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> Proofview.V82.tactic (reduce (Unfold [AllOccurrences,c]) onConcl) + | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl | Extern tacast -> conclPattern concl p tacast in let tac = run_hint t tac in diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 91711c2f74..73aa4c3373 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1967,7 +1967,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in tclTHEN (tclEVARS sigma) - (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) + (Proofview.V82.of_tactic (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl))) gl end end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 28d3ed18a1..210888b67c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -569,8 +569,8 @@ let reduct_option ?(check=false) redfun = function (** Tactic reduction modulo evars (for universes essentially) *) let pf_e_reduce_decl redfun where (id,c,ty) gl = - let sigma = project gl in - let redfun = redfun (pf_env gl) in + let sigma = Tacmach.New.project gl in + let redfun = redfun (Tacmach.New.pf_env gl) in match c with | None -> if where == InHypValueOnly then @@ -582,17 +582,17 @@ let pf_e_reduce_decl redfun where (id,c,ty) gl = let sigma, ty' = if where != InHypValueOnly then redfun sigma ty else sigma, ty in sigma, (id,Some b',ty') -let e_reduct_in_concl (redfun,sty) gl = - Proofview.V82.of_tactic - (let sigma, c' = (Tacmach.pf_apply redfun gl (Tacmach.pf_concl gl)) in - Proofview.Unsafe.tclEVARS sigma <*> - convert_concl_no_check c' sty) gl +let e_reduct_in_concl (redfun, sty) = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma, c' = Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl) in + Sigma.Unsafe.of_pair (convert_concl_no_check c' sty, sigma) + end } -let e_reduct_in_hyp ?(check=false) redfun (id,where) gl = - Proofview.V82.of_tactic - (let sigma, decl' = pf_e_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl in - Proofview.Unsafe.tclEVARS sigma <*> - convert_hyp ~check decl') gl +let e_reduct_in_hyp ?(check=false) redfun (id, where) = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma, decl' = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + Sigma.Unsafe.of_pair (convert_hyp ~check decl', sigma) + end } let e_reduct_option ?(check=false) redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id @@ -739,14 +739,16 @@ let reduction_clause redexp cl = | OnConcl occs -> (None, bind_red_expr_occurrences occs nbcl redexp)) cl -let reduce redexp cl goal = - let cl = concrete_clause_of (fun () -> Tacmach.pf_ids_of_hyps goal) cl in +let reduce redexp cl = + Proofview.Goal.enter { enter = begin fun gl -> + let cl = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let redexps = reduction_clause redexp cl in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in - let tac = tclMAP (fun (where,redexp) -> + let tac = Tacticals.New.tclMAP (fun (where,redexp) -> e_reduct_option ~check - (Redexpr.reduction_of_red_expr (Tacmach.pf_env goal) redexp) where) redexps in - if check then with_check tac goal else tac goal + (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps in + if check then Proofview.V82.tactic (fun gl -> with_check (Proofview.V82.of_tactic tac) gl) else tac (** FIXME *) + end } (* Unfolding occurrences of a constant *) @@ -3943,7 +3945,7 @@ let induction_without_atomization isrec with_evars elim names lid = if indvars = [] then [List.hd lid_params] else indvars in let induct_tac elim = Proofview.V82.tactic (tclTHENLIST [ (* pattern to make the predicate appear. *) - reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; + Proofview.V82.of_tactic (reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl); (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all possible holes using arguments given by the user (but the functional one). *) @@ -4717,9 +4719,9 @@ module New = struct open Locus let reduce_after_refine = - Proofview.V82.tactic (reduce + reduce (Lazy {rBeta=true;rIota=true;rZeta=false;rDelta=false;rConst=[]}) - {onhyps=None; concl_occs=AllOccurrences }) + {onhyps=None; concl_occs=AllOccurrences } let refine ?unsafe c = Proofview.Refine.refine ?unsafe c <*> diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 657367e36c..367430d918 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -157,8 +157,8 @@ val unfold_option : val change : constr_pattern option -> change_arg -> clause -> tactic val pattern_option : - (occurrences * constr) list -> goal_location -> tactic -val reduce : red_expr -> clause -> tactic + (occurrences * constr) list -> goal_location -> unit Proofview.tactic +val reduce : red_expr -> clause -> unit Proofview.tactic val unfold_constr : global_reference -> unit Proofview.tactic (** {6 Modification of the local context. } *) -- cgit v1.2.3 From 4689c62b791ae384f2f603c7f22d5088eafa1d3e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 15:53:25 +0100 Subject: Code factorization of tactic "unfold_body". --- tactics/equality.ml | 20 -------------------- tactics/tactics.ml | 31 ++++++++++++++++++------------- tactics/tactics.mli | 2 +- 3 files changed, 19 insertions(+), 34 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index c9ecc55d18..b287eb8e57 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1608,26 +1608,6 @@ user = raise user error specific to rewrite (**********************************************************************) (* Substitutions tactics (JCF) *) -let unfold_body x = - Proofview.Goal.enter { enter = begin fun gl -> - (** We normalize the given hypothesis immediately. *) - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let (_, xval, _) = Context.Named.lookup x hyps in - let xval = match xval with - | None -> errorlabstrm "unfold_body" - (pr_id x ++ str" is not a defined hypothesis.") - | Some xval -> pf_nf_evar gl xval - in - afterHyp x begin fun aft -> - let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in - let xvar = mkVar x in - let rfun _ _ c = replace_term xvar xval c in - let reducth h = reduct_in_hyp rfun h in - let reductc = reduct_in_concl (rfun, DEFAULTcast) in - tclTHENLIST [tclMAP reducth hl; reductc] - end - end } - let restrict_to_eq_and_identity eq = (* compatibility *) if not (is_global glob_eq eq) && not (is_global glob_identity eq) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 210888b67c..e363538471 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2721,23 +2721,28 @@ let specialize (c,lbind) = (* The two following functions should already exist, but found nowhere *) (* Unfolds x by its definition everywhere *) -let unfold_body x gl = - let hyps = pf_hyps gl in - let xval = - match Context.Named.lookup x hyps with - (_,Some xval,_) -> xval - | _ -> errorlabstrm "unfold_body" - (pr_id x ++ str" is not a defined hypothesis.") in - let aft = afterHyp x gl in +let unfold_body x = + Proofview.Goal.enter { enter = begin fun gl -> + (** We normalize the given hypothesis immediately. *) + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let (_, xval, _) = Context.Named.lookup x hyps in + let xval = match xval with + | None -> errorlabstrm "unfold_body" + (pr_id x ++ str" is not a defined hypothesis.") + | Some xval -> pf_nf_evar gl xval + in + Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in - tclTHENLIST - [tclMAP (fun h -> Proofview.V82.of_tactic (reduct_in_hyp rfun h)) hl; - Proofview.V82.of_tactic (reduct_in_concl (rfun,DEFAULTcast))] gl + let reducth h = reduct_in_hyp rfun h in + let reductc = reduct_in_concl (rfun, DEFAULTcast) in + Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] + end + end } (* Either unfold and clear if defined or simply clear if not a definition *) -let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id]) +let expand_hyp id = Tacticals.New.tclTHEN (Tacticals.New.tclTRY (unfold_body id)) (Proofview.V82.tactic (clear [id])) (*****************************) (* High-level induction *) @@ -3891,7 +3896,7 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = if deps = [] then Proofview.tclUNIT () else apply_type tmpcl deps_cstr; (* side-conditions in elim (resp case) schemes come last (resp first) *) induct_tac elim; - Proofview.V82.tactic (tclMAP expand_hyp toclear) + Tacticals.New.tclMAP expand_hyp toclear; ]) (Array.map2 (induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists)) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 367430d918..26ea017696 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -165,7 +165,7 @@ val unfold_constr : global_reference -> unit Proofview.tactic val clear : Id.t list -> tactic val clear_body : Id.t list -> unit Proofview.tactic -val unfold_body : Id.t -> tactic +val unfold_body : Id.t -> unit Proofview.tactic val keep : Id.t list -> unit Proofview.tactic val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic -- cgit v1.2.3 From 4f041384cb27f0d24fa14b272884b4b7f69cacbe Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 15 Feb 2016 11:55:43 +0100 Subject: CLEANUP: Simplifying the changes done in "kernel/*" ... ... ... ... ... ... ... ... ... ... ... ... ... ... --- kernel/closure.ml | 11 +++++++---- kernel/cooking.ml | 5 ++--- kernel/csymtable.ml | 8 ++++---- kernel/declareops.ml | 31 +++++-------------------------- kernel/environ.ml | 17 ++++++----------- kernel/fast_typeops.ml | 3 +-- kernel/inductive.ml | 2 +- kernel/nativecode.ml | 8 ++++---- 8 files changed, 30 insertions(+), 55 deletions(-) diff --git a/kernel/closure.ml b/kernel/closure.ml index dc98cc65d0..4476fe5241 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -245,10 +245,12 @@ and 'a infos = { let info_flags info = info.i_flags let info_env info = info.i_cache.i_env +open Context.Named.Declaration + let rec assoc_defined id = function | [] -> raise Not_found -| Context.Named.Declaration.LocalAssum _ :: ctxt -> assoc_defined id ctxt -| Context.Named.Declaration.LocalDef (id', c, _) :: ctxt -> +| LocalAssum _ :: ctxt -> assoc_defined id ctxt +| LocalDef (id', c, _) :: ctxt -> if Id.equal id id' then c else assoc_defined id ctxt let ref_value_cache ({i_cache = cache} as infos) ref = @@ -285,9 +287,10 @@ let defined_rels flags env = let ctx = rel_context env in let len = List.length ctx in let ans = Array.make len None in + let open Context.Rel.Declaration in let iter i = function - | Context.Rel.Declaration.LocalAssum _ -> () - | Context.Rel.Declaration.LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b) + | LocalAssum _ -> () + | LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b) in let () = List.iteri iter ctx in ans diff --git a/kernel/cooking.ml b/kernel/cooking.ml index d2106f8609..86d786b09a 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -203,9 +203,8 @@ let cook_constant env { from = cb; info } = let const_hyps = Context.Named.fold_outside (fun decl hyps -> let open Context.Named.Declaration in - let h = get_id decl in - List.filter (fun decl -> let id = get_id decl in - not (Id.equal id h)) hyps) + List.filter (fun decl' -> not (Id.equal (get_id decl) (get_id decl'))) + hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with | RegularArity t -> diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index cfbb89f06c..9d58f66154 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -190,8 +190,8 @@ and slot_for_fv env fv = begin match force_lazy_val nv with | None -> let open Context.Named in - let open Context.Named.Declaration in - fill_fv_cache nv id val_of_named idfun (lookup id env.env_named_context |> get_value) + let open Declaration in + env.env_named_context |> lookup id |> get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> @@ -199,8 +199,8 @@ and slot_for_fv env fv = begin match force_lazy_val rv with | None -> let open Context.Rel in - let open Context.Rel.Declaration in - fill_fv_cache rv i val_of_rel env_of_rel (lookup i env.env_rel_context |> get_value) + let open Declaration in + env.env_rel_context |> lookup i |> get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end | FVuniv_var idu -> diff --git a/kernel/declareops.ml b/kernel/declareops.ml index cb67135ad4..a09a8b7862 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -9,6 +9,7 @@ open Declarations open Mod_subst open Util +open Context.Rel.Declaration (** Operations concernings types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) @@ -87,18 +88,8 @@ let is_opaque cb = match cb.const_body with (** {7 Constant substitutions } *) -let subst_rel_declaration sub x = - let open Context.Rel.Declaration in - match x with - | LocalAssum (id,t) -> - let t' = subst_mps sub t in - if t == t' then x - else LocalAssum (id,t') - | LocalDef (id,v,t) -> - let v' = subst_mps sub v in - let t' = subst_mps sub t in - if v == v' && t == t' then x - else LocalDef (id,v',t') +let subst_rel_declaration sub = + map_constr (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) @@ -148,20 +139,8 @@ let subst_const_body sub cb = share internal fields (e.g. constr), and not the records themselves. But would it really bring substantial gains ? *) -let hcons_rel_decl d = - let open Context.Rel.Declaration in - match d with - | LocalAssum (n,t) -> - let n' = Names.Name.hcons n - and t' = Term.hcons_types t in - if n' == n && t' == t then d - else LocalAssum (n',t') - | LocalDef (n,v,t) -> - let n' = Names.Name.hcons n - and v' = Term.hcons_constr v - and t' = Term.hcons_types t in - if n' == n && v' == v && t' == t then d - else LocalDef (n',v',t') +let hcons_rel_decl = + map_type Term.hcons_types % map_value Term.hcons_constr % map_name Names.Name.hcons let hcons_rel_context l = List.smartmap hcons_rel_decl l diff --git a/kernel/environ.ml b/kernel/environ.ml index 1089dff92c..d8493d9baf 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -27,6 +27,7 @@ open Term open Vars open Declarations open Pre_env +open Context.Rel.Declaration (* The type of environments. *) @@ -72,8 +73,7 @@ let lookup_rel n env = Context.Rel.lookup n env.env_rel_context let evaluable_rel n env = - let open Context.Rel.Declaration in - lookup_rel n env |> is_local_def + is_local_def (lookup_rel n env) let nb_rel env = env.env_nb_rel @@ -82,7 +82,6 @@ let push_rel = push_rel let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = - let open Context.Rel.Declaration in let ctxt = Array.map2_i (fun i na t -> LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt @@ -128,11 +127,13 @@ let eq_named_context_val c1 c2 = (* A local const is evaluable if it is defined *) +open Context.Named.Declaration + let named_type id env = - lookup_named id env |> Context.Named.Declaration.get_type + get_type (lookup_named id env) let named_body id env = - lookup_named id env |> Context.Named.Declaration.get_value + get_value (lookup_named id env) let evaluable_named id env = match named_body id env with @@ -417,7 +418,6 @@ let global_vars_set env constr = contained in the types of the needed variables. *) let really_needed env needed = - let open Context.Named.Declaration in Context.Named.fold_inside (fun need decl -> if Id.Set.mem (get_id decl) need then @@ -436,7 +436,6 @@ let keep_hyps env needed = let really_needed = really_needed env needed in Context.Named.fold_outside (fun d nsign -> - let open Context.Named.Declaration in if Id.Set.mem (get_id d) really_needed then Context.Named.add d nsign else nsign) (named_context env) @@ -487,7 +486,6 @@ let compile_constant_body = Cbytegen.compile_constant_body false exception Hyp_not_found let apply_to_hyp (ctxt,vals) id f = - let open Context.Named.Declaration in let rec aux rtail ctxt vals = match ctxt, vals with | d::ctxt, v::vals -> @@ -501,7 +499,6 @@ let apply_to_hyp (ctxt,vals) id f = in aux [] ctxt vals let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = - let open Context.Named.Declaration in let rec aux ctxt vals = match ctxt,vals with | d::ctxt, v::vals -> @@ -516,7 +513,6 @@ let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = in aux ctxt vals let insert_after_hyp (ctxt,vals) id d check = - let open Context.Named.Declaration in let rec aux ctxt vals = match ctxt, vals with | decl::ctxt', v::vals' -> @@ -533,7 +529,6 @@ let insert_after_hyp (ctxt,vals) id d check = (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value (ctxt, vals) = - let open Context.Named.Declaration in let rec remove_hyps ctxt vals = match ctxt, vals with | [], [] -> [], [] | d :: rctxt, (nid, v) :: rvals -> diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index df95c93dc5..7f4ba8ecbe 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -74,8 +74,7 @@ let judge_of_type u = let judge_of_relative env n = try let open Context.Rel.Declaration in - let typ = get_type (lookup_rel n env) in - lift n typ + env |> lookup_rel n |> get_type |> lift n with Not_found -> error_unbound_rel env n diff --git a/kernel/inductive.ml b/kernel/inductive.ml index ca29d83f6a..229508ea34 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -319,7 +319,7 @@ let is_correct_arity env c pj ind specif params = let () = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in - srec (push_rel (LocalAssum (na1,a1)) env) t ar' + srec (push_rel (LocalAssum (na1,a1)) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (LocalAssum (na1,a1)) env in diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 47274a5cd5..dabe905dee 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1832,10 +1832,10 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = - let decl = Context.Rel.lookup n env.env_rel_context in - let n = Context.Rel.length env.env_rel_context - n in - let open Context.Rel.Declaration in - match decl with + let open Context.Rel in + let n = length env.env_rel_context - n in + let open Declaration in + match lookup n env.env_rel_context with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in -- cgit v1.2.3 From 5180ab68819f10949cd41a2458bff877b3ec3204 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 16:45:18 +0100 Subject: Using monotonic types for conversion functions. --- plugins/funind/recdef.ml | 5 ++-- pretyping/reductionops.ml | 2 +- pretyping/reductionops.mli | 2 +- pretyping/tacred.ml | 24 ++++++++++----- pretyping/tacred.mli | 3 +- proofs/redexpr.ml | 2 +- proofs/tacmach.ml | 6 +++- tactics/extratactics.ml4 | 5 ++-- tactics/rewrite.ml | 4 ++- tactics/tacinterp.ml | 5 +++- tactics/tactics.ml | 74 +++++++++++++++++++++++----------------------- toplevel/command.ml | 13 +++++--- toplevel/vernacentries.ml | 8 ++++- 13 files changed, 90 insertions(+), 63 deletions(-) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 6c6caa6284..555f08fa86 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -690,9 +690,8 @@ let mkDestructEq : [generalize new_hyps; (fun g2 -> let changefun patvars = { run = fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in - Sigma.Unsafe.of_pair (c, sigma) + let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in + redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 5e21154a67..a677458dab 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -572,7 +572,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = env -> evar_map -> constr -> evar_map * constr +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index e65ab83b29..b38252e971 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -108,7 +108,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = env -> evar_map -> constr -> evar_map * constr +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 085aaf78a1..be95de873e 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -963,10 +963,12 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> mkApp (app', [| a' |])) | _ -> map_constr_with_binders_left_to_right g f acc c -let e_contextually byhead (occs,c) f env sigma t = +let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in + let sigma = Sigma.to_evar_map sigma in + (** FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t @@ -985,8 +987,8 @@ let e_contextually byhead (occs,c) f env sigma t = (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); - let evm, t = f subst env !evd t in - (evd := evm; t) + let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in + (evd := Sigma.to_evar_map evm; t) end else traverse_below nested envc t @@ -1005,11 +1007,15 @@ let e_contextually byhead (occs,c) f env sigma t = in let t' = traverse None (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - !evd, t' + Sigma.Unsafe.of_pair (t', !evd) + end } let contextually byhead occs f env sigma t = - let f' subst env sigma t = sigma, f subst env sigma t in - snd (e_contextually byhead occs f' env sigma t) + let f' subst = { e_redfun = begin fun env sigma t -> + Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma + end } in + let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in + c (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurrence of name. @@ -1128,13 +1134,15 @@ let abstract_scheme env (locc,a) (c, sigma) = let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in mkLambda (na,ta,c'), sigma' -let pattern_occs loccs_trm env sigma c = +let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> + let sigma = Sigma.to_evar_map sigma in let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in try let _ = Typing.unsafe_type_of env sigma abstr_trm in - sigma, applist(abstr_trm, List.map snd loccs_trm) + Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) + end } (* Used in several tactics. *) diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 6a7248e197..195b21bbf2 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -61,8 +61,7 @@ val unfoldn : val fold_commands : constr list -> reduction_function (** Pattern *) -val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> - evar_map * constr +val pattern_occs : (occurrences * constr) list -> e_reduction_function (** Rem: Lazy strategies are defined in Reduction *) diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 818805a56c..2d886b8e1f 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -194,7 +194,7 @@ let out_arg = function let out_with_occurrences (occs,c) = (Locusops.occurrences_map (List.map out_arg) occs, c) -let e_red f env evm c = evm, f env evm c +let e_red f = { e_redfun = fun env evm c -> Sigma.here (f env (Sigma.to_evar_map evm) c) evm } let head_style = false (* Turn to true to have a semantics where simpl only reduce at the head when an evaluable reference is given, e.g. diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a1ebacea84..a10d8fd2f7 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -18,6 +18,7 @@ open Tacred open Proof_type open Logic open Refiner +open Sigma.Notations let re_sig it gc = { it = it; sigma = gc; } @@ -70,7 +71,10 @@ let pf_get_new_ids ids gls = let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id let pf_reduction_of_red_expr gls re c = - (fst (reduction_of_red_expr (pf_env gls) re)) (pf_env gls) (project gls) c + let (redfun, _) = reduction_of_red_expr (pf_env gls) re in + let sigma = Sigma.Unsafe.of_evar_map (project gls) in + let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in + (Sigma.to_evar_map sigma, c) let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 930cfebf4c..cdf29e4c62 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -724,8 +724,9 @@ let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - change_concl - (snd (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl)) + (** FIXME: this looks really wrong. Does anybody really use this tactic? *) + let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in + change_concl c end }; simplest_case a] end } diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 8b71affffa..4fa5ccf35a 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1370,7 +1370,9 @@ module Strategies = let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> let rfn, ckind = Redexpr.reduction_of_red_expr env r in - let evars', t' = rfn env (goalevars evars) t in + let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in + let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in + let evars' = Sigma.to_evar_map sigma in if eq_constr t' t then state, Identity else diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 73aa4c3373..edad75339e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -805,7 +805,10 @@ let interp_may_eval f ist env sigma = function | ConstrEval (r,c) -> let (sigma,redexp) = interp_red_expr ist env sigma r in let (sigma,c_interp) = f ist env sigma c in - (fst (Redexpr.reduction_of_red_expr env redexp) env sigma c_interp) + let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in + (Sigma.to_evar_map sigma, c) | ConstrContext ((loc,s),c) -> (try let (sigma,ic) = f ist env sigma c in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e363538471..6d589f46f7 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -569,29 +569,30 @@ let reduct_option ?(check=false) redfun = function (** Tactic reduction modulo evars (for universes essentially) *) let pf_e_reduce_decl redfun where (id,c,ty) gl = - let sigma = Tacmach.New.project gl in - let redfun = redfun (Tacmach.New.pf_env gl) in + let sigma = Proofview.Goal.sigma gl in + let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in match c with | None -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); - let sigma, ty' = redfun sigma ty in - sigma, (id,None,ty') + let Sigma (ty', sigma, p) = redfun sigma ty in + Sigma ((id, None, ty'), sigma, p) | Some b -> - let sigma, b' = if where != InHypTypeOnly then redfun sigma b else sigma, b in - let sigma, ty' = if where != InHypValueOnly then redfun sigma ty else sigma, ty in - sigma, (id,Some b',ty') + let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in + let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in + Sigma ((id, Some b', ty'), sigma, p +> q) let e_reduct_in_concl (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let sigma, c' = Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl) in - Sigma.Unsafe.of_pair (convert_concl_no_check c' sty, sigma) + let sigma = Proofview.Goal.sigma gl in + let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in + Sigma (convert_concl_no_check c' sty, sigma, p) end } let e_reduct_in_hyp ?(check=false) redfun (id, where) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let sigma, decl' = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in - Sigma.Unsafe.of_pair (convert_hyp ~check decl', sigma) + let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + Sigma (convert_hyp ~check decl', sigma, p) end } let e_reduct_option ?(check=false) redfun = function @@ -604,9 +605,8 @@ let e_reduct_option ?(check=false) redfun = function let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in - Sigma.Unsafe.of_pair (convert_concl_no_check c sty, sigma) + let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in + Sigma (convert_concl_no_check c sty, sigma, p) end } let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma = @@ -614,24 +614,23 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env | None -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); - let sigma',ty' = redfun false env sigma ty in - sigma', (id,None,ty') + let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in + Sigma ((id, None, ty'), sigma, p) | Some b -> - let sigma',b' = - if where != InHypTypeOnly then redfun true env sigma b else sigma, b + let Sigma (b', sigma, p) = + if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma in - let sigma',ty' = - if where != InHypValueOnly then redfun false env sigma' ty else sigma', ty + let Sigma (ty', sigma, q) = + if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma in - sigma', (id,Some b',ty') + Sigma ((id, Some b', ty'), sigma, p +> q) let e_change_in_hyp redfun (id,where) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in - let sigma, c = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in - Sigma.Unsafe.of_pair (convert_hyp c, sigma) + let Sigma (c, sigma, p) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + Sigma (convert_hyp c, sigma, p) end } type change_arg = Pattern.patvar_map -> constr Sigma.run @@ -661,32 +660,33 @@ let check_types env sigma mayneedglobalcheck deep newc origc = else sigma (* Now we introduce different instances of the previous tacticals *) -let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = - let sigma = Sigma.Unsafe.of_evar_map sigma in +let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> let Sigma (t', sigma, p) = t.run sigma in let sigma = Sigma.to_evar_map sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); - sigma, t' + Sigma.Unsafe.of_pair (t', sigma) +end } (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm cv_pb deep t where env sigma c = +let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> let mayneedglobalcheck = ref false in - let sigma,c = match where with - | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + let Sigma (c, sigma, p) = match where with + | None -> (change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty)).e_redfun env sigma c | Some occl -> - e_contextually false occl + (e_contextually false occl (fun subst -> - change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) + change_and_check Reduction.CONV mayneedglobalcheck true (t subst))).e_redfun env sigma c in if !mayneedglobalcheck then begin - try ignore (Typing.unsafe_type_of env sigma c) + try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; - sigma,c + Sigma (c, sigma, p) +end } let change_in_concl occl t = e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) @@ -924,9 +924,9 @@ let lookup_hypothesis_as_renamed_gen red h gl = let rec aux ccl = match lookup_hypothesis_as_renamed env ccl h with | None when red -> - aux - (snd ((fst (Redexpr.reduction_of_red_expr env (Red true))) - env (Sigma.to_evar_map (Proofview.Goal.sigma gl)) ccl)) + let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in + let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in + aux c | x -> x in try aux (Proofview.Goal.concl gl) diff --git a/toplevel/command.ml b/toplevel/command.ml index b6313cdbab..aa5f7a6927 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -36,12 +36,13 @@ open Evarconv open Indschemes open Misctypes open Vernacexpr +open Sigma.Notations let do_universe poly l = Declare.do_universe poly l let do_constraint poly l = Declare.do_constraint poly l let rec under_binders env sigma f n c = - if Int.equal n 0 then snd (f env sigma c) else + if Int.equal n 0 then f env sigma c else match kind_of_term c with | Lambda (x,t,c) -> mkLambda (x,t,under_binders (push_rel (x,None,t) env) sigma f (n-1) c) @@ -71,10 +72,14 @@ let red_constant_entry n ce sigma = function | Some red -> let proof_out = ce.const_entry_body in let env = Global.env () in + let (redfun, _) = reduction_of_red_expr env red in + let redfun env sigma c = + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, _, _) = redfun.e_redfun env sigma c in + c + in { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out - (fun ((body,ctx),eff) -> - (under_binders env sigma - (fst (reduction_of_red_expr env red)) n body,ctx),eff) } + (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } let interp_definition pl bl p red_option c ctypopt = let env = Global.env() in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 0f81943e2c..60aab09fdc 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -32,6 +32,7 @@ open Redexpr open Lemmas open Misctypes open Locality +open Sigma.Notations let debug = false let prerr_endline = @@ -1537,7 +1538,12 @@ let vernac_check_may_eval redexp glopt rc = | Some r -> Tacintern.dump_glob_red_expr r; let (sigma',r_interp) = interp_redexp env sigma' r in - let redfun env evm c = snd (fst (reduction_of_red_expr env r_interp) env evm c) in + let redfun env evm c = + let (redfun, _) = reduction_of_red_expr env r_interp in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in + c + in msg_notice (print_eval redfun env sigma' rc j) let vernac_declare_reduction locality s r = -- cgit v1.2.3 From 13e847b7092d53ffec63e4cba54c67d39560e67a Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Mon, 15 Feb 2016 23:33:01 +0100 Subject: CLEANUP: Simplifying the changes done in "checker/*" --- checker/declarations.ml | 10 ++-------- checker/indtypes.ml | 7 ++++--- checker/inductive.ml | 5 +++-- checker/term.ml | 26 +++++++++++++------------- checker/term.mli | 1 + 5 files changed, 23 insertions(+), 26 deletions(-) diff --git a/checker/declarations.ml b/checker/declarations.ml index 2f6eeba1d9..3ce3125337 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -517,14 +517,8 @@ let map_decl_arity f g = function | RegularArity a -> RegularArity (f a) | TemplateArity a -> TemplateArity (g a) -let subst_rel_declaration sub = function - | LocalAssum (id,t) as x -> - let t' = subst_mps sub t in - if t == t' then x else LocalAssum (id,t') - | LocalDef (id,c,t) as x -> - let c' = subst_mps sub c in - let t' = subst_mps sub t in - if c == c' && t == t' then x else LocalDef (id,c',t') +let subst_rel_declaration sub = + Term.map_rel_decl (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) diff --git a/checker/indtypes.ml b/checker/indtypes.ml index f11fa5a7ad..566df673c1 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -319,7 +319,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = let nhyps = List.length hyps in let rec check k index = function | [] -> () - | LocalDef (_,_,_) :: hyps -> check k (index+1) hyps + | LocalDef _ :: hyps -> check k (index+1) hyps | _::hyps -> match whd_betadeltaiota env lpar.(k) with | Rel w when w = index -> check (k-1) (index+1) hyps @@ -376,8 +376,9 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in let specif = lookup_mind_specif env mi in let env' = - push_rel (LocalAssum (Anonymous, - hnf_prod_applist env (type_of_inductive env (specif,u)) lpar)) env in + let decl = LocalAssum (Anonymous, + hnf_prod_applist env (type_of_inductive env (specif,u)) lpar) in + push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in diff --git a/checker/inductive.ml b/checker/inductive.ml index 9480124211..5e2e14f7fb 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -634,8 +634,9 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - push_rel (LocalAssum (Anonymous, - hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar)) env + let decl = LocalAssum (Anonymous, + hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in + push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in diff --git a/checker/term.ml b/checker/term.ml index 181d292ad4..56cc9cdc22 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -227,19 +227,19 @@ let rel_context_nhyps hyps = nhyps 0 hyps let fold_rel_context f l ~init = List.fold_right f l init -let map_rel_context f l = - let map_decl = function - | LocalAssum (n, typ) as decl -> - let typ' = f typ in - if typ' == typ then decl else - LocalAssum (n, typ') - | LocalDef (n, body, typ) as decl -> - let body' = f body in - let typ' = f typ in - if body' == body && typ' == typ then decl else - LocalDef (n, body', typ') - in - List.smartmap map_decl l +let map_rel_decl f = function + | LocalAssum (n, typ) as decl -> + let typ' = f typ in + if typ' == typ then decl else + LocalAssum (n, typ') + | LocalDef (n, body, typ) as decl -> + let body' = f body in + let typ' = f typ in + if body' == body && typ' == typ then decl else + LocalDef (n, body', typ') + +let map_rel_context f = + List.smartmap (map_rel_decl f) let extended_rel_list n hyps = let rec reln l p = function diff --git a/checker/term.mli b/checker/term.mli index d6455e23f4..0af83e05d7 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -35,6 +35,7 @@ val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a +val map_rel_decl : (constr -> constr) -> rel_declaration -> rel_declaration val map_rel_context : (constr -> constr) -> rel_context -> rel_context val extended_rel_list : int -> rel_context -> constr list val compose_lam : (name * constr) list -> constr -> constr -- cgit v1.2.3 From 1dddd062f35736285eb2940382df2b53224578a7 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Tue, 16 Feb 2016 07:38:45 +0100 Subject: Renaming variants of Entries.local_entry The original datatype: Entries.local_entry = LocalDef of constr | LocalAssum of constr was changed to: Entries.local_entry = LocalDefEntry of constr | LocalAssumEntry of constr There are two advantages: 1. the new names are consistent with other variant names in the same module which also have this "*Entry" suffix 2. the new names do not collide with variants defined in the Context.{Rel,Named}.Declaration modules so both, "Entries" as well as "Context.{Rel,Named}.Declaration" can be open at the same time. The disadvantage is that those new variants are longer. But since those variants are rarely used, it it is not a big deal. --- kernel/entries.mli | 4 ++-- kernel/typeops.ml | 14 ++++++-------- toplevel/command.ml | 5 +++-- toplevel/discharge.ml | 5 +++-- toplevel/record.ml | 5 +++-- 5 files changed, 17 insertions(+), 16 deletions(-) diff --git a/kernel/entries.mli b/kernel/entries.mli index b2a77dd950..3ecfcca64c 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -18,8 +18,8 @@ open Term (** {6 Local entries } *) type local_entry = - | LocalDef of constr - | LocalAssum of constr + | LocalDefEntry of constr + | LocalAssumEntry of constr (** {6 Declaration of inductive types. } *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index eeb12a2b49..0ea68e2bcc 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -18,6 +18,7 @@ open Entries open Reduction open Inductive open Type_errors +open Context.Rel.Declaration let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y @@ -77,7 +78,6 @@ let judge_of_type u = (*s Type of a de Bruijn index. *) let judge_of_relative env n = - let open Context.Rel.Declaration in try let typ = get_type (lookup_rel n env) in { uj_val = mkRel n; @@ -99,9 +99,9 @@ let judge_of_variable env id = variables of the current env. Order does not have to be checked assuming that all names are distinct *) let check_hyps_inclusion env c sign = - let open Context.Named.Declaration in Context.Named.fold_outside (fun d1 () -> + let open Context.Named.Declaration in let id = get_id d1 in try let d2 = lookup_named id env in @@ -127,7 +127,6 @@ let extract_level env p = match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None let extract_context_levels env l = - let open Context.Rel.Declaration in let fold l = function | LocalAssum (_,p) -> extract_level env p :: l | LocalDef _ -> l @@ -420,7 +419,6 @@ let type_fixpoint env lna lar vdefj = Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr = - let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> @@ -553,12 +551,12 @@ let infer_v env cv = (* Typing of several terms. *) let infer_local_decl env id = function - | LocalDef c -> + | LocalDefEntry c -> let j = infer env c in - Context.Rel.Declaration.LocalDef (Name id, j.uj_val, j.uj_type) - | LocalAssum c -> + LocalDef (Name id, j.uj_val, j.uj_type) + | LocalAssumEntry c -> let j = infer env c in - Context.Rel.Declaration.LocalAssum (Name id, assumption_of_judgment env j) + LocalAssum (Name id, assumption_of_judgment env j) let infer_local_decls env decls = let rec inferec env = function diff --git a/toplevel/command.ml b/toplevel/command.ml index 166fe94ead..284bcd75ec 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -38,6 +38,7 @@ open Misctypes open Vernacexpr open Sigma.Notations open Context.Rel.Declaration +open Entries let do_universe poly l = Declare.do_universe poly l let do_constraint poly l = Declare.do_constraint poly l @@ -385,8 +386,8 @@ let mk_mltype_data evdref env assums arity indname = (is_ml_type,indname,assums) let prepare_param = function - | LocalAssum (na,t) -> out_name na, Entries.LocalAssum t - | LocalDef (na,b,_) -> out_name na, Entries.LocalDef b + | LocalAssum (na,t) -> out_name na, LocalAssumEntry t + | LocalDef (na,b,_) -> out_name na, LocalDefEntry b (** Make the arity conclusion flexible to avoid generating an upper bound universe now, only if the universe does not appear anywhere else. diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 5fa51e06e4..ffa11679c2 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -14,6 +14,7 @@ open Vars open Entries open Declarations open Cooking +open Entries open Context.Rel.Declaration (********************************) @@ -21,8 +22,8 @@ open Context.Rel.Declaration let detype_param = function - | LocalAssum (Name id, p) -> id, Entries.LocalAssum p - | LocalDef (Name id, p,_) -> id, Entries.LocalDef p + | LocalAssum (Name id, p) -> id, LocalAssumEntry p + | LocalDef (Name id, p,_) -> id, LocalDefEntry p | _ -> anomaly (Pp.str "Unnamed inductive local variable") (* Replace diff --git a/toplevel/record.ml b/toplevel/record.ml index 4cf81a250c..c0bb9eb86c 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -26,6 +26,7 @@ open Constrexpr_ops open Goptions open Sigma.Notations open Context.Rel.Declaration +open Entries (********** definition d'un record (structure) **************) @@ -164,8 +165,8 @@ let degenerate_decl decl = | Name id -> id | Anonymous -> anomaly (Pp.str "Unnamed record variable") in match decl with - | LocalAssum (_,t) -> (id, Entries.LocalAssum t) - | LocalDef (_,b,_) -> (id, Entries.LocalDef b) + | LocalAssum (_,t) -> (id, LocalAssumEntry t) + | LocalDef (_,b,_) -> (id, LocalDefEntry b) type record_error = | MissingProj of Id.t * Id.t list -- cgit v1.2.3 From 3960836e255e3738cabcd559cc1c133c5f30137a Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 16 Feb 2016 11:46:37 +0100 Subject: Term: fix a comment (first de Bruijn index is 1) --- kernel/term.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/kernel/term.mli b/kernel/term.mli index 7f79f64033..32267f6c4c 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -202,7 +202,7 @@ val destCoFix : constr -> cofixpoint (** non-dependent product [t1 -> t2], an alias for [forall (_:t1), t2]. Beware [t_2] is NOT lifted. - Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))] + Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 1) (mkRel 2))] *) val mkArrow : types -> types -> constr -- cgit v1.2.3 From 9a7afc12e0573c74d0bb0943372dddc3c61a03f1 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 16 Feb 2016 11:48:28 +0100 Subject: Tacticals: typo in a comment --- tactics/tacticals.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index ffcc71b458..0f926468b9 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -147,7 +147,7 @@ val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic semantics as the similarly named tacticals in [Proofview]. The tactical of [Proofview] are used in the definition of the tacticals of [Tacticals.New], but they are more atomic. In - particular [Tacticals.New.tclORELSE] sees like of progress as a + particular [Tacticals.New.tclORELSE] sees lack of progress as a failure, whereas [Proofview.tclORELSE] doesn't. Additionally every tactic which can catch failure ([tclOR], [tclORELSE], [tclTRY], [tclREPEAt], etc…) are run into each goal independently (failures -- cgit v1.2.3 From 06fa0334047a9400d0b5a144601fca35746a53b8 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Wed, 17 Feb 2016 10:32:40 +0100 Subject: CLEANUP: Renaming "Util.compose" function to "%" I propose to change the name of the "Util.compose" function to "%". Reasons: 1. If one wants to express function composition, then the new name enables us to achieve this goal easier. 2. In "Batteries Included" they had made the same choice. --- lib/util.ml | 8 +++++++- lib/util.mli | 10 +++++++++- proofs/tacmach.ml | 2 +- 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/lib/util.ml b/lib/util.ml index b67539918d..0f79c10df1 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -87,7 +87,13 @@ let matrix_transpose mat = let identity x = x -let compose f g x = f (g x) +(** Function composition: the mathematical [∘] operator. + + So [g % f] is a synonym for [fun x -> g (f x)]. + + Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. + *) +let (%) f g x = f (g x) let const x _ = x diff --git a/lib/util.mli b/lib/util.mli index 7923c65a3b..559874bb83 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -83,7 +83,15 @@ val matrix_transpose : 'a list list -> 'a list list (** {6 Functions. } *) val identity : 'a -> 'a -val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b + +(** Function composition: the mathematical [∘] operator. + + So [g % f] is a synonym for [fun x -> g (f x)]. + + Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. +*) +val (%) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b + val const : 'a -> 'b -> 'a val iterate : ('a -> 'a) -> int -> 'a -> 'a val repeat : int -> ('a -> unit) -> 'a -> unit diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a10d8fd2f7..1e59c182ce 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -99,7 +99,7 @@ let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind -let pf_hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls) +let pf_hnf_type_of gls = pf_whd_betadeltaiota gls % pf_get_type_of gls let pf_is_matching = pf_apply Constr_matching.is_matching_conv let pf_matches = pf_apply Constr_matching.matches_conv -- cgit v1.2.3 From 65b901534649c5f29e245a4960fa66f6e9d9c257 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 17 Feb 2016 18:11:02 +0100 Subject: Fix bug #4574: Anomaly: Uncaught exception Invalid_argument("splay_arity"). The setoid_rewrite tactic was not checking that the relation it was looking for was indeed a relation, i.e. that its type was an arity. --- tactics/rewrite.ml | 13 +++++++++---- test-suite/bugs/closed/4574.v | 8 ++++++++ 2 files changed, 17 insertions(+), 4 deletions(-) create mode 100644 test-suite/bugs/closed/4574.v diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 83742bfbdd..b04fb660d8 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -446,6 +446,8 @@ type hypinfo = { let get_symmetric_proof b = if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof +let error_no_relation () = error "Cannot find a relation to rewrite." + let rec decompose_app_rel env evd t = (** Head normalize for compatibility with the old meta mechanism *) let t = Reductionops.whd_betaiota evd t in @@ -461,8 +463,11 @@ let rec decompose_app_rel env evd t = | App (f, args) -> let len = Array.length args in let fargs = Array.sub args 0 (Array.length args - 2) in - mkApp (f, fargs), args.(len - 2), args.(len - 1) - | _ -> error "Cannot find a relation to rewrite." + let rel = mkApp (f, fargs) in + let ty = Retyping.get_type_of env evd rel in + let () = if not (Reduction.is_arity env ty) then error_no_relation () in + rel, args.(len - 2), args.(len - 1) + | _ -> error_no_relation () let decompose_applied_relation env sigma (c,l) = let ctype = Retyping.get_type_of env sigma c in @@ -2048,8 +2053,8 @@ let setoid_proof ty fn fallback = begin try let rel, _, _ = decompose_app_rel env sigma concl in - let evm = sigma in - let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.unsafe_type_of env evm rel)))) in + let (sigma, t) = Typing.type_of env sigma rel in + let car = pi3 (List.hd (fst (Reduction.dest_prod env t))) in (try init_setoid () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e diff --git a/test-suite/bugs/closed/4574.v b/test-suite/bugs/closed/4574.v new file mode 100644 index 0000000000..39ba190369 --- /dev/null +++ b/test-suite/bugs/closed/4574.v @@ -0,0 +1,8 @@ +Require Import Setoid. + +Definition block A (a : A) := a. + +Goal forall A (a : A), block Type nat. +Proof. +Fail reflexivity. + -- cgit v1.2.3 From 8a179389fe5199e79d05b2c72ff2aae2061820aa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 17 Feb 2016 18:53:45 +0100 Subject: Fixing the Proofview.Goal.goal function. The environment put in the goals was not the right one and could lead to various leaks. --- proofs/proofview.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 49228c93ac..6d7dcb9257 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1000,7 +1000,6 @@ module Goal = struct end let goals = - Env.get >>= fun env -> Pv.get >>= fun step -> let sigma = step.solution in let map goal = @@ -1008,6 +1007,7 @@ module Goal = struct | None -> None (** ppedrot: Is this check really necessary? *) | Some goal -> let gl = + Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> tclUNIT (gmake env sigma goal) in -- cgit v1.2.3 From e4c9dfe7277ec2e2c4b1e40f60044ba4cade8e61 Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 18 Feb 2016 14:19:21 +0100 Subject: ADD: Names.Name.is_{anonymous,name} Two new (trivial) functions were added: Names.Name.is_anonymous : Names.Name.t -> bool Names.Name.is_name : Names.Name.t -> bool They enable us to write a more compact code. (example: commit "99633f4" in "relation-extraction" module of "coq-contribs"). --- kernel/names.ml | 6 ++++++ kernel/names.mli | 6 ++++++ 2 files changed, 12 insertions(+) diff --git a/kernel/names.ml b/kernel/names.ml index 02587bad9b..0aa26fb9cc 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -82,6 +82,12 @@ struct type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) + let is_anonymous = function + | Anonymous -> true + | Name _ -> false + + let is_name = not % is_anonymous + let compare n1 n2 = match n1, n2 with | Anonymous, Anonymous -> 0 | Name id1, Name id2 -> Id.compare id1 id2 diff --git a/kernel/names.mli b/kernel/names.mli index 40f96813fc..6380b17fbf 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -68,6 +68,12 @@ sig type t = Anonymous (** anonymous identifier *) | Name of Id.t (** non-anonymous identifier *) + val is_anonymous : t -> bool + (** Return [true] iff a given name is [Anonymous]. *) + + val is_name : t -> bool + (** Return [true] iff a given name is [Name _]. *) + val compare : t -> t -> int (** Comparison over names. *) -- cgit v1.2.3 From 82e4e8f2afbff4f1dbecb8a37e3c1c18a41c754f Mon Sep 17 00:00:00 2001 From: Matej Kosik Date: Thu, 18 Feb 2016 17:32:15 +0100 Subject: FIX: of my previous merging mistake --- tactics/inv.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/inv.ml b/tactics/inv.ml index 9bfbbc41b7..6841ab0ecd 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -298,7 +298,7 @@ let get_names (allow_conj,issimple) (loc, pat as x) = match pat with | IntroAction (IntroRewrite _) -> error "Rewriting pattern not allowed for inversion equations." | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) - | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l))) + | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ])) when allow_conj -> (Some id,l) | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then -- cgit v1.2.3 From 4f640bb24dfc45699670f41441355cdf71c83130 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Mon, 15 Feb 2016 16:11:11 +0100 Subject: STM: classify some variants of Instance as regular `Fork nodes. "Instance name : Type." is like "Lemma name : Type", i.e. it starts a proof. Unfortunately sometimes it does not, so we say VtUnknown. Still, if there is an open proof, we classify it as a regular Lemma, i.e. the opacity depends only on the terminator. This makes CoqIDE and PIDE based UI way more responsive when processing files containing Instance that are proved by tactics, since they are now correctly delegated to workers. Bug reported privately by Alec Faithfull. --- stm/stm.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/stm/stm.ml b/stm/stm.ml index 56dcda6a4a..f2855d5087 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2254,7 +2254,11 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in - VCS.commit id (Fork (x,bname,Doesn'tGuaranteeOpacity,[])); + let opacity_of_produced_term = + match x.expr with + | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity + | _ -> Doesn'tGuaranteeOpacity in + VCS.commit id (Fork (x,bname,opacity_of_produced_term,[])); VCS.branch bname (`Proof ("Classic", VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode "Classic"; end else begin -- cgit v1.2.3 From 37479c1b59b7492abb5c89a42c5a76d4cd9d48cd Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 18 Feb 2016 19:13:40 +0100 Subject: CoqIDE: STOP button also stops workers (fix #4542) --- ide/coq.ml | 15 +++++++++++---- ide/coq.mli | 4 ++-- ide/coqide.ml | 2 +- ide/session.ml | 3 +++ ide/session.mli | 1 + 5 files changed, 18 insertions(+), 7 deletions(-) diff --git a/ide/coq.ml b/ide/coq.ml index 98576a9811..7edae47ca1 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -465,10 +465,6 @@ let close_coqtop coqtop = let reset_coqtop coqtop = respawn_coqtop ~why:Planned coqtop -let break_coqtop coqtop = - try !interrupter (CoqTop.unixpid coqtop.handle.proc) - with _ -> Minilib.log "Error while sending Ctrl-C" - let get_arguments coqtop = coqtop.sup_args let set_arguments coqtop args = @@ -518,6 +514,17 @@ let search flags = eval_call (Xmlprotocol.search flags) let init x = eval_call (Xmlprotocol.init x) let stop_worker x = eval_call (Xmlprotocol.stop_worker x) +let break_coqtop coqtop workers = + if coqtop.status = Busy then + try !interrupter (CoqTop.unixpid coqtop.handle.proc) + with _ -> Minilib.log "Error while sending Ctrl-C" + else + let rec aux = function + | [] -> Void + | w :: ws -> stop_worker w coqtop.handle (fun _ -> aux ws) + in + let Void = aux workers in () + module PrintOpt = struct type t = string list diff --git a/ide/coq.mli b/ide/coq.mli index d9eda0f342..7cef6a4d0a 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -70,8 +70,8 @@ val init_coqtop : coqtop -> unit task -> unit (** Finish initializing a freshly spawned coqtop, by running a first task on it. The task should run its inner continuation at the end. *) -val break_coqtop : coqtop -> unit -(** Interrupt the current computation of coqtop. *) +val break_coqtop : coqtop -> string list -> unit +(** Interrupt the current computation of coqtop or the worker if coqtop it not running. *) val close_coqtop : coqtop -> unit (** Close coqtop. Subsequent requests will be discarded. Hook ignored. *) diff --git a/ide/coqide.ml b/ide/coqide.ml index 608cf82ff8..36aab30e60 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -574,7 +574,7 @@ module Nav = struct let restart _ = on_current_term restart let interrupt sn = Minilib.log "User break received"; - Coq.break_coqtop sn.coqtop + Coq.break_coqtop sn.coqtop CString.(Set.elements (Map.domain sn.jobpage#data)) let interrupt = cb_on_current_term interrupt let join_document _ = send_to_coq (fun sn -> sn.coqops#join_document) end diff --git a/ide/session.ml b/ide/session.ml index 34c533b8e5..168ddd4df9 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -19,6 +19,7 @@ class type ['a] page = method update : 'a -> unit method on_update : callback:('a -> unit) -> unit method refresh_color : unit -> unit + method data : 'a end class type control = @@ -321,6 +322,7 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage = end method on_update ~callback:cb = callback := cb method refresh_color () = refresh () + method data = !last_update end let create_jobpage coqtop coqops : jobpage = @@ -361,6 +363,7 @@ let create_jobpage coqtop coqops : jobpage = end method on_update ~callback:cb = callback := cb method refresh_color () = refresh () + method data = !last_update end let create_proof () = diff --git a/ide/session.mli b/ide/session.mli index 0881e40392..ef39ab2e0d 100644 --- a/ide/session.mli +++ b/ide/session.mli @@ -15,6 +15,7 @@ class type ['a] page = method update : 'a -> unit method on_update : callback:('a -> unit) -> unit method refresh_color : unit -> unit + method data : 'a end class type control = -- cgit v1.2.3 From 9aa2d99fb1ad6b348142fce244f277b9dd25017f Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 19 Feb 2016 11:51:04 +0100 Subject: STM: Print/Extraction have to be skipped if -quick Print and Extraction commands may pierce opacity: if the task producing the proof term is not finished, we wait for its completion. In -quick mode no worker is going to process a task, since tasks are simply stored to disk (and resumed later in -vio2vo mode). This commit avoids coqc waits forever for a task in order to Print/Extract the corresponding term. Bug reported privately by Alec Faithfull. --- stm/stm.ml | 31 +++++++++++++++++++++++-------- test-suite/vio/print.v | 10 ++++++++++ 2 files changed, 33 insertions(+), 8 deletions(-) create mode 100644 test-suite/vio/print.v diff --git a/stm/stm.ml b/stm/stm.ml index f2855d5087..a6d119f0cd 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -83,6 +83,18 @@ let async_proofs_workers_extra_env = ref [||] type ast = { verbose : bool; loc : Loc.t; mutable expr : vernac_expr } let pr_ast { expr } = pr_vernac expr +(* Commands piercing opaque *) +let may_pierce_opaque = function + | { expr = VernacPrint (PrintName _) } -> true + | { expr = VernacExtend (("Extraction",_), _) } -> true + | { expr = VernacExtend (("SeparateExtraction",_), _) } -> true + | { expr = VernacExtend (("ExtractionLibrary",_), _) } -> true + | { expr = VernacExtend (("RecursiveExtractionLibrary",_), _) } -> true + | { expr = VernacExtend (("ExtractionConstant",_), _) } -> true + | { expr = VernacExtend (("ExtractionInlinedConstant",_), _) } -> true + | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true + | _ -> false + (* Wrapper for Vernacentries.interp to set the feedback id *) let vernac_interp ?proof id ?route { verbose; loc; expr } = let rec internal_command = function @@ -145,7 +157,7 @@ type cmd_t = { ceff : bool; (* is a side-effecting command *) cast : ast; cids : Id.t list; - cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch ] } + cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch | `SkipQueue ] } type fork_t = ast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list type qed_t = { qast : ast; @@ -1665,7 +1677,7 @@ let delegate name = let time = get_hint_bp_time name in time >= 1.0 || !Flags.compilation_mode = Flags.BuildVio || !Flags.async_proofs_full - + let collect_proof keep cur hd brkind id = prerr_endline ("Collecting proof ending at "^Stateid.to_string id); let no_name = "" in @@ -1687,23 +1699,20 @@ let collect_proof keep cur hd brkind id = let has_proof_no_using = function | Some (_, { expr = VernacProof(_,None) }) -> true | _ -> false in - let may_pierce_opaque = function - | { expr = VernacPrint (PrintName _) } -> true - (* These do not exactly pierce opaque, but are anyway impossible to properly - * delegate *) + let too_complex_to_delegate = function | { expr = (VernacDeclareModule _ | VernacDefineModule _ | VernacDeclareModuleType _ | VernacInclude _) } -> true | { expr = (VernacRequire _ | VernacImport _) } -> true - | _ -> false in + | ast -> may_pierce_opaque ast in let parent = function Some (p, _) -> p | None -> assert false in let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in let rec collect last accn id = let view = VCS.visit id in match view.step with | (`Sideff (`Ast(x,_)) | `Cmd { cast = x }) - when may_pierce_opaque x -> `Sync(no_name,None,`Print) + when too_complex_to_delegate x -> `Sync(no_name,None,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next | `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next (* An Alias could jump everywhere... we hope we can ignore it*) @@ -1811,6 +1820,8 @@ let known_state ?(redefine_qed=false) ~cache id = | `Alias (id,_) -> (fun () -> reach view.next; reach id ), cache, true + | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () -> + reach view.next), cache, true | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () -> reach ~cache:`Shallow view.next; Hooks.(call tactic_being_run true); @@ -2176,6 +2187,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = let id = VCS.new_node ~id:newtip () in let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) + else if Flags.(!compilation_mode = BuildVio) && + VCS.((get_branch head).kind = `Master) && + may_pierce_opaque x + then `SkipQueue else `MainQueue in VCS.commit id (Cmd {ctac=false;ceff=false;cast = x; cids = []; cqueue = queue }); Backtrack.record (); if w == VtNow then finish (); `Ok diff --git a/test-suite/vio/print.v b/test-suite/vio/print.v new file mode 100644 index 0000000000..9c36a463c9 --- /dev/null +++ b/test-suite/vio/print.v @@ -0,0 +1,10 @@ +Lemma a : True. +Proof. +idtac. +exact I. +Qed. + +Print a. + +Lemma b : False. +Admitted. -- cgit v1.2.3 From d3012c8ac308b18272ddaa90c4eae7e517b63c7c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 19 Feb 2016 13:59:33 +0100 Subject: Fixing bug #4582: cannot override notation [ x ]. --- test-suite/bugs/closed/4582.v | 10 ++++++++++ theories/Lists/List.v | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4582.v diff --git a/test-suite/bugs/closed/4582.v b/test-suite/bugs/closed/4582.v new file mode 100644 index 0000000000..0842fb8fa7 --- /dev/null +++ b/test-suite/bugs/closed/4582.v @@ -0,0 +1,10 @@ +Require List. +Import List.ListNotations. + +Variable Foo : nat -> nat. + +Delimit Scope Foo_scope with F. + +Notation " [ x ] " := (Foo x) : Foo_scope. + +Check ([1] : nat)%F. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index cc7586fecb..957f1066d2 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -26,7 +26,7 @@ In a special module to avoid conflicts. *) Module ListNotations. Notation " [ ] " := nil (format "[ ]") : list_scope. Notation " [ x ] " := (cons x nil) : list_scope. -Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. +Notation " [ x ; y ; .. ; z ] " := (cons x (cons y .. (cons z nil) ..)) : list_scope. End ListNotations. Import ListNotations. -- cgit v1.2.3 From 924d2833644735a9fa8289ffaa9bac9fbc43982c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 19 Feb 2016 14:27:31 +0100 Subject: Fixing bug #4580: [Set Refine Instance Mode] also used for Program Instance. --- test-suite/bugs/closed/4580.v | 6 ++++++ toplevel/classes.ml | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4580.v diff --git a/test-suite/bugs/closed/4580.v b/test-suite/bugs/closed/4580.v new file mode 100644 index 0000000000..4ffd5f0f4b --- /dev/null +++ b/test-suite/bugs/closed/4580.v @@ -0,0 +1,6 @@ +Require Import Program. + +Class Foo (A : Type) := foo : A. + +Unset Refine Instance Mode. +Program Instance f1 : Foo nat := S _. diff --git a/toplevel/classes.ml b/toplevel/classes.ml index f73dd5a2e6..5f73b70a2e 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -290,7 +290,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro if not (Evd.has_undefined evm) && not (Option.is_empty term) then declare_instance_constant k pri global imps ?hook id pl poly evm (Option.get term) termtype - else if !refine_instance || Option.is_empty term then begin + else if Flags.is_program_mode () || !refine_instance || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then let hook vis gr _ = -- cgit v1.2.3 From 8d0ff142913fc6351ff7f0a6b8eacc6c21d36000 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 19 Feb 2016 15:12:53 +0100 Subject: Allowing to attach location to universes in UState. --- engine/evd.ml | 42 +++++++++++++++++++++--------------------- engine/evd.mli | 20 ++++++++++---------- engine/sigma.ml | 32 ++++++++++++++++---------------- engine/sigma.mli | 24 ++++++++++++------------ engine/uState.ml | 49 +++++++++++++++++++++++++++++++++++++------------ engine/uState.mli | 4 ++-- 6 files changed, 98 insertions(+), 73 deletions(-) diff --git a/engine/evd.ml b/engine/evd.ml index f751f4d922..b6849f7ffb 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -781,25 +781,25 @@ let restrict_universe_context evd vars = let universe_subst evd = UState.subst evd.universes -let merge_context_set ?(sideff=false) rigid evd ctx' = - {evd with universes = UState.merge sideff rigid evd.universes ctx'} +let merge_context_set ?loc ?(sideff=false) rigid evd ctx' = + {evd with universes = UState.merge ?loc sideff rigid evd.universes ctx'} let merge_universe_subst evd subst = {evd with universes = UState.merge_subst evd.universes subst } -let with_context_set rigid d (a, ctx) = - (merge_context_set rigid d ctx, a) +let with_context_set ?loc rigid d (a, ctx) = + (merge_context_set ?loc rigid d ctx, a) -let new_univ_level_variable ?name ?(predicative=true) rigid evd = - let uctx', u = UState.new_univ_variable rigid name evd.universes in +let new_univ_level_variable ?loc ?name ?(predicative=true) rigid evd = + let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in ({evd with universes = uctx'}, u) -let new_univ_variable ?name ?(predicative=true) rigid evd = - let uctx', u = UState.new_univ_variable rigid name evd.universes in +let new_univ_variable ?loc ?name ?(predicative=true) rigid evd = + let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in ({evd with universes = uctx'}, Univ.Universe.make u) -let new_sort_variable ?name ?(predicative=true) rigid d = - let (d', u) = new_univ_variable rigid ?name ~predicative d in +let new_sort_variable ?loc ?name ?(predicative=true) rigid d = + let (d', u) = new_univ_variable ?loc rigid ?name ~predicative d in (d', Type u) let add_global_univ d u = @@ -815,27 +815,27 @@ let make_evar_universe_context e l = | Some us -> List.fold_left (fun uctx (loc,id) -> - fst (UState.new_univ_variable univ_rigid (Some (Id.to_string id)) uctx)) + fst (UState.new_univ_variable ~loc univ_rigid (Some (Id.to_string id)) uctx)) uctx us (****************************************) (* Operations on constants *) (****************************************) -let fresh_sort_in_family ?(rigid=univ_flexible) env evd s = - with_context_set rigid evd (Universes.fresh_sort_in_family env s) +let fresh_sort_in_family ?loc ?(rigid=univ_flexible) env evd s = + with_context_set ?loc rigid evd (Universes.fresh_sort_in_family env s) -let fresh_constant_instance env evd c = - with_context_set univ_flexible evd (Universes.fresh_constant_instance env c) +let fresh_constant_instance ?loc env evd c = + with_context_set ?loc univ_flexible evd (Universes.fresh_constant_instance env c) -let fresh_inductive_instance env evd i = - with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i) +let fresh_inductive_instance ?loc env evd i = + with_context_set ?loc univ_flexible evd (Universes.fresh_inductive_instance env i) -let fresh_constructor_instance env evd c = - with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c) +let fresh_constructor_instance ?loc env evd c = + with_context_set ?loc univ_flexible evd (Universes.fresh_constructor_instance env c) -let fresh_global ?(rigid=univ_flexible) ?names env evd gr = - with_context_set rigid evd (Universes.fresh_global_instance ?names env gr) +let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = + with_context_set ?loc rigid evd (Universes.fresh_global_instance ?names env gr) let whd_sort_variable evd t = t diff --git a/engine/evd.mli b/engine/evd.mli index a9ca9a7408..3ae6e586c1 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -504,9 +504,9 @@ val normalize_evar_universe_context_variables : evar_universe_context -> val normalize_evar_universe_context : evar_universe_context -> evar_universe_context -val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level -val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe -val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts +val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level +val new_univ_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts val add_global_univ : evar_map -> Univ.Level.t -> evar_map val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map @@ -541,10 +541,10 @@ val universes : evar_map -> UGraph.t val merge_universe_context : evar_map -> evar_universe_context -> evar_map val set_universe_context : evar_map -> evar_universe_context -> evar_map -val merge_context_set : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map +val merge_context_set : ?loc:Loc.t -> ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map -val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a +val with_context_set : ?loc:Loc.t -> rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst val abstract_undefined_variables : evar_universe_context -> evar_universe_context @@ -559,12 +559,12 @@ val update_sigma_env : evar_map -> env -> evar_map (** Polymorphic universes *) -val fresh_sort_in_family : ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts -val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant -val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive -val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor +val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts +val fresh_constant_instance : ?loc:Loc.t -> env -> evar_map -> constant -> evar_map * pconstant +val fresh_inductive_instance : ?loc:Loc.t -> env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : ?loc:Loc.t -> env -> evar_map -> constructor -> evar_map * pconstructor -val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> +val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> Globnames.global_reference -> evar_map * constr (******************************************************************** diff --git a/engine/sigma.ml b/engine/sigma.ml index c25aac0c14..c7b0bb5a50 100644 --- a/engine/sigma.ml +++ b/engine/sigma.ml @@ -36,36 +36,36 @@ let new_evar sigma ?naming info = let define evk c sigma = Sigma ((), Evd.define evk c sigma, ()) -let new_univ_level_variable ?name ?predicative rigid sigma = - let (sigma, u) = Evd.new_univ_level_variable ?name ?predicative rigid sigma in +let new_univ_level_variable ?loc ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_univ_level_variable ?loc ?name ?predicative rigid sigma in Sigma (u, sigma, ()) -let new_univ_variable ?name ?predicative rigid sigma = - let (sigma, u) = Evd.new_univ_variable ?name ?predicative rigid sigma in +let new_univ_variable ?loc ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_univ_variable ?loc ?name ?predicative rigid sigma in Sigma (u, sigma, ()) -let new_sort_variable ?name ?predicative rigid sigma = - let (sigma, u) = Evd.new_sort_variable ?name ?predicative rigid sigma in +let new_sort_variable ?loc ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_sort_variable ?loc ?name ?predicative rigid sigma in Sigma (u, sigma, ()) -let fresh_sort_in_family ?rigid env sigma s = - let (sigma, s) = Evd.fresh_sort_in_family ?rigid env sigma s in +let fresh_sort_in_family ?loc ?rigid env sigma s = + let (sigma, s) = Evd.fresh_sort_in_family ?loc ?rigid env sigma s in Sigma (s, sigma, ()) -let fresh_constant_instance env sigma cst = - let (sigma, cst) = Evd.fresh_constant_instance env sigma cst in +let fresh_constant_instance ?loc env sigma cst = + let (sigma, cst) = Evd.fresh_constant_instance ?loc env sigma cst in Sigma (cst, sigma, ()) -let fresh_inductive_instance env sigma ind = - let (sigma, ind) = Evd.fresh_inductive_instance env sigma ind in +let fresh_inductive_instance ?loc env sigma ind = + let (sigma, ind) = Evd.fresh_inductive_instance ?loc env sigma ind in Sigma (ind, sigma, ()) -let fresh_constructor_instance env sigma pc = - let (sigma, c) = Evd.fresh_constructor_instance env sigma pc in +let fresh_constructor_instance ?loc env sigma pc = + let (sigma, c) = Evd.fresh_constructor_instance ?loc env sigma pc in Sigma (c, sigma, ()) -let fresh_global ?rigid ?names env sigma r = - let (sigma, c) = Evd.fresh_global ?rigid ?names env sigma r in +let fresh_global ?loc ?rigid ?names env sigma r = + let (sigma, c) = Evd.fresh_global ?loc ?rigid ?names env sigma r in Sigma (c, sigma, ()) (** Run *) diff --git a/engine/sigma.mli b/engine/sigma.mli index d7ae2e4ac9..643bea4036 100644 --- a/engine/sigma.mli +++ b/engine/sigma.mli @@ -66,23 +66,23 @@ val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma (** Polymorphic universes *) -val new_univ_level_variable : ?name:string -> ?predicative:bool -> Evd.rigid -> - 'r t -> (Univ.universe_level, 'r) sigma -val new_univ_variable : ?name:string -> ?predicative:bool -> Evd.rigid -> - 'r t -> (Univ.universe, 'r) sigma -val new_sort_variable : ?name:string -> ?predicative:bool -> Evd.rigid -> - 'r t -> (Sorts.t, 'r) sigma - -val fresh_sort_in_family : ?rigid:Evd.rigid -> Environ.env -> +val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> + Evd.rigid -> 'r t -> (Univ.universe_level, 'r) sigma +val new_univ_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> + Evd.rigid -> 'r t -> (Univ.universe, 'r) sigma +val new_sort_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> + Evd.rigid -> 'r t -> (Sorts.t, 'r) sigma + +val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:Evd.rigid -> Environ.env -> 'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma val fresh_constant_instance : - Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma + ?loc:Loc.t -> Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma val fresh_inductive_instance : - Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma -val fresh_constructor_instance : Environ.env -> 'r t -> constructor -> + ?loc:Loc.t -> Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma +val fresh_constructor_instance : ?loc:Loc.t -> Environ.env -> 'r t -> constructor -> (pconstructor, 'r) sigma -val fresh_global : ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> +val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> 'r t -> Globnames.global_reference -> (constr, 'r) sigma (** FILLME *) diff --git a/engine/uState.ml b/engine/uState.ml index 75c03bc89c..8aa9a61ab9 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -25,9 +25,14 @@ module UNameMap = struct | _, _ -> r) s t end +type uinfo = { + uname : string option; + uloc : Loc.t option; +} + (* 2nd part used to check consistency on the fly. *) type t = - { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t; + { uctx_names : Univ.Level.t UNameMap.t * uinfo Univ.LMap.t; uctx_local : Univ.universe_context_set; (** The local context of variables *) uctx_univ_variables : Universes.universe_opt_subst; (** The local universes that are unification variables *) @@ -104,8 +109,13 @@ let constrain_variables diff ctx = with Not_found | Option.IsNone -> cstrs) diff Univ.Constraint.empty -let add_uctx_names s l (names, names_rev) = - (UNameMap.add s l names, Univ.LMap.add l s names_rev) +let add_uctx_names ?loc s l (names, names_rev) = + (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) + +let add_uctx_loc l loc (names, names_rev) = + match loc with + | None -> (names, names_rev) + | Some _ -> (names, Univ.LMap.add l { uname = None; uloc = loc } names_rev) let of_binders b = let ctx = empty in @@ -230,8 +240,8 @@ let add_universe_constraints ctx cstrs = let pr_uctx_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try str(Univ.LMap.find l map_rev) - with Not_found -> + try str (Option.get (Univ.LMap.find l map_rev).uname) + with Not_found | Option.IsNone -> Universes.pr_with_global_universes l let universe_context ?names ctx = @@ -252,10 +262,14 @@ let universe_context ?names ctx = in if not (Univ.LSet.is_empty left) then let n = Univ.LSet.cardinal left in - errorlabstrm "universe_context" + let loc = + let get_loc u = try (Univ.LMap.find u (snd ctx.uctx_names)).uloc with Not_found -> None in + try List.find_map get_loc (Univ.LSet.elements left) with Not_found -> Loc.ghost + in + user_err_loc (loc, "universe_context", (str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level ctx) left ++ - spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") + spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.")) else let inst = Univ.Instance.of_array (Array.of_list newinst) in let ctx = Univ.UContext.make (inst, @@ -274,7 +288,7 @@ let univ_rigid = UnivRigid let univ_flexible = UnivFlexible false let univ_flexible_alg = UnivFlexible true -let merge sideff rigid uctx ctx' = +let merge ?loc sideff rigid uctx ctx' = let open Univ in let levels = ContextSet.levels ctx' in let uctx = if sideff then uctx else @@ -301,10 +315,21 @@ let merge sideff rigid uctx ctx' = with UGraph.AlreadyDeclared when sideff -> g) levels g in + let uctx_names = + let fold u accu = + let modify _ info = match info.uloc with + | None -> { info with uloc = loc } + | Some _ -> info + in + try LMap.modify u modify accu + with Not_found -> LMap.add u { uname = None; uloc = loc } accu + in + (fst uctx.uctx_names, LSet.fold fold levels (snd uctx.uctx_names)) + in let initial = declare uctx.uctx_initial_universes in let univs = declare uctx.uctx_universes in let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in - { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } + { uctx with uctx_names; uctx_local; uctx_universes; uctx_initial_universes = initial } let merge_subst uctx s = { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } @@ -313,7 +338,7 @@ let emit_side_effects eff u = let uctxs = Safe_typing.universes_of_private eff in List.fold_left (merge true univ_rigid) u uctxs -let new_univ_variable rigid name +let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = Universes.new_univ_level (Global.current_dirpath ()) in let ctx' = Univ.ContextSet.add_universe u ctx in @@ -328,8 +353,8 @@ let new_univ_variable rigid name in let names = match name with - | Some n -> add_uctx_names n u uctx.uctx_names - | None -> uctx.uctx_names + | Some n -> add_uctx_names ?loc n u uctx.uctx_names + | None -> add_uctx_loc u loc uctx.uctx_names in let initial = UGraph.add_universe u false uctx.uctx_initial_universes diff --git a/engine/uState.mli b/engine/uState.mli index 9dc96622ea..c5c454020c 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -84,11 +84,11 @@ val univ_rigid : rigid val univ_flexible : rigid val univ_flexible_alg : rigid -val merge : bool -> rigid -> t -> Univ.universe_context_set -> t +val merge : ?loc:Loc.t -> bool -> rigid -> t -> Univ.universe_context_set -> t val merge_subst : t -> Universes.universe_opt_subst -> t val emit_side_effects : Safe_typing.private_constants -> t -> t -val new_univ_variable : rigid -> string option -> t -> t * Univ.Level.t +val new_univ_variable : ?loc:Loc.t -> rigid -> string option -> t -> t * Univ.Level.t val add_global_univ : t -> Univ.Level.t -> t val make_flexible_variable : t -> bool -> Univ.Level.t -> t -- cgit v1.2.3 From bd0dc480ec02352b83e335ed2209abcf3d0f89eb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 19 Feb 2016 15:56:02 +0100 Subject: Adding location to universes generated by the pretyper. --- pretyping/pretyping.ml | 32 ++++++++++++++++---------------- pretyping/pretyping.mli | 2 +- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 5e8c5beb58..8329de2ee4 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -143,12 +143,12 @@ let interp_universe_level_name evd (loc,s) = evd, Idmap.find id names with Not_found -> if not (is_strict_universe_declarations ()) then - new_univ_level_variable ~name:s univ_rigid evd + new_univ_level_variable ~loc ~name:s univ_rigid evd else user_err_loc (loc, "interp_universe_level_name", Pp.(str "Undeclared universe: " ++ str s)) -let interp_universe evd = function - | [] -> let evd, l = new_univ_level_variable univ_rigid evd in +let interp_universe ?loc evd = function + | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in evd, Univ.Universe.make l | l -> List.fold_left (fun (evd, u) l -> @@ -156,15 +156,15 @@ let interp_universe evd = function (evd', Univ.sup u (Univ.Universe.make l))) (evd, Univ.Universe.type0m) l -let interp_universe_level evd = function - | None -> new_univ_level_variable univ_rigid evd +let interp_universe_level loc evd = function + | None -> new_univ_level_variable ~loc univ_rigid evd | Some (loc,s) -> interp_universe_level_name evd (loc,s) -let interp_sort evd = function +let interp_sort ?loc evd = function | GProp -> evd, Prop Null | GSet -> evd, Prop Pos | GType n -> - let evd, u = interp_universe evd n in + let evd, u = interp_universe ?loc evd n in evd, Type u let interp_elimination_sort = function @@ -385,11 +385,11 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let interp_universe_level_name evd l = +let interp_universe_level_name loc evd l = match l with | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set - | GType s -> interp_universe_level evd s + | GType s -> interp_universe_level loc evd s let pretype_global loc rigid env evd gr us = let evd, instance = @@ -404,7 +404,7 @@ let pretype_global loc rigid env evd gr us = str "Universe instance should have length " ++ int len) else let evd, l' = List.fold_left (fun (evd, univs) l -> - let evd, l = interp_universe_level_name evd l in + let evd, l = interp_universe_level_name loc evd l in (evd, l :: univs)) (evd, []) l in if List.exists (fun l -> Univ.Level.is_prop l) l' then @@ -413,7 +413,7 @@ let pretype_global loc rigid env evd gr us = str " universe instances must be greater or equal to Set."); evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in - Evd.fresh_global ~rigid ?names:instance env evd gr + Evd.fresh_global ~loc ~rigid ?names:instance env evd gr let pretype_ref loc evdref env ref us = match ref with @@ -431,17 +431,17 @@ let pretype_ref loc evdref env ref us = let ty = Typing.unsafe_type_of env evd c in make_judge c ty -let judge_of_Type evd s = - let evd, s = interp_universe evd s in +let judge_of_Type loc evd s = + let evd, s = interp_universe ~loc evd s in let judge = { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } in evd, judge -let pretype_sort evdref = function +let pretype_sort loc evdref = function | GProp -> judge_of_prop | GSet -> judge_of_set - | GType s -> evd_comb1 judge_of_Type evdref s + | GType s -> evd_comb1 (judge_of_Type loc) evdref s let new_type_evar env evdref loc = let sigma = Sigma.Unsafe.of_evar_map !evdref in @@ -598,7 +598,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> - let j = pretype_sort evdref s in + let j = pretype_sort loc evdref s in inh_conv_coerce_to_tycon loc env evdref j tycon | GApp (loc,f,args) -> diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index bfb4e7325e..40745ed097 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -148,7 +148,7 @@ val ise_pretype_gen : (** To embed constr in glob_constr *) -val interp_sort : evar_map -> glob_sort -> evar_map * sorts +val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : -- cgit v1.2.3 From fd8038facfe10abb2c874ca4602b1d2ee0903056 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 9 Feb 2016 17:46:37 +0100 Subject: Fix regression from 8.4 in reflexivity/... reflexivity/symmetry/transitivity only need RelationClasses to be loaded. --- tactics/rewrite.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index b04fb660d8..5ca74050a1 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -42,6 +42,10 @@ open Libnames let classes_dirpath = Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"]) +let init_relation_classes () = + if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () + else Coqlib.check_required_library ["Coq";"Classes";"RelationClasses"] + let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] @@ -2041,8 +2045,9 @@ let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite_clause (** [setoid_]{reflexivity,symmetry,transitivity} tactics *) let not_declared env ty rel = - Tacticals.New.tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ - str ty ++ str" relation. Maybe you need to require the Setoid library") + Tacticals.New.tclFAIL 0 + (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") let setoid_proof ty fn fallback = Proofview.Goal.nf_enter begin fun gl -> @@ -2055,7 +2060,7 @@ let setoid_proof ty fn fallback = let rel, _, _ = decompose_app_rel env sigma concl in let (sigma, t) = Typing.type_of env sigma rel in let car = pi3 (List.hd (fst (Reduction.dest_prod env t))) in - (try init_setoid () with _ -> raise Not_found); + (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e end -- cgit v1.2.3 From e54d014ce10dea4a74b66e5091d25e4b26bd71fa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 15 Feb 2016 20:17:24 +0100 Subject: Fixing bug #4540: CoqIDE bottom progress bar does not update. --- ide/coqOps.ml | 67 +++++++++++++++++++++++++-------- ide/document.ml | 27 +++++++++----- ide/document.mli | 4 +- ide/wg_Segment.ml | 106 ++++++++++++++++++++--------------------------------- ide/wg_Segment.mli | 14 +++++-- 5 files changed, 119 insertions(+), 99 deletions(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 89f4e513ed..58f5eda62e 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -169,6 +169,55 @@ let flags_to_color f = module Doc = Document +let segment_model (doc : sentence Doc.document) : Wg_Segment.model = +object (self) + + val mutable cbs = [] + + val mutable document_length = 0 + + method length = document_length + + method changed ~callback = cbs <- callback :: cbs + + method fold : 'a. ('a -> Wg_Segment.color -> 'a) -> 'a -> 'a = fun f accu -> + let fold accu _ _ s = + let flags = List.map mem_flag_of_flag s.flags in + f accu (flags_to_color flags) + in + Doc.fold_all doc accu fold + + method private on_changed (i, f) = + let data = (i, flags_to_color f) in + List.iter (fun f -> f (`SET data)) cbs + + method private on_push s ctx = + let after = match ctx with + | None -> [] + | Some (l, _) -> l + in + List.iter (fun s -> set_index s (s.index + 1)) after; + set_index s (document_length - List.length after); + ignore ((SentenceId.connect s)#changed self#on_changed); + document_length <- document_length + 1; + List.iter (fun f -> f `INSERT) cbs + + method private on_pop s ctx = + let () = match ctx with + | None -> () + | Some (l, _) -> List.iter (fun s -> set_index s (s.index - 1)) l + in + set_index s (-1); + document_length <- document_length - 1; + List.iter (fun f -> f `REMOVE) cbs + + initializer + let _ = (Doc.connect doc)#pushed self#on_push in + let _ = (Doc.connect doc)#popped self#on_pop in + () + +end + class coqops (_script:Wg_ScriptView.script_view) (_pv:Wg_ProofView.proof_view) @@ -201,20 +250,8 @@ object(self) script#misc#set_has_tooltip true; ignore(script#misc#connect#query_tooltip ~callback:self#tooltip_callback); feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; - let on_changed (i, f) = segment#add i (flags_to_color f) in - let on_push s = - set_index s document_length; - ignore ((SentenceId.connect s)#changed on_changed); - document_length <- succ document_length; - segment#set_length document_length; - let flags = List.map mem_flag_of_flag s.flags in - segment#add s.index (flags_to_color flags); - in - let on_pop s = - set_index s (-1); - document_length <- pred document_length; - segment#set_length document_length; - in + let md = segment_model document in + segment#set_model md; let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in @@ -230,8 +267,6 @@ object(self) script#buffer#place_cursor iter; ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in - let _ = (Doc.connect document)#pushed on_push in - let _ = (Doc.connect document)#popped on_pop in let _ = segment#connect#clicked on_click in () diff --git a/ide/document.ml b/ide/document.ml index 9823e7576c..6566ee3f81 100644 --- a/ide/document.ml +++ b/ide/document.ml @@ -16,8 +16,8 @@ type id = Stateid.t class type ['a] signals = object - method popped : callback:('a -> unit) -> unit - method pushed : callback:('a -> unit) -> unit + method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit + method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit end class ['a] signal () = @@ -32,14 +32,14 @@ end type 'a document = { mutable stack : 'a sentence list; mutable context : ('a sentence list * 'a sentence list) option; - pushed_sig : 'a signal; - popped_sig : 'a signal; + pushed_sig : ('a * ('a list * 'a list) option) signal; + popped_sig : ('a * ('a list * 'a list) option) signal; } -let connect d = +let connect d : 'a signals = object - method pushed ~callback = d.pushed_sig#connect callback - method popped ~callback = d.popped_sig#connect callback + method pushed ~callback = d.pushed_sig#connect (fun (x, ctx) -> callback x ctx) + method popped ~callback = d.popped_sig#connect (fun (x, ctx) -> callback x ctx) end let create () = { @@ -49,6 +49,12 @@ let create () = { popped_sig = new signal (); } +let repr_context s = match s.context with +| None -> None +| Some (cl, cr) -> + let map s = s.data in + Some (List.map map cl, List.map map cr) + (* Invariant, only the tip is a allowed to have state_id = None *) let invariant l = l = [] || (List.hd l).state_id <> None @@ -64,12 +70,13 @@ let tip_data = function let push d x = assert(invariant d.stack); d.stack <- { data = x; state_id = None } :: d.stack; - d.pushed_sig#call x + d.pushed_sig#call (x, repr_context d) let pop = function | { stack = [] } -> raise Empty - | { stack = { data }::xs } as s -> s.stack <- xs; s.popped_sig#call data; data - + | { stack = { data }::xs } as s -> + s.stack <- xs; s.popped_sig#call (data, repr_context s); data + let focus d ~cond_top:c_start ~cond_bot:c_stop = assert(invariant d.stack); if d.context <> None then invalid_arg "focus"; diff --git a/ide/document.mli b/ide/document.mli index 0d803ff003..fb96cb6d76 100644 --- a/ide/document.mli +++ b/ide/document.mli @@ -108,8 +108,8 @@ val print : class type ['a] signals = object - method popped : callback:('a -> unit) -> unit - method pushed : callback:('a -> unit) -> unit + method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit + method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit end val connect : 'a document -> 'a signals diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index b4b02a7fa2..47fdeb127b 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -10,53 +10,13 @@ open Util type color = GDraw.color -module Segment : -sig - type +'a t - val length : 'a t -> int - val resize : 'a t -> int -> 'a t - val empty : 'a t - val add : int -> 'a -> 'a t -> 'a t - val remove : int -> 'a t -> 'a t - val fold : ('a -> 'a -> bool) -> (int -> int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b -end = -struct - type 'a t = { - length : int; - content : 'a Int.Map.t; - } - - let empty = { length = 0; content = Int.Map.empty } - - let length s = s.length - - let resize s len = - if s.length <= len then { s with length = len } - else - let filter i v = i < len in - { length = len; content = Int.Map.filter filter s.content } - - let add i v s = - if i < s.length then - { s with content = Int.Map.add i v s.content } - else s - - let remove i s = { s with content = Int.Map.remove i s.content } - - let fold eq f s accu = - let make k v (cur, accu) = match cur with - | None -> Some (k, k, v), accu - | Some (i, j, w) -> - if k = j + 1 && eq v w then Some (i, k, w), accu - else Some (k, k, v), (i, j, w) :: accu - in - let p, segments = Int.Map.fold make s.content (None, []) in - let segments = match p with - | None -> segments - | Some p -> p :: segments - in - List.fold_left (fun accu (i, j, v) -> f i j v accu) accu segments +type model_event = [ `INSERT | `REMOVE | `SET of int * color ] +class type model = +object + method changed : callback:(model_event -> unit) -> unit + method length : int + method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end let i2f = float_of_int @@ -95,7 +55,7 @@ object (self) val mutable width = 1 val mutable height = 20 - val mutable data = Segment.empty + val mutable model : model option = None val mutable default : color = `WHITE val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () val clicked = new GUtil.signal () @@ -113,10 +73,12 @@ object (self) end in let _ = box#misc#connect#size_allocate cb in - let clicked_cb ev = + let clicked_cb ev = match model with + | None -> true + | Some md -> let x = GdkEvent.Button.x ev in let (width, _) = pixmap#size in - let len = Segment.length data in + let len = md#length in let idx = f2i ((x *. i2f len) /. i2f width) in let () = clicked#call idx in true @@ -125,17 +87,23 @@ object (self) (** Initial pixmap *) draw#set_pixmap pixmap - method length = Segment.length data - - method set_length len = - data <- Segment.resize data len; - if self#misc#visible then self#refresh () + method set_model md = + model <- Some md; + let changed_cb = function + | `INSERT | `REMOVE -> + if self#misc#visible then self#refresh () + | `SET (i, color) -> + if self#misc#visible then self#fill_range color i (i + 1) + in + md#changed changed_cb - method private fill_range color i j = + method private fill_range color i j = match model with + | None -> () + | Some md -> let i = i2f i in let j = i2f j in let width = i2f width in - let len = i2f (Segment.length data) in + let len = i2f md#length in let x = f2i ((i *. width) /. len) in let x' = f2i ((j *. width) /. len) in let w = x' - x in @@ -143,14 +111,6 @@ object (self) pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true (); draw#set_mask None; - method add i color = - data <- Segment.add i color data; - if self#misc#visible then self#fill_range color i (i + 1) - - method remove i = - data <- Segment.remove i data; - if self#misc#visible then self#fill_range default i (i + 1) - method set_default_color color = default <- color method default_color = default @@ -159,11 +119,23 @@ object (self) draw#set_pixmap pixmap; self#refresh (); - method private refresh () = + method private refresh () = match model with + | None -> () + | Some md -> pixmap#set_foreground default; pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); - let fold i j v () = self#fill_range v i (j + 1) in - Segment.fold color_eq fold data (); + let make (k, cur, accu) v = match cur with + | None -> pred k, Some (k, k, v), accu + | Some (i, j, w) -> + if k = j - 1 && color_eq v w then pred k, Some (k, i, w), accu + else pred k, Some (k, k, v), (i, j, w) :: accu + in + let _, p, segments = md#fold make (md#length - 1, None, []) in + let segments = match p with + | None -> segments + | Some p -> p :: segments + in + List.iter (fun (i, j, v) -> self#fill_range v i (j + 1)) segments; draw#set_mask None; method connect = diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index 0fc8ebd75e..29cbbedacf 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -8,6 +8,8 @@ type color = GDraw.color +type model_event = [ `INSERT | `REMOVE | `SET of int * color ] + class type segment_signals = object inherit GObj.misc_signals @@ -15,15 +17,19 @@ object method clicked : callback:(int -> unit) -> GtkSignal.id end +class type model = +object + method changed : callback:(model_event -> unit) -> unit + method length : int + method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a +end + class segment : unit -> object inherit GObj.widget val obj : Gtk.widget Gtk.obj + method set_model : model -> unit method connect : segment_signals - method length : int - method set_length : int -> unit method default_color : color method set_default_color : color -> unit - method add : int -> color -> unit - method remove : int -> unit end -- cgit v1.2.3 From f358d7b4c962f5288ad9ce2dc35802666c882422 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 22 Feb 2016 10:32:57 +0100 Subject: The tactic generic argument now returns a value rather than a glob_expr. The glob_expr was actually always embedded as a VFun, so this patch should not change anything semantically. The only change occurs in the plugin API where one should use the Tacinterp.tactic_of_value function instead of Tacinterp.eval_tactic. Moreover, this patch allows to use tactics returning arguments from the ML side. --- interp/constrarg.ml | 2 +- interp/constrarg.mli | 2 +- plugins/decl_mode/decl_expr.mli | 2 +- plugins/decl_mode/decl_interp.ml | 2 +- plugins/decl_mode/decl_proof_instr.ml | 4 ++-- plugins/firstorder/g_ground.ml4 | 8 ++++---- plugins/quote/g_quote.ml4 | 13 ++++++------- plugins/setoid_ring/newring.ml | 13 +++++-------- plugins/setoid_ring/newring.mli | 4 ++-- printing/pptactic.ml | 10 ++++++---- printing/pptactic.mli | 2 +- tactics/extraargs.mli | 2 +- tactics/extratactics.ml4 | 16 ++++++++-------- tactics/g_class.ml4 | 2 +- tactics/tacinterp.ml | 7 ++----- tactics/tacinterp.mli | 2 ++ tactics/tauto.ml4 | 7 ++++--- 17 files changed, 48 insertions(+), 50 deletions(-) diff --git a/interp/constrarg.ml b/interp/constrarg.ml index b093d92e73..a48d683754 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -25,7 +25,7 @@ let wit_int_or_var = let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = Genarg.make0 None "intropattern" -let wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type = +let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = Genarg.make0 None "tactic" let wit_ident = diff --git a/interp/constrarg.mli b/interp/constrarg.mli index e1a5f4d7c9..5c26af3c2a 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -69,6 +69,6 @@ val wit_red_expr : (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type -val wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type +val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli index 79ef3d186b..9d78a51ef6 100644 --- a/plugins/decl_mode/decl_expr.mli +++ b/plugins/decl_mode/decl_expr.mli @@ -99,4 +99,4 @@ type proof_instr = (Term.constr statement, Term.constr, proof_pattern, - Tacexpr.glob_tactic_expr) gen_proof_instr + Genarg.Val.t) gen_proof_instr diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 7cfca53c50..4874552d6a 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -384,7 +384,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let interp_cut interp_it env sigma cut= let nenv,nstat = interp_it env sigma cut.cut_stat in - {cut with + { cut_using=Option.map (Tacinterp.Value.of_closure (Tacinterp.default_ist ())) cut.cut_using; cut_stat=nstat; cut_by=interp_justification_items nenv sigma cut.cut_by} diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index adfcb3e60d..090b293f5c 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -496,7 +496,7 @@ let just_tac _then cut info gls0 = None -> Proofview.V82.of_tactic automation_tac gls | Some tac -> - Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in + Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in justification (tclTHEN items_tac method_tac) gls0 let instr_cut mkstat _thus _then cut gls0 = @@ -546,7 +546,7 @@ let instr_rew _thus rew_side cut gls0 = None -> Proofview.V82.of_tactic automation_tac gls | Some tac -> - Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in + Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in let just_tac gls = justification (tclTHEN items_tac method_tac) gls in let (c_id,_) = match cut.cut_stat.st_label with diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 25509b4b5f..3e8be36993 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -135,17 +135,17 @@ END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l []) ] + [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l []) ] | [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) [] l) ] + [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l) ] | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l l') ] + [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l l') ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> - [ Proofview.V82.tactic (gen_ground_tac false (Option.map eval_tactic t) [] []) ] + [ Proofview.V82.tactic (gen_ground_tac false (Option.map (tactic_of_value ist) t) [] []) ] END open Proofview.Notations diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index fdc5c2bbda..7a3d7936a6 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -17,15 +17,14 @@ open Quote DECLARE PLUGIN "quote_plugin" let loc = Loc.ghost -let cont = (loc, Id.of_string "cont") -let x = (loc, Id.of_string "x") +let cont = Id.of_string "cont" +let x = Id.of_string "x" -let make_cont (k : glob_tactic_expr) (c : Constr.t) = +let make_cont (k : Genarg.Val.t) (c : Constr.t) = let c = Tacinterp.Value.of_constr c in - let tac = TacCall (loc, ArgVar cont, [Reference (ArgVar x)]) in - let tac = TacLetIn (false, [(cont, Tacexp k)], TacArg (loc, tac)) in - let ist = { lfun = Id.Map.singleton (snd x) c; extra = TacStore.empty; } in - Tacinterp.eval_tactic_ist ist tac + let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in + let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in + Tacinterp.eval_tactic_ist ist (TacArg (loc, tac)) TACTIC EXTEND quote [ "quote" ident(f) ] -> [ quote f [] ] diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index a67cc7cb87..37a8959767 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -176,19 +176,16 @@ let ltac_call tac (args:glob_tactic_arg list) = let ltac_lcall tac args = TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args)) -let ltac_letin (x, e1) e2 = - TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2) - -let ltac_apply (f:glob_tactic_expr) (args: Tacinterp.Value.t list) = +let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar (Loc.ghost, id)) in (succ i, x :: vars, Id.Map.add id arg lfun) in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - Tacinterp.eval_tactic_ist ist - (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args)) + Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) let ltac_record flds = TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds) @@ -774,7 +771,7 @@ let ltac_ring_structure e = [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] -let ring_lookup (f:glob_tactic_expr) lH rl t = +let ring_lookup (f : Value.t) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in @@ -1046,7 +1043,7 @@ let ltac_field_structure e = [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] -let field_lookup (f:glob_tactic_expr) lH rl t = +let field_lookup (f : Value.t) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index 4bd3383d65..07a1ae833b 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -45,7 +45,7 @@ val ic : constr_expr -> Evd.evar_map * constr val from_name : ring_info Spmap.t ref val ring_lookup : - glob_tactic_expr -> + Genarg.Val.t -> constr list -> constr list -> constr -> unit Proofview.tactic @@ -73,6 +73,6 @@ val add_field_theory : val field_from_name : field_info Spmap.t ref val field_lookup : - glob_tactic_expr -> + Genarg.Val.t -> constr list -> constr list -> constr -> unit Proofview.tactic diff --git a/printing/pptactic.ml b/printing/pptactic.ml index c00036bb3c..ed85b21478 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -61,7 +61,7 @@ type 'a glob_extra_genarg_printer = type 'a extra_genarg_printer = (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds let genarg_pprule = ref String.Map.empty @@ -106,6 +106,8 @@ module Make let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) + let pr_value _ _ = str "(* FIXME *)" + let pr_with_occurrences pr (occs,c) = match occs with | AllOccurrences -> @@ -1308,10 +1310,10 @@ module Make pr_generic = Genprint.generic_top_print; pr_extend = pr_extend_rec (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - (pr_glob_tactic_level env) pr_constr_pattern; + pr_value pr_constr_pattern; pr_alias = pr_alias (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - (pr_glob_tactic_level env) pr_constr_pattern; + pr_value pr_constr_pattern; } in make_pr_tac @@ -1330,7 +1332,7 @@ module Make let pr_top_generic env = pr_top_generic_rec (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - (pr_glob_tactic_level env) pr_constr_pattern + pr_value pr_constr_pattern let pr_raw_extend env = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr diff --git a/printing/pptactic.mli b/printing/pptactic.mli index 2bc64509f0..31a5a5d4a8 100644 --- a/printing/pptactic.mli +++ b/printing/pptactic.mli @@ -32,7 +32,7 @@ type 'a glob_extra_genarg_printer = type 'a extra_genarg_printer = (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds val declare_extra_genarg_pprule : diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 7c206d95cb..7df845e4bd 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -47,7 +47,7 @@ val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry val wit_by_arg_tac : (raw_tactic_expr option, glob_tactic_expr option, - glob_tactic_expr option) Genarg.genarg_type + Genarg.Val.t option) Genarg.genarg_type val pr_by_arg_tac : (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index cdf29e4c62..151949c3c6 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -44,7 +44,7 @@ let with_delayed_uconstr ist c tac = let replace_in_clause_maybe_by ist c1 c2 cl tac = with_delayed_uconstr ist c1 - (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac)) + (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) @@ -237,7 +237,7 @@ TACTIC EXTEND autorewrite [ auto_multi_rewrite l ( cl) ] | [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> [ - auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl + auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl ] END @@ -245,14 +245,14 @@ TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> [ auto_multi_rewrite ~conds:AllMatches l cl ] | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ] + [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] END (**********************************************************************) (* Rewrite star *) -let rewrite_star ist clause orient occs c (tac : glob_tactic_expr option) = - let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in +let rewrite_star ist clause orient occs c (tac : Val.t option) = + let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in with_delayed_uconstr ist c (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) @@ -512,12 +512,12 @@ let add_transitivity_lemma left lem = (* Vernacular syntax *) TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ] +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] | ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] END TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ] +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] | ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] END @@ -883,7 +883,7 @@ END TACTIC EXTEND unshelve | [ "unshelve" tactic1(t) ] -> [ - Proofview.with_shelf (Tacinterp.eval_tactic t) >>= fun (gls, ()) -> + Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> Proofview.Unsafe.tclGETGOALS >>= fun ogls -> Proofview.Unsafe.tclSETGOALS (gls @ ogls) ] diff --git a/tactics/g_class.ml4 b/tactics/g_class.ml4 index e0c1f671fd..766593543c 100644 --- a/tactics/g_class.ml4 +++ b/tactics/g_class.ml4 @@ -14,7 +14,7 @@ open Class_tactics DECLARE PLUGIN "g_class" TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ] + [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] END (** Options: depth, debug and transparency settings. *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 2af21fac6e..cb4a9f320d 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1458,7 +1458,7 @@ and tactic_of_value ist vle = | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in - eval_tactic ist tac + tactic_of_value ist tac else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") (* Interprets the clauses of a recursive LetIn *) @@ -2232,10 +2232,7 @@ let () = () let () = - let interp ist tac = - let f = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - Ftactic.return (TacArg (dloc, TacGeneric (Genarg.in_gen (glbwit wit_tacvalue) f))) - in + let interp ist tac = Ftactic.return (Value.of_closure ist tac) in Geninterp.register_interp0 wit_tactic interp let () = diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 89d34231b8..c5da3494cb 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -88,6 +88,8 @@ val eval_tactic : glob_tactic_expr -> unit Proofview.tactic val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic (** Same as [eval_tactic], but with the provided [interp_sign]. *) +val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic + (** Globalization + interpretation *) val interp_tac_gen : value Id.Map.t -> Id.t list -> diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 4dc5388eeb..5485f344b3 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -352,7 +352,6 @@ let t_reduction_not_iff = tacticIn reduction_not_iff "reduction_not_iff" let intuition_gen ist flags tac = Proofview.Goal.enter { enter = begin fun gl -> - let tac = Value.of_closure ist tac in let env = Proofview.Goal.env gl in let vars, ist, intuition = tauto_intuit flags t_reduction_not_iff tac in let glb_intuition = Tacintern.glob_tactic_env vars env intuition in @@ -360,8 +359,9 @@ let intuition_gen ist flags tac = end } let tauto_intuitionistic flags = + let fail = Value.of_closure (default_ist ()) <:tactic> in Proofview.tclORELSE - (intuition_gen (default_ist ()) flags <:tactic>) + (intuition_gen (default_ist ()) flags fail) begin function (e, info) -> match e with | Refiner.FailError _ | UserError _ -> Tacticals.New.tclZEROMSG (str "tauto failed.") @@ -395,7 +395,8 @@ let tauto_gen flags = let default_intuition_tac = let tac _ _ = Auto.h_auto None [] None in - register_tauto_tactic tac "auto_with" + let tac = register_tauto_tactic tac "auto_with" in + Value.of_closure (default_ist ()) tac (* This is the uniform mode dealing with ->, not, iff and types isomorphic to /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. -- cgit v1.2.3 From 33fe6e61ff2f1f8184373ed8fccc403591c4605a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 21 Feb 2016 17:13:26 +0100 Subject: Moving the Tauto tactic to proper Ltac. This gets rid of brittle code written in ML files through Ltac quotations, and reduces the dependance of Coq to such a feature. This also fixes the particular instance of bug #2800, although the underlying issue is still there. --- plugins/funind/invfun.ml | 11 +- tactics/tauto.ml4 | 249 +++++++----------------------------------- tactics/tauto.mli | 0 test-suite/bugs/closed/2800.v | 6 + test-suite/bugs/opened/2800.v | 6 - theories/Init/Notations.v | 1 - theories/Init/Prelude.v | 1 + theories/Init/Tauto.v | 101 +++++++++++++++++ theories/Init/vo.itarget | 3 +- theories/Logic/Decidable.v | 2 +- 10 files changed, 161 insertions(+), 219 deletions(-) create mode 100644 tactics/tauto.mli create mode 100644 test-suite/bugs/closed/2800.v delete mode 100644 test-suite/bugs/opened/2800.v create mode 100644 theories/Init/Tauto.v diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index cdb9c5067f..6a5a5ad533 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -474,6 +474,15 @@ let generalize_dependent_of x hyp g = (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) *) +let tauto = + let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let mp = ModPath.MPfile (DirPath.make dp) in + let kn = KerName.make2 mp (Label.make "tauto") in + Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body + end + let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = @@ -530,7 +539,7 @@ and intros_with_rewrite_aux : tactic = ] g end | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> - Proofview.V82.of_tactic Tauto.tauto g + Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ Proofview.V82.of_tactic (simplest_case v); diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 5485f344b3..e0427ae89a 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -14,6 +14,7 @@ open Names open Pp open Genarg open Stdarg +open Misctypes open Tacexpr open Tacinterp open Tactics @@ -90,6 +91,7 @@ let _ = (** Base tactics *) +let loc = Loc.ghost let idtac = Proofview.tclUNIT () let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) @@ -112,38 +114,9 @@ let split = Tactics.split_with_bindings false [Misctypes.NoBindings] (** Test *) -let make_lfun l = - let fold accu (id, v) = Id.Map.add (Id.of_string id) v accu in - List.fold_left fold Id.Map.empty l - -let register_tauto_tactic tac name = - let name = { mltac_plugin = "tauto"; mltac_tactic = name; } in - let entry = { mltac_name = name; mltac_index = 0 } in - Tacenv.register_ml_tactic name [| tac |]; - TacML (Loc.ghost, entry, []) - -let tacticIn_ist tac name = - let tac _ ist = - let avoid = Option.default [] (TacStore.get ist.extra f_avoid_ids) in - let debug = Option.default Tactic_debug.DebugOff (TacStore.get ist.extra f_debug) in - let (tac, ist) = tac ist in - interp_tac_gen ist.lfun avoid debug tac - in - register_tauto_tactic tac name - -let tacticIn tac name = - tacticIn_ist (fun ist -> tac ist, ist) name - -let push_ist ist args = - let fold accu (id, arg) = Id.Map.add (Id.of_string id) arg accu in - let lfun = List.fold_left fold ist.lfun args in - { ist with lfun = lfun } - let is_empty _ ist = if is_empty_type (assoc_var "X1" ist) then idtac else fail -let t_is_empty = register_tauto_tactic is_empty "is_empty" - (* Strictly speaking, this exceeds the propositional fragment as it matches also equality types (and solves them if a reflexivity) *) let is_unit_or_eq _ ist = @@ -151,16 +124,6 @@ let is_unit_or_eq _ ist = let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in if test (assoc_var "X1" ist) then idtac else fail -let t_is_unit_or_eq = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" - -let is_record t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind (ind,u) -> - let (mib,mip) = Global.lookup_inductive ind in - mib.Declarations.mind_record <> None - | _ -> false - let bugged_is_binary t = isApp t && let (hdapp,args) = decompose_app t in @@ -182,8 +145,6 @@ let is_conj _ ist = then idtac else fail -let t_is_conj = register_tauto_tactic is_conj "is_conj" - let flatten_contravariant_conj _ ist = let flags = assoc_flags ist in let typ = assoc_var "X1" ist in @@ -200,18 +161,8 @@ let flatten_contravariant_conj _ ist = tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] | _ -> fail -let t_flatten_contravariant_conj = - register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" - (** Dealing with disjunction *) -let constructor i = - let name = { Tacexpr.mltac_plugin = "coretactics"; mltac_tactic = "constructor" } in - (** Take care of the index: this is the second entry in constructor. *) - let name = { Tacexpr.mltac_name = name; mltac_index = 1 } in - let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in - Tacexpr.TacML (Loc.ghost, name, [TacGeneric i]) - let is_disj _ ist = let flags = assoc_flags ist in let t = assoc_var "X1" ist in @@ -222,8 +173,6 @@ let is_disj _ ist = then idtac else fail -let t_is_disj = register_tauto_tactic is_disj "is_disj" - let flatten_contravariant_disj _ ist = let flags = assoc_flags ist in let typ = assoc_var "X1" ist in @@ -245,159 +194,30 @@ let flatten_contravariant_disj _ ist = tclTHEN (tclTHENLIST tacs) tac0 | _ -> fail -let t_flatten_contravariant_disj = - register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" - -(** Main tactic *) - -let not_dep_intros ist = - <:tactic< - repeat match goal with - | |- (forall (_: ?X1), ?X2) => intro - | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro - end >> - -let t_not_dep_intros = tacticIn not_dep_intros "not_dep_intros" - -let axioms ist = - let c1 = constructor 1 in - <:tactic< - match reverse goal with - | |- ?X1 => $t_is_unit_or_eq; $c1 - | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption - | _:?X1 |- ?X1 => assumption - end >> - -let t_axioms = tacticIn axioms "axioms" - -let simplif ist = - let c1 = constructor 1 in - <:tactic< - $t_not_dep_intros; - repeat - (match reverse goal with - | id: ?X1 |- _ => $t_is_conj; elim id; do 2 intro; clear id - | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id - | id: (Coq.Init.Logic.not _) |- _ => red in id - | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id - | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ => - (* generalize (id0 id1); intro; clear id0 does not work - (see Marco Maggiesi's bug PR#301) - so we instead use Assert and exact. *) - assert X2; [exact (id0 id1) | clear id0] - | id: forall (_ : ?X1), ?X2|- _ => - $t_is_unit_or_eq; cut X2; - [ intro; clear id - | (* id : forall (_: ?X1), ?X2 |- ?X2 *) - cut X1; [exact id| $c1; fail] - ] - | id: forall (_ : ?X1), ?X2|- _ => - $t_flatten_contravariant_conj - (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *) - | id: forall (_: Coq.Init.Logic.iff ?X1 ?X2), ?X3|- _ => - assert (forall (_: forall _:X1, X2), forall (_: forall _: X2, X1), X3) - by (do 2 intro; apply id; split; assumption); - clear id - | id: forall (_:?X1), ?X2|- _ => - $t_flatten_contravariant_disj - (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *) - | |- ?X1 => $t_is_conj; split - | |- (Coq.Init.Logic.iff _ _) => split - | |- (Coq.Init.Logic.not _) => red - end; - $t_not_dep_intros) >> - -let t_simplif = tacticIn simplif "simplif" - -let tauto_intuit flags t_reduce solver = - let flags = Genarg.Val.Dyn (Genarg.val_tag (topwit wit_tauto_flags), flags) in - let lfun = make_lfun [("t_solver", solver); ("tauto_flags", flags)] in - let ist = { default_ist () with lfun = lfun; } in - let vars = [Id.of_string "t_solver"] in - (vars, ist, <:tactic< - let rec t_tauto_intuit := - ($t_simplif;$t_axioms - || match reverse goal with - | id:forall(_: forall (_: ?X1), ?X2), ?X3|- _ => - cut X3; - [ intro; clear id; t_tauto_intuit - | cut (forall (_: X1), X2); - [ exact id - | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; - solve [ t_tauto_intuit ]]] - | id:forall (_:not ?X1), ?X3|- _ => - cut X3; - [ intro; clear id; t_tauto_intuit - | cut (not X1); [ exact id | clear id; intro; solve [t_tauto_intuit ]]] - | |- ?X1 => - $t_is_disj; solve [left;t_tauto_intuit | right;t_tauto_intuit] - end - || - (* NB: [|- _ -> _] matches any product *) - match goal with | |- forall (_ : _), _ => intro; t_tauto_intuit - | |- _ => $t_reduce;t_solver - end - || - t_solver - ) in t_tauto_intuit >>) - -let reduction_not_iff _ist = - match !negation_unfolding, unfold_iff () with +let reduction_not_iff _ ist = + let avoid = Option.default [] (TacStore.get ist.extra f_avoid_ids) in + let debug = Option.default Tactic_debug.DebugOff (TacStore.get ist.extra f_debug) in + let tac = match !negation_unfolding, unfold_iff () with | true, true -> <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> | true, false -> <:tactic< unfold Coq.Init.Logic.not in * >> | false, true -> <:tactic< unfold Coq.Init.Logic.iff in * >> | false, false -> <:tactic< idtac >> - -let t_reduction_not_iff = tacticIn reduction_not_iff "reduction_not_iff" - -let intuition_gen ist flags tac = - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let vars, ist, intuition = tauto_intuit flags t_reduction_not_iff tac in - let glb_intuition = Tacintern.glob_tactic_env vars env intuition in - eval_tactic_ist ist glb_intuition - end } - -let tauto_intuitionistic flags = - let fail = Value.of_closure (default_ist ()) <:tactic> in - Proofview.tclORELSE - (intuition_gen (default_ist ()) flags fail) - begin function (e, info) -> match e with - | Refiner.FailError _ | UserError _ -> - Tacticals.New.tclZEROMSG (str "tauto failed.") - | e -> Proofview.tclZERO ~info e - end + in + interp_tac_gen ist.lfun avoid debug tac let coq_nnpp_path = let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") -let tauto_classical flags nnpp = - Proofview.tclORELSE - (Tacticals.New.tclTHEN (apply nnpp) (tauto_intuitionistic flags)) - begin function (e, info) -> match e with - | UserError _ -> Tacticals.New.tclZEROMSG (str "Classical tauto failed.") - | e -> Proofview.tclZERO ~info e - end - -let tauto_gen flags = - (* spiwack: I use [tclBIND (tclUNIT ())] as a way to delay the effect - (in [constr_of_global]) to the application of the tactic. *) +let apply_nnpp _ ist = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> try let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in - (* try intuitionistic version first to avoid an axiom if possible *) - Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp) - with Not_found -> - tauto_intuitionistic flags + apply nnpp + with Not_found -> tclFAIL 0 (Pp.mt ()) end -let default_intuition_tac = - let tac _ _ = Auto.h_auto None [] None in - let tac = register_tauto_tactic tac "auto_with" in - Value.of_closure (default_ist ()) tac - (* This is the uniform mode dealing with ->, not, iff and types isomorphic to /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. For the moment not and iff are still always unfolded. *) @@ -427,23 +247,34 @@ let tauto_power_flags = { strict_unit = false } -let tauto = tauto_gen tauto_uniform_unit_flags -let dtauto = tauto_gen tauto_power_flags - -TACTIC EXTEND tauto -| [ "tauto" ] -> [ tauto ] -END - -TACTIC EXTEND dtauto -| [ "dtauto" ] -> [ dtauto ] +let with_flags flags ist tac = + let f = (loc, Id.of_string "f") in + let x = (loc, Id.of_string "x") in + let arg = Val.Dyn (val_tag (topwit wit_tauto_flags), flags) in + let ist = { ist with lfun = Id.Map.add (snd f) tac (Id.Map.add (snd x) arg ist.lfun) } in + eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) + +TACTIC EXTEND with_flags +| [ "with_uniform_flags" tactic(tac) ] -> [ with_flags tauto_uniform_unit_flags ist tac ] +| [ "with_legacy_flags" tactic(tac) ] -> [ with_flags tauto_legacy_flags ist tac ] +| [ "with_power_flags" tactic(tac) ] -> [ with_flags tauto_power_flags ist tac ] END -TACTIC EXTEND intuition -| [ "intuition" ] -> [ intuition_gen ist tauto_uniform_unit_flags default_intuition_tac ] -| [ "intuition" tactic(t) ] -> [ intuition_gen ist tauto_uniform_unit_flags t ] -END - -TACTIC EXTEND dintuition -| [ "dintuition" ] -> [ intuition_gen ist tauto_power_flags default_intuition_tac ] -| [ "dintuition" tactic(t) ] -> [ intuition_gen ist tauto_power_flags t ] -END +let register_tauto_tactic_ tac name0 args = + let ids = List.map (fun id -> Id.of_string id) args in + let ids = List.map (fun id -> Some id) ids in + let name = { mltac_plugin = "tauto"; mltac_tactic = name0 ^ "_"; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let () = Tacenv.register_ml_tactic name [| tac |] in + let tac = TacFun (ids, TacML (loc, entry, [])) in + let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in + Mltop.declare_cache_obj obj "tauto" + +let () = register_tauto_tactic_ is_empty "is_empty" ["tauto_flags"; "X1"] +let () = register_tauto_tactic_ is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] +let () = register_tauto_tactic_ is_disj "is_disj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic_ is_conj "is_conj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic_ flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic_ flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic_ apply_nnpp "apply_nnpp" [] +let () = register_tauto_tactic_ reduction_not_iff "reduction_not_iff" [] diff --git a/tactics/tauto.mli b/tactics/tauto.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/test-suite/bugs/closed/2800.v b/test-suite/bugs/closed/2800.v new file mode 100644 index 0000000000..2ee438934e --- /dev/null +++ b/test-suite/bugs/closed/2800.v @@ -0,0 +1,6 @@ +Goal False. + +intuition + match goal with + | |- _ => idtac " foo" + end. diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/opened/2800.v deleted file mode 100644 index c559ab0c17..0000000000 --- a/test-suite/bugs/opened/2800.v +++ /dev/null @@ -1,6 +0,0 @@ -Goal False. - -Fail intuition - match goal with - | |- _ => idtac " foo" - end. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index e1ddaeaeff..55eb699be6 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -90,4 +90,3 @@ Declare ML Module "eauto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". Declare ML Module "g_rewrite". -Declare ML Module "tauto". diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 04a263ad94..03f2328dec 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -15,6 +15,7 @@ Require Coq.Init.Nat. Require Export Peano. Require Export Coq.Init.Wf. Require Export Coq.Init.Tactics. +Require Export Coq.Init.Tauto. (* Initially available plugins (+ nat_syntax_plugin loaded in Datatypes) *) Declare ML Module "extraction_plugin". diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v new file mode 100644 index 0000000000..e0949eb732 --- /dev/null +++ b/theories/Init/Tauto.v @@ -0,0 +1,101 @@ +Require Import Notations. +Require Import Datatypes. +Require Import Logic. + +Local Declare ML Module "tauto". + +Local Ltac not_dep_intros := + repeat match goal with + | |- (forall (_: ?X1), ?X2) => intro + | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro + end. + +Local Ltac axioms flags := + match reverse goal with + | |- ?X1 => is_unit_or_eq flags X1; constructor 1 + | _:?X1 |- _ => is_empty flags X1; elimtype X1; assumption + | _:?X1 |- ?X1 => assumption + end. + +Local Ltac simplif flags := + not_dep_intros; + repeat + (match reverse goal with + | id: ?X1 |- _ => is_conj flags X1; elim id; do 2 intro; clear id + | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id + | id: (Coq.Init.Logic.not _) |- _ => red in id + | id: ?X1 |- _ => is_disj flags X1; elim id; intro; clear id + | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ => + (* generalize (id0 id1); intro; clear id0 does not work + (see Marco Maggiesi's bug PR#301) + so we instead use Assert and exact. *) + assert X2; [exact (id0 id1) | clear id0] + | id: forall (_ : ?X1), ?X2|- _ => + is_unit_or_eq flags X1; cut X2; + [ intro; clear id + | (* id : forall (_: ?X1), ?X2 |- ?X2 *) + cut X1; [exact id| constructor 1; fail] + ] + | id: forall (_ : ?X1), ?X2|- _ => + flatten_contravariant_conj flags X1 X2 id + (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *) + | id: forall (_: Coq.Init.Logic.iff ?X1 ?X2), ?X3|- _ => + assert (forall (_: forall _:X1, X2), forall (_: forall _: X2, X1), X3) + by (do 2 intro; apply id; split; assumption); + clear id + | id: forall (_:?X1), ?X2|- _ => + flatten_contravariant_disj flags X1 X2 id + (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *) + | |- ?X1 => is_conj flags X1; split + | |- (Coq.Init.Logic.iff _ _) => split + | |- (Coq.Init.Logic.not _) => red + end; + not_dep_intros). + +Local Ltac tauto_intuit flags t_reduce t_solver := + let rec t_tauto_intuit := + (simplif flags; axioms flags + || match reverse goal with + | id:forall(_: forall (_: ?X1), ?X2), ?X3|- _ => + cut X3; + [ intro; clear id; t_tauto_intuit + | cut (forall (_: X1), X2); + [ exact id + | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; + solve [ t_tauto_intuit ]]] + | id:forall (_:not ?X1), ?X3|- _ => + cut X3; + [ intro; clear id; t_tauto_intuit + | cut (not X1); [ exact id | clear id; intro; solve [t_tauto_intuit ]]] + | |- ?X1 => + is_disj flags X1; solve [left;t_tauto_intuit | right;t_tauto_intuit] + end + || + (* NB: [|- _ -> _] matches any product *) + match goal with | |- forall (_ : _), _ => intro; t_tauto_intuit + | |- _ => t_reduce;t_solver + end + || + t_solver + ) in t_tauto_intuit. + +Local Ltac intuition_gen flags solver := tauto_intuit flags reduction_not_iff solver. +Local Ltac tauto_intuitionistic flags := intuition_gen flags fail || fail "tauto failed". +Local Ltac tauto_classical flags := + (apply_nnpp || fail "tauto failed"); (tauto_intuitionistic flags || fail "Classical tauto failed"). +Local Ltac tauto_gen flags := tauto_intuitionistic flags || tauto_classical flags. + +Ltac tauto := with_uniform_flags (fun flags => tauto_gen flags). +Ltac dtauto := with_power_flags (fun flags => tauto_gen flags). + +Ltac intuition := with_uniform_flags (fun flags => intuition_gen flags ltac:(auto with *)). +Local Ltac intuition_then tac := with_uniform_flags (fun flags => intuition_gen flags tac). + +Ltac dintuition := with_power_flags (fun flags => intuition_gen flags ltac:(auto with *)). +Local Ltac dintuition_then tac := with_power_flags (fun flags => intuition_gen flags tac). + +Tactic Notation "intuition" := intuition. +Tactic Notation "intuition" tactic(t) := intuition_then t. + +Tactic Notation "dintuition" := dintuition. +Tactic Notation "dintuition" tactic(t) := dintuition_then t. diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget index cc62e66cce..99877065e8 100644 --- a/theories/Init/vo.itarget +++ b/theories/Init/vo.itarget @@ -7,4 +7,5 @@ Prelude.vo Specif.vo Tactics.vo Wf.vo -Nat.vo \ No newline at end of file +Nat.vo +Tauto.vo diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 2ba7253c44..8b6054f9d0 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -50,7 +50,7 @@ Qed. Theorem dec_iff : forall A B:Prop, decidable A -> decidable B -> decidable (A<->B). Proof. -unfold decidable; tauto. +unfold decidable. tauto. Qed. Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P. -- cgit v1.2.3 From 55ce331822a673d710451c628ec5a731ab36da1f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 2 Feb 2016 15:28:48 +0100 Subject: Fix bug #4544: Backtrack on using full betaiota reduction during keyed unification. --- tactics/equality.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index ef1ec13bae..80f6038cb7 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -228,8 +228,8 @@ let rewrite_keyed_core_unif_flags = { (* This is set dynamically *) restrict_conv_on_strict_subterms = false; - modulo_betaiota = true; - (* Different from conv_closed *) + modulo_betaiota = false; + modulo_eta = true; } -- cgit v1.2.3 From 5bca0e81c46c1cc6427f939263670996f570dbcf Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 2 Feb 2016 15:47:23 +0100 Subject: Fix part of bug #4533: respect declared global transparency of projections in unification.ml --- pretyping/unification.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 6cb1bc7028..55210d067e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -481,7 +481,8 @@ let key_of env b flags f = Id.Pred.mem id (fst flags.modulo_delta) -> Some (IsKey (VarKey id)) | Proj (p, c) when Projection.unfolded p - || Cpred.mem (Projection.constant p) (snd flags.modulo_delta) -> + || (is_transparent env (ConstKey (Projection.constant p)) && + (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) -> Some (IsProj (p, c)) | _ -> None -- cgit v1.2.3 From e7b292de756b335069fce9d9a999904ea2af6630 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 23 Feb 2016 18:21:02 +0100 Subject: Document differences of Hint Resolve and Hint Extern --- test-suite/success/auto.v | 89 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index aaa7b3a514..5477c83316 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -45,3 +45,92 @@ Proof. eexists. Fail progress debug eauto with test2. progress eauto with test. Qed. + +(** Patterns of Extern have a "matching" semantics. + It is not so for apply/exact hints *) + +Class B (A : Type). +Class I. +Instance i : I. + +Definition flip {A B C : Type} (f : A -> B -> C) := fun y x => f x y. +Class D (f : nat -> nat -> nat). +Definition ftest (x y : nat) := x + y. +Definition flipD (f : nat -> nat -> nat) : D f -> D (flip f). + Admitted. +Module Instnopat. + Local Instance: B nat. + (* pattern_of_constr -> B nat *) + (* exact hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. + + Local Instance: D ftest. + Local Hint Resolve flipD | 0 : typeclass_instances. + (* pattern: D (flip _) *) + Fail Timeout 1 Check (_ : D _). (* loops applying flipD *) + +End Instnopat. + +Module InstnopatApply. + Local Instance: I -> B nat. + (* pattern_of_constr -> B nat *) + (* apply hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. +End InstnopatApply. + +Module InstPat. + Hint Extern 3 (B nat) => split : typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> true *) + Check (_ : B nat). + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false: + Because an inductive in the pattern does not match an evar in the goal *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + (* map_existential -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail progress eauto with typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail typeclasses eauto. + Abort. + + Hint Extern 0 (D (flip _)) => apply flipD : typeclass_instances. + Module withftest. + Local Instance: D ftest. + + Check (_ : D _). + (* D_instance_0 : D ftest *) + Check (_ : D (flip _)). + (* ... : D (flip ftest) *) + End withftest. + Module withoutftest. + Hint Extern 0 (D ftest) => split : typeclass_instances. + Check (_ : D _). + (* ? : D ?, _not_ looping *) + Check (_ : D (flip _)). + (* ? : D (flip ?), _not_ looping *) + + Check (_ : D (flip ftest)). + (* flipD ftest {| |} : D (flip ftest) *) + End withoutftest. +End InstPat. -- cgit v1.2.3 From 7fb5a9c518f30298a7a9332f0280c2ca0e690f18 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 23 Feb 2016 10:28:00 +0100 Subject: Moving tauto.ml4 to a proper ML file. --- tactics/tauto.ml | 284 ++++++++++++++++++++++++++++++++++++++++++++++++++ tactics/tauto.ml4 | 280 ------------------------------------------------- theories/Init/Tauto.v | 12 +-- 3 files changed, 290 insertions(+), 286 deletions(-) create mode 100644 tactics/tauto.ml delete mode 100644 tactics/tauto.ml4 diff --git a/tactics/tauto.ml b/tactics/tauto.ml new file mode 100644 index 0000000000..67ef25d49f --- /dev/null +++ b/tactics/tauto.ml @@ -0,0 +1,284 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* c + | None -> failwith "tauto: anomaly" + +(** Parametrization of tauto *) + +type tauto_flags = { + +(* Whether conjunction and disjunction are restricted to binary connectives *) + binary_mode : bool; + +(* Whether compatibility for buggy detection of binary connective is on *) + binary_mode_bugged_detection : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* contravariant position in an hypothesis *) + strict_in_contravariant_hyp : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* an hypothesis and in the conclusion *) + strict_in_hyp_and_ccl : bool; + +(* Whether unit type includes equality types *) + strict_unit : bool; +} + +let wit_tauto_flags : tauto_flags uniform_genarg_type = + Genarg.create_arg None "tauto_flags" + +let assoc_flags ist = + let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in + try Value.cast (topwit wit_tauto_flags) v with _ -> assert false + +(* Whether inner not are unfolded *) +let negation_unfolding = ref true + +(* Whether inner iff are unfolded *) +let iff_unfolding = ref false + +let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of not in intuition"; + optkey = ["Intuition";"Negation";"Unfolding"]; + optread = (fun () -> !negation_unfolding); + optwrite = (:=) negation_unfolding } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of iff in intuition"; + optkey = ["Intuition";"Iff";"Unfolding"]; + optread = (fun () -> !iff_unfolding); + optwrite = (:=) iff_unfolding } + +(** Base tactics *) + +let loc = Loc.ghost +let idtac = Proofview.tclUNIT () +let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) + +let intro = Tactics.intro + +let assert_ ?by c = + let tac = match by with + | None -> None + | Some tac -> Some (tclCOMPLETE tac) + in + Proofview.tclINDEPENDENT (Tactics.forward true tac None c) + +let apply c = Tactics.apply c + +let clear id = Proofview.V82.tactic (fun gl -> Tactics.clear [id] gl) + +let assumption = Tactics.assumption + +let split = Tactics.split_with_bindings false [Misctypes.NoBindings] + +(** Test *) + +let is_empty _ ist = + if is_empty_type (assoc_var "X1" ist) then idtac else fail + +(* Strictly speaking, this exceeds the propositional fragment as it + matches also equality types (and solves them if a reflexivity) *) +let is_unit_or_eq _ ist = + let flags = assoc_flags ist in + let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in + if test (assoc_var "X1" ist) then idtac else fail + +let bugged_is_binary t = + isApp t && + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind (ind,u) -> + let (mib,mip) = Global.lookup_inductive ind in + Int.equal mib.Declarations.mind_nparams 2 + | _ -> false + +(** Dealing with conjunction *) + +let is_conj _ ist = + let flags = assoc_flags ist in + let ind = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && + is_conjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode ind + then idtac + else fail + +let flatten_contravariant_conj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_conjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode typ + with + | Some (_,args) -> + let newtyp = List.fold_right mkArrow args c in + let intros = tclMAP (fun _ -> intro) args in + let by = tclTHENLIST [intros; apply hyp; split; assumption] in + tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] + | _ -> fail + +(** Dealing with disjunction *) + +let is_disj _ ist = + let flags = assoc_flags ist in + let t = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && + is_disjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode t + then idtac + else fail + +let flatten_contravariant_disj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_disjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode + typ with + | Some (_,args) -> + let map i arg = + let typ = mkArrow arg c in + let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in + let by = tclTHENLIST [intro; apply hyp; ci; assumption] in + assert_ ~by typ + in + let tacs = List.mapi map args in + let tac0 = clear (destVar hyp) in + tclTHEN (tclTHENLIST tacs) tac0 + | _ -> fail + +let make_unfold name = + let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in + let const = Constant.make2 (MPfile dir) (Label.make name) in + (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + +let u_iff = make_unfold "iff" +let u_not = make_unfold "not" + +let reduction_not_iff _ ist = + let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let tac = match !negation_unfolding, unfold_iff () with + | true, true -> make_reduce [u_not; u_iff] + | true, false -> make_reduce [u_not] + | false, true -> make_reduce [u_iff] + | false, false -> TacId [] + in + eval_tactic_ist ist tac + +let coq_nnpp_path = + let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in + Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") + +let apply_nnpp _ ist = + Proofview.tclBIND + (Proofview.tclUNIT ()) + begin fun () -> try + let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in + apply nnpp + with Not_found -> tclFAIL 0 (Pp.mt ()) + end + +(* This is the uniform mode dealing with ->, not, iff and types isomorphic to + /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. + For the moment not and iff are still always unfolded. *) +let tauto_uniform_unit_flags = { + binary_mode = true; + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = true; + strict_unit = false +} + +(* This is the compatibility mode (not used) *) +let tauto_legacy_flags = { + binary_mode = true; + binary_mode_bugged_detection = true; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +(* This is the improved mode *) +let tauto_power_flags = { + binary_mode = false; (* support n-ary connectives *) + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = false; (* supports non-regular connectives *) + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +let with_flags flags _ ist = + let f = (loc, Id.of_string "f") in + let x = (loc, Id.of_string "x") in + let arg = Val.Dyn (val_tag (topwit wit_tauto_flags), flags) in + let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in + eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) + +let register_tauto_tactic tac name0 args = + let ids = List.map (fun id -> Id.of_string id) args in + let ids = List.map (fun id -> Some id) ids in + let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let () = Tacenv.register_ml_tactic name [| tac |] in + let tac = TacFun (ids, TacML (loc, entry, [])) in + let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in + Mltop.declare_cache_obj obj tauto_plugin + +let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] +let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] +let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] +let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 deleted file mode 100644 index e0427ae89a..0000000000 --- a/tactics/tauto.ml4 +++ /dev/null @@ -1,280 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* c - | None -> failwith "tauto: anomaly" - -(** Parametrization of tauto *) - -type tauto_flags = { - -(* Whether conjunction and disjunction are restricted to binary connectives *) - binary_mode : bool; - -(* Whether compatibility for buggy detection of binary connective is on *) - binary_mode_bugged_detection : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* contravariant position in an hypothesis *) - strict_in_contravariant_hyp : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* an hypothesis and in the conclusion *) - strict_in_hyp_and_ccl : bool; - -(* Whether unit type includes equality types *) - strict_unit : bool; -} - -let wit_tauto_flags : tauto_flags uniform_genarg_type = - Genarg.create_arg None "tauto_flags" - -let assoc_flags ist = - let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in - try Value.cast (topwit wit_tauto_flags) v with _ -> assert false - -(* Whether inner not are unfolded *) -let negation_unfolding = ref true - -(* Whether inner iff are unfolded *) -let iff_unfolding = ref false - -let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 - -open Goptions -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of not in intuition"; - optkey = ["Intuition";"Negation";"Unfolding"]; - optread = (fun () -> !negation_unfolding); - optwrite = (:=) negation_unfolding } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of iff in intuition"; - optkey = ["Intuition";"Iff";"Unfolding"]; - optread = (fun () -> !iff_unfolding); - optwrite = (:=) iff_unfolding } - -(** Base tactics *) - -let loc = Loc.ghost -let idtac = Proofview.tclUNIT () -let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) - -let intro = Tactics.intro - -let assert_ ?by c = - let tac = match by with - | None -> None - | Some tac -> Some (tclCOMPLETE tac) - in - Proofview.tclINDEPENDENT (Tactics.forward true tac None c) - -let apply c = Tactics.apply c - -let clear id = Proofview.V82.tactic (fun gl -> Tactics.clear [id] gl) - -let assumption = Tactics.assumption - -let split = Tactics.split_with_bindings false [Misctypes.NoBindings] - -(** Test *) - -let is_empty _ ist = - if is_empty_type (assoc_var "X1" ist) then idtac else fail - -(* Strictly speaking, this exceeds the propositional fragment as it - matches also equality types (and solves them if a reflexivity) *) -let is_unit_or_eq _ ist = - let flags = assoc_flags ist in - let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test (assoc_var "X1" ist) then idtac else fail - -let bugged_is_binary t = - isApp t && - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind (ind,u) -> - let (mib,mip) = Global.lookup_inductive ind in - Int.equal mib.Declarations.mind_nparams 2 - | _ -> false - -(** Dealing with conjunction *) - -let is_conj _ ist = - let flags = assoc_flags ist in - let ind = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && - is_conjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode ind - then idtac - else fail - -let flatten_contravariant_conj _ ist = - let flags = assoc_flags ist in - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_conjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode typ - with - | Some (_,args) -> - let newtyp = List.fold_right mkArrow args c in - let intros = tclMAP (fun _ -> intro) args in - let by = tclTHENLIST [intros; apply hyp; split; assumption] in - tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] - | _ -> fail - -(** Dealing with disjunction *) - -let is_disj _ ist = - let flags = assoc_flags ist in - let t = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && - is_disjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode t - then idtac - else fail - -let flatten_contravariant_disj _ ist = - let flags = assoc_flags ist in - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_disjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode - typ with - | Some (_,args) -> - let map i arg = - let typ = mkArrow arg c in - let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in - let by = tclTHENLIST [intro; apply hyp; ci; assumption] in - assert_ ~by typ - in - let tacs = List.mapi map args in - let tac0 = clear (destVar hyp) in - tclTHEN (tclTHENLIST tacs) tac0 - | _ -> fail - -let reduction_not_iff _ ist = - let avoid = Option.default [] (TacStore.get ist.extra f_avoid_ids) in - let debug = Option.default Tactic_debug.DebugOff (TacStore.get ist.extra f_debug) in - let tac = match !negation_unfolding, unfold_iff () with - | true, true -> <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> - | true, false -> <:tactic< unfold Coq.Init.Logic.not in * >> - | false, true -> <:tactic< unfold Coq.Init.Logic.iff in * >> - | false, false -> <:tactic< idtac >> - in - interp_tac_gen ist.lfun avoid debug tac - -let coq_nnpp_path = - let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in - Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") - -let apply_nnpp _ ist = - Proofview.tclBIND - (Proofview.tclUNIT ()) - begin fun () -> try - let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in - apply nnpp - with Not_found -> tclFAIL 0 (Pp.mt ()) - end - -(* This is the uniform mode dealing with ->, not, iff and types isomorphic to - /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. - For the moment not and iff are still always unfolded. *) -let tauto_uniform_unit_flags = { - binary_mode = true; - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = true; - strict_unit = false -} - -(* This is the compatibility mode (not used) *) -let tauto_legacy_flags = { - binary_mode = true; - binary_mode_bugged_detection = true; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -(* This is the improved mode *) -let tauto_power_flags = { - binary_mode = false; (* support n-ary connectives *) - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = false; (* supports non-regular connectives *) - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -let with_flags flags ist tac = - let f = (loc, Id.of_string "f") in - let x = (loc, Id.of_string "x") in - let arg = Val.Dyn (val_tag (topwit wit_tauto_flags), flags) in - let ist = { ist with lfun = Id.Map.add (snd f) tac (Id.Map.add (snd x) arg ist.lfun) } in - eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) - -TACTIC EXTEND with_flags -| [ "with_uniform_flags" tactic(tac) ] -> [ with_flags tauto_uniform_unit_flags ist tac ] -| [ "with_legacy_flags" tactic(tac) ] -> [ with_flags tauto_legacy_flags ist tac ] -| [ "with_power_flags" tactic(tac) ] -> [ with_flags tauto_power_flags ist tac ] -END - -let register_tauto_tactic_ tac name0 args = - let ids = List.map (fun id -> Id.of_string id) args in - let ids = List.map (fun id -> Some id) ids in - let name = { mltac_plugin = "tauto"; mltac_tactic = name0 ^ "_"; } in - let entry = { mltac_name = name; mltac_index = 0 } in - let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (loc, entry, [])) in - let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in - Mltop.declare_cache_obj obj "tauto" - -let () = register_tauto_tactic_ is_empty "is_empty" ["tauto_flags"; "X1"] -let () = register_tauto_tactic_ is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] -let () = register_tauto_tactic_ is_disj "is_disj" ["tauto_flags"; "X1"] -let () = register_tauto_tactic_ is_conj "is_conj" ["tauto_flags"; "X1"] -let () = register_tauto_tactic_ flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] -let () = register_tauto_tactic_ flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] -let () = register_tauto_tactic_ apply_nnpp "apply_nnpp" [] -let () = register_tauto_tactic_ reduction_not_iff "reduction_not_iff" [] diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v index e0949eb732..1e409607ae 100644 --- a/theories/Init/Tauto.v +++ b/theories/Init/Tauto.v @@ -85,14 +85,14 @@ Local Ltac tauto_classical flags := (apply_nnpp || fail "tauto failed"); (tauto_intuitionistic flags || fail "Classical tauto failed"). Local Ltac tauto_gen flags := tauto_intuitionistic flags || tauto_classical flags. -Ltac tauto := with_uniform_flags (fun flags => tauto_gen flags). -Ltac dtauto := with_power_flags (fun flags => tauto_gen flags). +Ltac tauto := with_uniform_flags ltac:(fun flags => tauto_gen flags). +Ltac dtauto := with_power_flags ltac:(fun flags => tauto_gen flags). -Ltac intuition := with_uniform_flags (fun flags => intuition_gen flags ltac:(auto with *)). -Local Ltac intuition_then tac := with_uniform_flags (fun flags => intuition_gen flags tac). +Ltac intuition := with_uniform_flags ltac:(fun flags => intuition_gen flags ltac:(auto with *)). +Local Ltac intuition_then tac := with_uniform_flags ltac:(fun flags => intuition_gen flags tac). -Ltac dintuition := with_power_flags (fun flags => intuition_gen flags ltac:(auto with *)). -Local Ltac dintuition_then tac := with_power_flags (fun flags => intuition_gen flags tac). +Ltac dintuition := with_power_flags ltac:(fun flags => intuition_gen flags ltac:(auto with *)). +Local Ltac dintuition_then tac := with_power_flags ltac:(fun flags => intuition_gen flags tac). Tactic Notation "intuition" := intuition. Tactic Notation "intuition" tactic(t) := intuition_then t. -- cgit v1.2.3 From 60f6d46c6e623a39fc66a21cbac5aaecdf4c67c6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 23 Feb 2016 18:50:31 +0100 Subject: Getting rid of the "<:tactic< ... >>" quotations. It used to allow to represent parts of tactic AST directly in ML code. Most of the uses were trivial, only calling a constant, except for tauto that had an important code base written in this style. Removing this reduces the dependency to CAMLPX and the preeminence of Ltac in ML code. --- plugins/omega/g_omega.ml4 | 15 +++++++++++---- plugins/romega/g_romega.ml4 | 15 +++++++++++---- tactics/extratactics.ml4 | 5 ++++- 3 files changed, 26 insertions(+), 9 deletions(-) diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index c96b4a4f4a..04c62eb487 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -17,15 +17,22 @@ DECLARE PLUGIN "omega_plugin" +open Names open Coq_omega +let eval_tactic name = + let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in + let kn = KerName.make2 (MPfile dp) (Label.make name) in + let tac = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic tac + let omega_tactic l = let tacs = List.map (function - | "nat" -> Tacinterp.interp <:tactic> - | "positive" -> Tacinterp.interp <:tactic> - | "N" -> Tacinterp.interp <:tactic> - | "Z" -> Tacinterp.interp <:tactic> + | "nat" -> eval_tactic "zify_nat" + | "positive" -> eval_tactic "zify_positive" + | "N" -> eval_tactic "zify_N" + | "Z" -> eval_tactic "zify_op" | s -> Errors.error ("No Omega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 0a99a26b36..6b2b2bbfaf 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -10,15 +10,22 @@ DECLARE PLUGIN "romega_plugin" +open Names open Refl_omega +let eval_tactic name = + let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in + let kn = KerName.make2 (MPfile dp) (Label.make name) in + let tac = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic tac + let romega_tactic l = let tacs = List.map (function - | "nat" -> Tacinterp.interp <:tactic> - | "positive" -> Tacinterp.interp <:tactic> - | "N" -> Tacinterp.interp <:tactic> - | "Z" -> Tacinterp.interp <:tactic> + | "nat" -> eval_tactic "zify_nat" + | "positive" -> eval_tactic "zify_positive" + | "N" -> eval_tactic "zify_N" + | "Z" -> eval_tactic "zify_op" | s -> Errors.error ("No ROmega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 151949c3c6..85b9d6a08f 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -752,11 +752,14 @@ let case_eq_intros_rewrite x = end } let rec find_a_destructable_match t = + let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in + let cl = [cl, (None, None), None], None in + let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in match kind_of_term t with | Case (_,_,x,_) when closed0 x -> if isVar x then (* TODO check there is no rel n. *) - raise (Found (Tacinterp.eval_tactic(<:tactic>))) + raise (Found (Tacinterp.eval_tactic dest)) else (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) raise (Found (case_eq_intros_rewrite x)) -- cgit v1.2.3 From 0a024252f6346287cf4886903c800590191ddec0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 23 Feb 2016 19:27:07 +0100 Subject: Removing the Q_coqast module. It implemented the quotation logic of terms and tactics, although it was mostly obsolete. With quotations gone, it is now useless and thus removed. I fundamentally doubt that anyone hardly depends on this out there. --- grammar/grammar.mllib | 1 - grammar/q_coqast.ml4 | 573 -------------------------------------------------- grammar/q_util.ml4 | 3 + grammar/q_util.mli | 2 + grammar/tacextend.ml4 | 10 +- 5 files changed, 14 insertions(+), 575 deletions(-) delete mode 100644 grammar/q_coqast.ml4 diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 6098de8f03..4432f4306e 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -60,7 +60,6 @@ G_ltac G_constr Q_util -Q_coqast Egramml Argextend Tacextend diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 deleted file mode 100644 index f6abe12cf2..0000000000 --- a/grammar/q_coqast.ml4 +++ /dev/null @@ -1,573 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 && s.[0] == '$' - -let purge_str s = - if String.length s == 0 || s.[0] <> '$' then s - else String.sub s 1 (String.length s - 1) - -let anti loc x = - expl_anti loc <:expr< $lid:purge_str x$ >> - -(* We don't give location for tactic quotation! *) -let loc = CompatLoc.ghost - -let dloc = <:expr< Loc.ghost >> - -let mlexpr_of_ident id = - <:expr< Names.Id.of_string $str:Names.Id.to_string id$ >> - -let mlexpr_of_name = function - | Names.Anonymous -> <:expr< Names.Anonymous >> - | Names.Name id -> - <:expr< Names.Name (Names.Id.of_string $str:Names.Id.to_string id$) >> - -let mlexpr_of_dirpath dir = - let l = Names.DirPath.repr dir in - <:expr< Names.DirPath.make $mlexpr_of_list mlexpr_of_ident l$ >> - -let mlexpr_of_qualid qid = - let (dir, id) = Libnames.repr_qualid qid in - <:expr< Libnames.make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >> - -let mlexpr_of_reference = function - | Libnames.Qualid (loc,qid) -> - let loc = of_coqloc loc in <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >> - | Libnames.Ident (loc,id) -> - let loc = of_coqloc loc in <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >> - -let mlexpr_of_union f g = function - | Util.Inl a -> <:expr< Util.Inl $f a$ >> - | Util.Inr b -> <:expr< Util.Inr $g b$ >> - -let mlexpr_of_located f (loc,x) = - let loc = of_coqloc loc in - <:expr< ($dloc$, $f x$) >> - -let mlexpr_of_loc loc = <:expr< $dloc$ >> - -let mlexpr_of_by_notation f = function - | Misctypes.AN x -> <:expr< Misctypes.AN $f x$ >> - | Misctypes.ByNotation (loc,s,sco) -> - let loc = of_coqloc loc in - <:expr< Misctypes.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >> - -let mlexpr_of_global_flag = function - | Tacexpr.TacGlobal -> <:expr> - | Tacexpr.TacLocal -> <:expr> - -let mlexpr_of_intro_pattern_disjunctive = function - _ -> failwith "mlexpr_of_intro_pattern_disjunctive: TODO" - -let mlexpr_of_intro_pattern_naming = function - | Misctypes.IntroAnonymous -> <:expr< Misctypes.IntroAnonymous >> - | Misctypes.IntroFresh id -> <:expr< Misctypes.IntroFresh (mlexpr_of_ident $dloc$ id) >> - | Misctypes.IntroIdentifier id -> - <:expr< Misctypes.IntroIdentifier (mlexpr_of_ident $dloc$ id) >> - -let mlexpr_of_intro_pattern = function - | Misctypes.IntroForthcoming b -> <:expr< Misctypes.IntroForthcoming (mlexpr_of_bool $dloc$ b) >> - | Misctypes.IntroNaming pat -> - <:expr< Misctypes.IntroNaming $mlexpr_of_intro_pattern_naming pat$ >> - | Misctypes.IntroAction _ -> - failwith "mlexpr_of_intro_pattern: TODO" - -let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident) - -let mlexpr_of_quantified_hypothesis = function - | Misctypes.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >> - | Misctypes.NamedHyp id -> <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >> - -let mlexpr_of_or_var f = function - | Misctypes.ArgArg x -> <:expr< Misctypes.ArgArg $f x$ >> - | Misctypes.ArgVar id -> <:expr< Misctypes.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >> - -let mlexpr_of_hyp = (mlexpr_of_located mlexpr_of_ident) - -let mlexpr_of_occs = function - | Locus.AllOccurrences -> <:expr< Locus.AllOccurrences >> - | Locus.AllOccurrencesBut l -> - <:expr< Locus.AllOccurrencesBut - $mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int) l$ >> - | Locus.NoOccurrences -> <:expr< Locus.NoOccurrences >> - | Locus.OnlyOccurrences l -> - <:expr< Locus.OnlyOccurrences - $mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int) l$ >> - -let mlexpr_of_occurrences f = mlexpr_of_pair mlexpr_of_occs f - -let mlexpr_of_hyp_location = function - | occs, Locus.InHyp -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHyp) >> - | occs, Locus.InHypTypeOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHypTypeOnly) >> - | occs, Locus.InHypValueOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHypValueOnly) >> - -let mlexpr_of_clause cl = - <:expr< {Locus.onhyps= - $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location) - cl.Locus.onhyps$; - Locus.concl_occs= $mlexpr_of_occs cl.Locus.concl_occs$} >> - -let mlexpr_of_red_flags { - Genredexpr.rBeta = bb; - Genredexpr.rIota = bi; - Genredexpr.rZeta = bz; - Genredexpr.rDelta = bd; - Genredexpr.rConst = l -} = <:expr< { - Genredexpr.rBeta = $mlexpr_of_bool bb$; - Genredexpr.rIota = $mlexpr_of_bool bi$; - Genredexpr.rZeta = $mlexpr_of_bool bz$; - Genredexpr.rDelta = $mlexpr_of_bool bd$; - Genredexpr.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$ -} >> - -let mlexpr_of_instance c = <:expr< None >> - -let mlexpr_of_explicitation = function - | Constrexpr.ExplByName id -> <:expr< Constrexpr.ExplByName $mlexpr_of_ident id$ >> - | Constrexpr.ExplByPos (n,_id) -> <:expr< Constrexpr.ExplByPos $mlexpr_of_int n$ >> - -let mlexpr_of_binding_kind = function - | Decl_kinds.Implicit -> <:expr< Decl_kinds.Implicit >> - | Decl_kinds.Explicit -> <:expr< Decl_kinds.Explicit >> - -let mlexpr_of_binder_kind = function - | Constrexpr.Default b -> <:expr< Constrexpr.Default $mlexpr_of_binding_kind b$ >> - | Constrexpr.Generalized (b,b',b'') -> - <:expr< Constrexpr.TypeClass $mlexpr_of_binding_kind b$ - $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> - -let rec mlexpr_of_constr = function - | Constrexpr.CRef (Libnames.Ident (loc,id),_) when is_meta (Id.to_string id) -> - let loc = of_coqloc loc in - anti loc (Id.to_string id) - | Constrexpr.CRef (r,n) -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ None >> - | Constrexpr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CProdN (loc,l,a) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CProdN $dloc$ $mlexpr_of_list - (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> - | Constrexpr.CLambdaN (loc,l,a) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> - | Constrexpr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CAppExpl (loc,(p,r,us),l) -> - let loc = of_coqloc loc in - let a = (p,r,us) in - <:expr< Constrexpr.CAppExpl $dloc$ $mlexpr_of_triple (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference mlexpr_of_instance a$ $mlexpr_of_list mlexpr_of_constr l$ >> - | Constrexpr.CApp (loc,a,l) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >> - | Constrexpr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CHole (loc, None, ipat, None) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CHole $dloc$ None $mlexpr_of_intro_pattern_naming ipat$ None >> - | Constrexpr.CHole (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO CHole (Some _)" - | Constrexpr.CNotation(_,ntn,(subst,substl,[])) -> - <:expr< Constrexpr.CNotation $dloc$ $mlexpr_of_string ntn$ - ($mlexpr_of_list mlexpr_of_constr subst$, - $mlexpr_of_list (mlexpr_of_list mlexpr_of_constr) substl$,[]) >> - | Constrexpr.CPatVar (loc,n) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CPatVar $dloc$ $mlexpr_of_ident n$ >> - | Constrexpr.CEvar (loc,n,[]) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CEvar $dloc$ $mlexpr_of_ident n$ [] >> - | _ -> failwith "mlexpr_of_constr: TODO" - -let mlexpr_of_occ_constr = - mlexpr_of_occurrences mlexpr_of_constr - -let mlexpr_of_occ_ref_or_constr = - mlexpr_of_occurrences - (mlexpr_of_union - (mlexpr_of_by_notation mlexpr_of_reference) mlexpr_of_constr) - -let mlexpr_of_red_expr = function - | Genredexpr.Red b -> <:expr< Genredexpr.Red $mlexpr_of_bool b$ >> - | Genredexpr.Hnf -> <:expr< Genredexpr.Hnf >> - | Genredexpr.Simpl (f,o) -> - <:expr< Genredexpr.Simpl $mlexpr_of_red_flags f$ $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >> - | Genredexpr.Cbv f -> - <:expr< Genredexpr.Cbv $mlexpr_of_red_flags f$ >> - | Genredexpr.Cbn f -> - <:expr< Genredexpr.Cbn $mlexpr_of_red_flags f$ >> - | Genredexpr.Lazy f -> - <:expr< Genredexpr.Lazy $mlexpr_of_red_flags f$ >> - | Genredexpr.Unfold l -> - let f1 = mlexpr_of_by_notation mlexpr_of_reference in - let f = mlexpr_of_list (mlexpr_of_occurrences f1) in - <:expr< Genredexpr.Unfold $f l$ >> - | Genredexpr.Fold l -> - <:expr< Genredexpr.Fold $mlexpr_of_list mlexpr_of_constr l$ >> - | Genredexpr.Pattern l -> - let f = mlexpr_of_list mlexpr_of_occ_constr in - <:expr< Genredexpr.Pattern $f l$ >> - | Genredexpr.CbvVm o -> <:expr< Genredexpr.CbvVm $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >> - | Genredexpr.CbvNative o -> <:expr< Genredexpr.CbvNative $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >> - | Genredexpr.ExtraRedExpr s -> - <:expr< Genredexpr.ExtraRedExpr $mlexpr_of_string s$ >> - -let rec mlexpr_of_argtype loc = function - | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> - | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> - | Genarg.PairArgType (t1,t2) -> - let t1 = mlexpr_of_argtype loc t1 in - let t2 = mlexpr_of_argtype loc t2 in - <:expr< Genarg.PairArgType $t1$ $t2$ >> - | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> - -let mlexpr_of_may_eval f = function - | Genredexpr.ConstrEval (r,c) -> - <:expr< Genredexpr.ConstrEval $mlexpr_of_red_expr r$ $f c$ >> - | Genredexpr.ConstrContext ((loc,id),c) -> - let loc = of_coqloc loc in - let id = mlexpr_of_ident id in - <:expr< Genredexpr.ConstrContext (loc,$id$) $f c$ >> - | Genredexpr.ConstrTypeOf c -> - <:expr< Genredexpr.ConstrTypeOf $mlexpr_of_constr c$ >> - | Genredexpr.ConstrTerm c -> - <:expr< Genredexpr.ConstrTerm $mlexpr_of_constr c$ >> - -let mlexpr_of_binding_kind = function - | Misctypes.ExplicitBindings l -> - let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in - <:expr< Misctypes.ExplicitBindings $l$ >> - | Misctypes.ImplicitBindings l -> - let l = mlexpr_of_list mlexpr_of_constr l in - <:expr< Misctypes.ImplicitBindings $l$ >> - | Misctypes.NoBindings -> - <:expr< Misctypes.NoBindings >> - -let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr - -let mlexpr_of_constr_with_binding = - mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind - -let mlexpr_of_constr_with_binding_arg = - mlexpr_of_pair (mlexpr_of_option mlexpr_of_bool) mlexpr_of_constr_with_binding - -let mlexpr_of_move_location f = function - | Misctypes.MoveAfter id -> <:expr< Misctypes.MoveAfter $f id$ >> - | Misctypes.MoveBefore id -> <:expr< Misctypes.MoveBefore $f id$ >> - | Misctypes.MoveFirst -> <:expr< Misctypes.MoveFirst >> - | Misctypes.MoveLast -> <:expr< Misctypes.MoveLast >> - -let mlexpr_of_induction_arg = function - | Tacexpr.ElimOnConstr c -> - <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >> - | Tacexpr.ElimOnIdent (_,id) -> - <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >> - | Tacexpr.ElimOnAnonHyp n -> - <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >> - -let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO" - -let mlexpr_of_pattern_ast = mlexpr_of_constr - -let mlexpr_of_entry_type = function - _ -> failwith "mlexpr_of_entry_type: TODO" - -let mlexpr_of_match_lazy_flag = function - | Tacexpr.General -> <:expr> - | Tacexpr.Select -> <:expr> - | Tacexpr.Once -> <:expr> - -let mlexpr_of_match_pattern = function - | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >> - | Tacexpr.Subterm (b,ido,t) -> - <:expr< Tacexpr.Subterm $mlexpr_of_bool b$ $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >> - -let mlexpr_of_match_context_hyps = function - | Tacexpr.Hyp (id,l) -> - let f = mlexpr_of_located mlexpr_of_name in - <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >> - | Tacexpr.Def (id,v,l) -> - let f = mlexpr_of_located mlexpr_of_name in - <:expr< Tacexpr.Def $f id$ $mlexpr_of_match_pattern v$ $mlexpr_of_match_pattern l$ >> - -let mlexpr_of_match_rule f = function - | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >> - | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >> - -let mlexpr_of_message_token = function - | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >> - | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >> - | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >> - -let mlexpr_of_debug = function - | Tacexpr.Off -> <:expr< Tacexpr.Off >> - | Tacexpr.Debug -> <:expr< Tacexpr.Debug >> - | Tacexpr.Info -> <:expr< Tacexpr.Info >> - -let rec mlexpr_of_atomic_tactic = function - (* Basic tactics *) - | Tacexpr.TacIntroPattern pl -> - let pl = mlexpr_of_list (mlexpr_of_located mlexpr_of_intro_pattern) pl in - <:expr< Tacexpr.TacIntroPattern $pl$ >> - | Tacexpr.TacIntroMove (idopt,idopt') -> - let idopt = mlexpr_of_ident_option idopt in - let idopt'= mlexpr_of_move_location mlexpr_of_hyp idopt' in - <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >> - | Tacexpr.TacExact c -> - <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >> - | Tacexpr.TacApply (b,false,cb,None) -> - <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding_arg cb$ None >> - | Tacexpr.TacElim (false,cb,cbo) -> - let cb = mlexpr_of_constr_with_binding_arg cb in - let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - <:expr< Tacexpr.TacElim False $cb$ $cbo$ >> - | Tacexpr.TacCase (false,cb) -> - let cb = mlexpr_of_constr_with_binding_arg cb in - <:expr< Tacexpr.TacCase False $cb$ >> - | Tacexpr.TacFix (ido,n) -> - let ido = mlexpr_of_ident_option ido in - let n = mlexpr_of_int n in - <:expr< Tacexpr.TacFix $ido$ $n$ >> - | Tacexpr.TacMutualFix (id,n,l) -> - let id = mlexpr_of_ident id in - let n = mlexpr_of_int n in - let f =mlexpr_of_triple mlexpr_of_ident mlexpr_of_int mlexpr_of_constr in - let l = mlexpr_of_list f l in - <:expr< Tacexpr.TacMutualFix $id$ $n$ $l$ >> - | Tacexpr.TacCofix ido -> - let ido = mlexpr_of_ident_option ido in - <:expr< Tacexpr.TacCofix $ido$ >> - | Tacexpr.TacMutualCofix (id,l) -> - let id = mlexpr_of_ident id in - let f = mlexpr_of_pair mlexpr_of_ident mlexpr_of_constr in - let l = mlexpr_of_list f l in - <:expr< Tacexpr.TacMutualCofix $id$ $l$ >> - - | Tacexpr.TacAssert (b,t,ipat,c) -> - let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in - <:expr< Tacexpr.TacAssert $mlexpr_of_bool b$ - $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ - $mlexpr_of_constr c$ >> - | Tacexpr.TacGeneralize cl -> - <:expr< Tacexpr.TacGeneralize - $mlexpr_of_list - (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >> - | Tacexpr.TacGeneralizeDep c -> - <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >> - | Tacexpr.TacLetTac (na,c,cl,b,e) -> - let na = mlexpr_of_name na in - let cl = mlexpr_of_clause_pattern cl in - <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ - $mlexpr_of_bool b$ - (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) e) - >> - - (* Derived basic tactics *) - | Tacexpr.TacInductionDestruct (isrec,ev,l) -> - <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ - $mlexpr_of_pair - (mlexpr_of_list - (mlexpr_of_triple - (mlexpr_of_pair - (mlexpr_of_option mlexpr_of_bool) - mlexpr_of_induction_arg) - (mlexpr_of_pair - (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern_naming)) - (mlexpr_of_option (mlexpr_of_intro_pattern_disjunctive))) - (mlexpr_of_option mlexpr_of_clause))) - (mlexpr_of_option mlexpr_of_constr_with_binding) - l$ >> - - (* Context management *) - | Tacexpr.TacClear (b,l) -> - let l = mlexpr_of_list (mlexpr_of_hyp) l in - <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >> - | Tacexpr.TacClearBody l -> - let l = mlexpr_of_list (mlexpr_of_hyp) l in - <:expr< Tacexpr.TacClearBody $l$ >> - | Tacexpr.TacMove (id1,id2) -> - <:expr< Tacexpr.TacMove - $mlexpr_of_hyp id1$ - $mlexpr_of_move_location mlexpr_of_hyp id2$ >> - - (* Constructors *) - | Tacexpr.TacSplit (ev,l) -> - <:expr< Tacexpr.TacSplit - ($mlexpr_of_bool ev$, $mlexpr_of_list mlexpr_of_binding_kind l$)>> - (* Conversion *) - | Tacexpr.TacReduce (r,cl) -> - let l = mlexpr_of_clause cl in - <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >> - | Tacexpr.TacChange (p,c,cl) -> - let l = mlexpr_of_clause cl in - let g = mlexpr_of_option mlexpr_of_constr in - <:expr< Tacexpr.TacChange $g p$ $mlexpr_of_constr c$ $l$ >> - - (* Equivalence relations *) - | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >> - - | _ -> failwith "Quotation of atomic tactic expressions: TODO" - -and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function - | Tacexpr.TacAtom (loc,t) -> - let loc = of_coqloc loc in - <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >> - | Tacexpr.TacThen (t1,t2) -> - <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$>> - | Tacexpr.TacThens (t,tl) -> - <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>> - | Tacexpr.TacFirst tl -> - <:expr< Tacexpr.TacFirst $mlexpr_of_list mlexpr_of_tactic tl$ >> - | Tacexpr.TacSolve tl -> - <:expr< Tacexpr.TacSolve $mlexpr_of_list mlexpr_of_tactic tl$ >> - | Tacexpr.TacTry t -> - <:expr< Tacexpr.TacTry $mlexpr_of_tactic t$ >> - | Tacexpr.TacOr (t1,t2) -> - <:expr< Tacexpr.TacOr $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> - | Tacexpr.TacOrelse (t1,t2) -> - <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> - | Tacexpr.TacDo (n,t) -> - <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacTimeout (n,t) -> - <:expr< Tacexpr.TacTimeout $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacRepeat t -> - <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> - | Tacexpr.TacProgress t -> - <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> - | Tacexpr.TacShowHyps t -> - <:expr< Tacexpr.TacShowHyps $mlexpr_of_tactic t$ >> - | Tacexpr.TacId l -> - <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >> - | Tacexpr.TacFail (g,n,l) -> - <:expr< Tacexpr.TacFail $mlexpr_of_global_flag g$ $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >> -(* - | Tacexpr.TacInfo t -> TacInfo (loc,f t) - - | Tacexpr.TacRec (id,(idl,t)) -> TacRec (loc,(id,(idl,f t))) - | Tacexpr.TacRecIn (l,t) -> TacRecIn(loc,List.map (fun (id,t) -> (id,f t)) l,f t) -*) - | Tacexpr.TacLetIn (isrec,l,t) -> - let f = - mlexpr_of_pair - (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident) - mlexpr_of_tactic_arg in - <:expr< Tacexpr.TacLetIn $mlexpr_of_bool isrec$ $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacMatch (lz,t,l) -> - <:expr< Tacexpr.TacMatch - $mlexpr_of_match_lazy_flag lz$ - $mlexpr_of_tactic t$ - $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> - | Tacexpr.TacMatchGoal (lz,lr,l) -> - <:expr< Tacexpr.TacMatchGoal - $mlexpr_of_match_lazy_flag lz$ - $mlexpr_of_bool lr$ - $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> - - | Tacexpr.TacFun (idol,body) -> - <:expr< Tacexpr.TacFun - ($mlexpr_of_list mlexpr_of_ident_option idol$, - $mlexpr_of_tactic body$) >> - | Tacexpr.TacArg (_,Tacexpr.MetaIdArg (_,true,id)) -> anti loc id - | Tacexpr.TacArg (_,t) -> - <:expr< Tacexpr.TacArg $dloc$ $mlexpr_of_tactic_arg t$ >> - | Tacexpr.TacComplete t -> - <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >> - | _ -> failwith "Quotation of tactic expressions: TODO" - -and mlexpr_of_tactic_arg = function - | Tacexpr.MetaIdArg (loc,true,id) -> - let loc = of_coqloc loc in - anti loc id - | Tacexpr.MetaIdArg (loc,false,id) -> - let loc = of_coqloc loc in - <:expr< Tacexpr.ConstrMayEval (Genredexpr.ConstrTerm $anti loc id$) >> - | Tacexpr.TacCall (loc,t,tl) -> - let loc = of_coqloc loc in - <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> - | Tacexpr.Tacexp t -> - <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >> - | Tacexpr.ConstrMayEval c -> - <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >> - | Tacexpr.Reference r -> - <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> - | _ -> failwith "mlexpr_of_tactic_arg: TODO" - - -IFDEF CAMLP5 THEN - -let not_impl x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith (" PaAcc (loc, patt_of_expr e1, patt_of_expr e2) - | ExApp (_, e1, e2) -> PaApp (loc, patt_of_expr e1, patt_of_expr e2) - | ExLid (_, x) when x = vala "loc" -> PaAny loc - | ExLid (_, s) -> PaLid (loc, s) - | ExUid (_, s) -> PaUid (loc, s) - | ExStr (_, s) -> PaStr (loc, s) - | ExAnt (_, e) -> PaAnt (loc, patt_of_expr e) - | _ -> not_impl e - -let fconstr e = - let ee s = - mlexpr_of_constr (Pcoq.Gram.entry_parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - -let ftac e = - let ee s = - mlexpr_of_tactic (Pcoq.Gram.entry_parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - -let _ = - Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); - Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); - Quotation.default := "constr" - -ELSE - -open Pcaml - -let expand_constr_quot_expr loc _loc_name_opt contents = - mlexpr_of_constr - (Pcoq.Gram.parse_string Pcoq.Constr.constr_eoi loc contents) - -let expand_tactic_quot_expr loc _loc_name_opt contents = - mlexpr_of_tactic - (Pcoq.Gram.parse_string Pcoq.Tactic.tactic_eoi loc contents) - -let _ = - (* FIXME: for the moment, we add quotations in expressions only, not pattern *) - Quotation.add "constr" Quotation.DynAst.expr_tag expand_constr_quot_expr; - Quotation.add "tactic" Quotation.DynAst.expr_tag expand_tactic_quot_expr; - Quotation.default := "constr" - -END diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 4b0be1b1cb..d668e3d398 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -54,6 +54,9 @@ let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> +let mlexpr_of_ident id = + <:expr< Names.Id.of_string $str:Names.Id.to_string id$ >> + let mlexpr_of_token = function | Tok.KEYWORD s -> <:expr< Tok.KEYWORD $mlexpr_of_string s$ >> | Tok.METAIDENT s -> <:expr< Tok.METAIDENT $mlexpr_of_string s$ >> diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 50827ead25..d0e0dab22e 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -34,6 +34,8 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr +val mlexpr_of_ident : Names.Id.t -> MLast.expr + val mlexpr_of_prod_entry_key : Extend.user_symbol -> MLast.expr val type_of_user_symbol : Extend.user_symbol -> Genarg.argument_type diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index ef7cdbfa3a..10afcdd21a 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -15,7 +15,6 @@ open Pp open Names open Genarg open Q_util -open Q_coqast open Argextend open Pcoq open Egramml @@ -32,6 +31,15 @@ let rec make_patt = function <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l +let rec mlexpr_of_argtype loc = function + | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> + | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> + | Genarg.PairArgType (t1,t2) -> + let t1 = mlexpr_of_argtype loc t1 in + let t2 = mlexpr_of_argtype loc t2 in + <:expr< Genarg.PairArgType $t1$ $t2$ >> + | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> + let rec make_when loc = function | [] -> <:expr< True >> | ExtNonTerminal (t, _, p) :: l -> -- cgit v1.2.3 From ee162ba3b28fccca0a2b3ea4b1e0811006840570 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 24 Feb 2016 10:07:57 +0100 Subject: Removing the MetaIdArg entry of tactic expressions. This was historically used together with the <:tactic< ... >> quotation to insert foreign code as $foo, but it actually only survived in the implementation of Tauto. With the removal of the quotation feature, this is now totally obsolete. --- intf/tacexpr.mli | 1 - parsing/g_ltac.ml4 | 4 +--- printing/pptactic.ml | 4 ---- tactics/tacintern.ml | 13 ------------- tactics/tacinterp.ml | 1 - tactics/tacsubst.ml | 1 - 6 files changed, 1 insertion(+), 23 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 57c61874a5..502f2db4c1 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -206,7 +206,6 @@ constraint 'a = < and 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument - | MetaIdArg of Loc.t * bool * string | ConstrMayEval of ('trm,'cst,'pat) may_eval | UConstr of 'utrm | Reference of 'ref diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 12d53030d7..0a11d3928a 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -146,7 +146,6 @@ GEXTEND Gram | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) - | id = METAIDENT -> MetaIdArg (!@loc,true,id) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) @@ -179,8 +178,7 @@ GEXTEND Gram | c = Constr.constr -> ConstrTerm c ] ] ; tactic_atom: - [ [ id = METAIDENT -> MetaIdArg (!@loc,true,id) - | n = integer -> TacGeneric (genarg_of_int n) + [ [ n = integer -> TacGeneric (genarg_of_int n) | r = reference -> TacCall (!@loc,r,[]) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; diff --git a/printing/pptactic.ml b/printing/pptactic.ml index ed85b21478..12667d0f24 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1189,10 +1189,6 @@ module Make else str"(" ++ strm ++ str")" and pr_tacarg = function - | MetaIdArg (loc,true,s) -> - pr_with_comments loc (str "$" ++ str s) - | MetaIdArg (loc,false,s) -> - pr_with_comments loc (keyword "constr:" ++ str " $" ++ str s) | Reference r -> pr.pr_reference r | ConstrMayEval c -> diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 4ef1beb034..cbb9db65c1 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -35,11 +35,6 @@ let dloc = Loc.ghost let error_global_not_found_loc (loc,qid) = error_global_not_found_loc loc qid -let error_syntactic_metavariables_not_allowed loc = - user_err_loc - (loc,"out_ident", - str "Syntactic metavariables allowed only in quotations.") - let error_tactic_expected loc = user_err_loc (loc,"",str "Tactic expected.") @@ -672,7 +667,6 @@ and intern_tactic_as_arg loc onlytac ist a = | Tacexp a -> a | ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> if onlytac then error_tactic_expected loc else TacArg (loc,a) - | MetaIdArg _ -> assert false and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -686,13 +680,6 @@ and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) | UConstr c -> UConstr (intern_constr ist c) - | MetaIdArg (loc,istac,s) -> - (* $id can occur in Grammar tactic... *) - let id = Id.of_string s in - if find_var id ist then - if istac then Reference (ArgVar (adjust_loc loc,id)) - else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None)) - else error_syntactic_metavariables_not_allowed loc | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f | TacCall (loc,f,l) -> TacCall (loc, diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index cb4a9f320d..43c9ee9be4 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1371,7 +1371,6 @@ and interp_tacarg ist arg : Val.t Ftactic.t = let env = Proofview.Goal.env gl in Ftactic.return (Value.of_uconstr (interp_uconstr ist env c)) end } - | MetaIdArg (loc,_,id) -> assert false | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist r | TacCall (loc,f,l) -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index dd851b5c0d..4a5fa9828e 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -260,7 +260,6 @@ and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) | UConstr c -> UConstr (subst_glob_constr subst c) - | MetaIdArg (_loc,_,_) -> assert false | TacCall (_loc,f,l) -> TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) | TacFreshId _ as x -> x -- cgit v1.2.3 From d96bf1b1ec79fa93787d23e1c42f803d74b49321 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 24 Feb 2016 10:26:56 +0100 Subject: Removing the METAIDENT token, as it is not used anymore. METAIDENT were idents of the form $foobar, only used in quotations. Note that it removes two dollars in the Coq codebase! Guess I'm absolved for the $(...) syntax. --- grammar/q_util.ml4 | 1 - parsing/compat.ml4 | 1 - parsing/g_constr.ml4 | 5 +---- parsing/lexer.ml4 | 3 --- parsing/tok.ml | 7 ------- parsing/tok.mli | 1 - 6 files changed, 1 insertion(+), 17 deletions(-) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index d668e3d398..c6e2e99668 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -59,7 +59,6 @@ let mlexpr_of_ident id = let mlexpr_of_token = function | Tok.KEYWORD s -> <:expr< Tok.KEYWORD $mlexpr_of_string s$ >> -| Tok.METAIDENT s -> <:expr< Tok.METAIDENT $mlexpr_of_string s$ >> | Tok.PATTERNIDENT s -> <:expr< Tok.PATTERNIDENT $mlexpr_of_string s$ >> | Tok.IDENT s -> <:expr< Tok.IDENT $mlexpr_of_string s$ >> | Tok.FIELD s -> <:expr< Tok.FIELD $mlexpr_of_string s$ >> diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 3405d2429b..0e416fe32c 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -262,7 +262,6 @@ IFDEF CAMLP5 THEN let pattern = match tok with | Tok.KEYWORD s -> "", s | Tok.IDENT s -> "IDENT", s - | Tok.METAIDENT s -> "METAIDENT", s | Tok.PATTERNIDENT s -> "PATTERNIDENT", s | Tok.FIELD s -> "FIELD", s | Tok.INT s -> "INT", s diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 1ac260ebeb..0fe0ac42b1 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -132,10 +132,7 @@ GEXTEND Gram closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; Constr.ident: - [ [ id = Prim.ident -> id - - (* This is used in quotations and Syntax *) - | id = METAIDENT -> Id.of_string id ] ] + [ [ id = Prim.ident -> id ] ] ; Prim.name: [ [ "_" -> (!@loc, Anonymous) ] ] diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 74e05ce84d..232e9aee3f 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -493,7 +493,6 @@ let process_chars bp c cs = err (bp, ep') Undefined_token let token_of_special c s = match c with - | '$' -> METAIDENT s | '.' -> FIELD s | _ -> assert false @@ -532,8 +531,6 @@ let blank_or_eof cs = let rec next_token = parser bp | [< '' ' | '\t' | '\n' |'\r' as c; s >] -> comm_loc bp; push_char c; next_token s - | [< ''$' as c; t = parse_after_special c bp >] ep -> - comment_stop bp; (t, (ep, bp)) | [< ''.' as c; t = parse_after_special c bp; s >] ep -> comment_stop bp; (* We enforce that "." should either be part of a larger keyword, diff --git a/parsing/tok.ml b/parsing/tok.ml index 4f50c48d0d..6b90086155 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -10,7 +10,6 @@ type t = | KEYWORD of string - | METAIDENT of string | PATTERNIDENT of string | IDENT of string | FIELD of string @@ -24,7 +23,6 @@ type t = let equal t1 t2 = match t1, t2 with | IDENT s1, KEYWORD s2 -> CString.equal s1 s2 | KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 -| METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2 | PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 | IDENT s1, IDENT s2 -> CString.equal s1 s2 | FIELD s1, FIELD s2 -> CString.equal s1 s2 @@ -40,7 +38,6 @@ let extract_string = function | KEYWORD s -> s | IDENT s -> s | STRING s -> s - | METAIDENT s -> s | PATTERNIDENT s -> s | FIELD s -> s | INT s -> s @@ -52,7 +49,6 @@ let extract_string = function let to_string = function | KEYWORD s -> Format.sprintf "%S" s | IDENT s -> Format.sprintf "IDENT %S" s - | METAIDENT s -> Format.sprintf "METAIDENT %S" s | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s | FIELD s -> Format.sprintf "FIELD %S" s | INT s -> Format.sprintf "INT %s" s @@ -76,7 +72,6 @@ let print ppf tok = Format.pp_print_string ppf (to_string tok) let of_pattern = function | "", s -> KEYWORD s | "IDENT", s -> IDENT s - | "METAIDENT", s -> METAIDENT s | "PATTERNIDENT", s -> PATTERNIDENT s | "FIELD", s -> FIELD s | "INT", s -> INT s @@ -90,7 +85,6 @@ let of_pattern = function let to_pattern = function | KEYWORD s -> "", s | IDENT s -> "IDENT", s - | METAIDENT s -> "METAIDENT", s | PATTERNIDENT s -> "PATTERNIDENT", s | FIELD s -> "FIELD", s | INT s -> "INT", s @@ -105,7 +99,6 @@ let match_pattern = function | "", "" -> (function KEYWORD s -> s | _ -> err ()) | "IDENT", "" -> (function IDENT s -> s | _ -> err ()) - | "METAIDENT", "" -> (function METAIDENT s -> s | _ -> err ()) | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) | "INT", "" -> (function INT s -> s | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index f37de05a44..416ce468e3 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -10,7 +10,6 @@ type t = | KEYWORD of string - | METAIDENT of string | PATTERNIDENT of string | IDENT of string | FIELD of string -- cgit v1.2.3 From 20fe4afb53e2b68ffb06a5504a444e536d4b813e Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 24 Feb 2016 16:06:40 +0100 Subject: Document Hint Mode, cleanup Hint doc. --- doc/refman/RefMan-tac.tex | 40 ++++++++++++++++++---------------------- 1 file changed, 18 insertions(+), 22 deletions(-) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 9a365b8297..903e2e19af 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3669,9 +3669,6 @@ The {\hintdef} is one of the following expressions: the number of subgoals generated by {\tt simple apply {\term}}. %{\tt auto} actually uses a slightly modified variant of {\tt simple apply} with use_metas_eagerly_in_conv_on_closed_terms set to false - The cost of that hint is the number of subgoals generated by that - tactic. - % Is it really needed? %% In case the inferred type of \term\ does not start with a product %% the tactic added in the hint list is {\tt exact {\term}}. In case @@ -3869,7 +3866,25 @@ is to set the cut expression to $c | e$, the initial cut expression being \texttt{emp}. +\item \texttt{Mode} {\tt (+ | -)}$^*$ {\qualid} +\label{HintMode} +\comindex{Hint Mode} + +This sets an optional mode of use of the identifier {\qualid}. When +proof-search faces a goal that ends in an application of {\qualid} to +arguments {\tt \term$_1$ \mbox{\dots} \term$_n$}, the mode tells if the +hints associated to qualid can be applied or not. A mode specification +is a list of $n$ {\tt +} or {\tt -} items that specify if an argument is +to be treated as an input {\tt +} or an output {\tt -} of the +identifier. For a mode to match a list of arguments, input terms \emph{must +not} contain existential variables, while outputs can be any term. +Multiple modes can be declared for a single identifier, in that case +only one mode needs to match the arguments for the hints to be applied. +{\tt Hint Mode} is especially useful for typeclasses, when one does not +want to support default instances and avoid ambiguity in +general. Setting a parameter of a class as an input forces proof-search +to be driven by that index of the class. \end{itemize} @@ -3877,25 +3892,6 @@ being \texttt{emp}. pattern-matching on hypotheses using \texttt{match goal with} inside the tactic. -\begin{Variants} -\item {\tt Hint \hintdef} - - No database name is given: the hint is registered in the {\tt core} - database. - -\item {\tt Hint Local {\hintdef} : \ident$_1$ \mbox{\dots} \ident$_n$} - - This is used to declare hints that must not be exported to the other - modules that require and import the current module. Inside a - section, the option {\tt Local} is useless since hints do not - survive anyway to the closure of sections. - -\item {\tt Hint Local \hintdef} - - Idem for the {\tt core} database. - -\end{Variants} - % There are shortcuts that allow to define several goal at once: % \begin{itemize} -- cgit v1.2.3 From ea05377f19404e0627a105b07c10ce72fb010af9 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 26 Feb 2016 16:12:33 +0100 Subject: Qcanon : implement some old suggestions by C. Auger --- theories/Numbers/Rational/BigQ/QMake.v | 37 +++++----- theories/QArith/Qcanon.v | 120 ++++++++++++++++++--------------- 2 files changed, 83 insertions(+), 74 deletions(-) diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v index 4ac36425b4..b9fed9d566 100644 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ b/theories/Numbers/Rational/BigQ/QMake.v @@ -1050,13 +1050,13 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. Theorem spec_of_Qc: forall q, [[of_Qc q]] = q. Proof. intros; apply Qc_decomp; simpl; intros. - rewrite strong_spec_of_Qc; auto. + rewrite strong_spec_of_Qc. apply canon. Qed. Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. Proof. intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. rewrite spec_opp, <- Qred_opp, Qred_correct. apply Qeq_refl. @@ -1085,10 +1085,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] + [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_add; auto. unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qplus_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1099,10 +1099,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] + [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_add_norm; auto. unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qplus_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1147,10 +1147,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] * [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_mul; auto. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1161,10 +1161,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] * [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_mul_norm; auto. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1185,10 +1185,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc (/[x])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_inv; auto. unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qinv_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1199,10 +1199,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc (/[x])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_inv_norm; auto. unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qinv_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1247,13 +1247,13 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x]^2)). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_square; auto. simpl Qcpower. replace (Q2Qc [x] * 1) with (Q2Qc [x]); try ring. simpl. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1264,14 +1264,14 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x]^Zpos p)). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_power_pos; auto. induction p using Pos.peano_ind. simpl; ring. rewrite Pos2Nat.inj_succ; simpl Qcpower. rewrite <- IHp; clear IHp. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. setoid_replace ([x] ^ ' Pos.succ p)%Q with ([x] * [x] ^ ' p)%Q. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. @@ -1281,4 +1281,3 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. Qed. End Make. - diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index d966b050c3..86be28d7b8 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -21,37 +21,30 @@ Bind Scope Qc_scope with Qc. Arguments Qcmake this%Q _. Open Scope Qc_scope. +(** An alternative statement of [Qred q = q] via [Z.gcd] *) + Lemma Qred_identity : forall q:Q, Z.gcd (Qnum q) (QDen q) = 1%Z -> Qred q = q. Proof. - unfold Qred; intros (a,b); simpl. - generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)). - intros. - rewrite H1 in H; clear H1. - destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. - destruct H0. - rewrite Z.mul_1_l in H, H0. - subst; simpl; auto. + intros (a,b) H; simpl in *. + rewrite <- Z.ggcd_gcd in H. + generalize (Z.ggcd_correct_divisors a ('b)). + destruct Z.ggcd as (g,(aa,bb)); simpl in *; subst. + rewrite !Z.mul_1_l. now intros (<-,<-). Qed. Lemma Qred_identity2 : forall q:Q, Qred q = q -> Z.gcd (Qnum q) (QDen q) = 1%Z. Proof. - unfold Qred; intros (a,b); simpl. - generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)) (Z.gcd_nonneg a ('b)). - intros. - rewrite <- H; rewrite <- H in H1; clear H. - destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. - injection H2; intros; clear H2. - destruct H0. - clear H0 H3. - destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate. - f_equal. - apply Pos.mul_reg_r with bb. - injection H2; intros. - rewrite <- H0. - rewrite H; simpl; auto. - elim H1; auto. + intros (a,b) H; simpl in *. + generalize (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)). + rewrite <- Z.ggcd_gcd. + destruct Z.ggcd as (g,(aa,bb)); simpl in *. + injection H as <- <-. intros H (_,H'). + destruct g as [|g|g]; [ discriminate | | now elim H ]. + destruct bb as [|b|b]; simpl in *; try discriminate. + injection H' as H'. f_equal. + apply Pos.mul_reg_r with b. now rewrite Pos.mul_1_l. Qed. Lemma Qred_iff : forall q:Q, Qred q = q <-> Z.gcd (Qnum q) (QDen q) = 1%Z. @@ -61,6 +54,23 @@ Proof. apply Qred_identity; auto. Qed. +(** Coercion from [Qc] to [Q] and equality *) + +Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. +Proof. + intros (q,hq) (q',hq') H. simpl in *. + assert (H' := Qred_complete _ _ H). + rewrite hq, hq' in H'. subst q'. f_equal. + apply eq_proofs_unicity. intros. repeat decide equality. +Qed. +Hint Resolve Qc_is_canon. + +Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'. +Proof. + intros. apply Qc_is_canon. now rewrite H. +Qed. + +(** [Q2Qc] : a conversion from [Q] to [Qc]. *) Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q. Proof. @@ -71,20 +81,20 @@ Qed. Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). Arguments Q2Qc q%Q. -Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. +Lemma Qred_eq_iff (q q' : Q) : Qred q = Qred q' <-> q == q'. Proof. - intros (q,proof_q) (q',proof_q'). - simpl. - intros H. - assert (H0:=Qred_complete _ _ H). - assert (q = q') by congruence. - subst q'. - assert (proof_q = proof_q'). - apply eq_proofs_unicity; auto; intros. - repeat decide equality. - congruence. + split. + - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q'). + now rewrite E. + - apply Qred_complete. +Qed. + +Lemma Q2Qc_eq_iff (q q' : Q) : Q2Qc q = Q2Qc q' <-> q == q'. +Proof. + split; intro H. + - injection H. apply Qred_eq_iff. + - apply Qc_is_canon. simpl. now rewrite H. Qed. -Hint Resolve Qc_is_canon. Notation " 0 " := (Q2Qc 0) : Qc_scope. Notation " 1 " := (Q2Qc 1) : Qc_scope. @@ -107,8 +117,7 @@ Lemma Qceq_alt : forall p q, (p = q) <-> (p ?= q) = Eq. Proof. unfold Qccompare. intros; rewrite <- Qeq_alt. - split; auto. - intro H; rewrite H; auto with qarith. + split; auto. now intros <-. Qed. Lemma Qclt_alt : forall p q, (p (p?=q = Lt). @@ -166,7 +175,7 @@ Qed. Ltac qc := match goal with | q:Qc |- _ => destruct q; qc - | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct + | _ => apply Qc_is_canon; simpl; rewrite !Qred_correct end. Opaque Qred. @@ -216,6 +225,18 @@ Proof. intros; qc; apply Qmult_assoc. Qed. +(** [0] is absorbing for multiplication: *) + +Lemma Qcmult_0_l : forall n, 0*n = 0. +Proof. + intros; qc; split. +Qed. + +Theorem Qcmult_0_r : forall n, n*0=0. +Proof. + intros; qc; rewrite Qmult_comm; split. +Qed. + (** [1] is a neutral element for multiplication: *) Lemma Qcmult_1_l : forall n, 1*n = n. @@ -303,7 +324,7 @@ Proof. apply Qcmult_1_l. Qed. -(** Properties of order upon Q. *) +(** Properties of order upon Qc. *) Lemma Qcle_refl : forall x, x<=x. Proof. @@ -372,9 +393,11 @@ Proof. unfold Qcle, Qclt; intros; apply Qle_not_lt; auto. Qed. -Lemma Qcle_lt_or_eq : forall x y, x<=y -> x xO -> 0^n = 0. Proof. destruct n; simpl. @@ -525,16 +548,3 @@ intros. field. auto. Qed. - - -Theorem Qc_decomp: forall x y: Qc, - (Qred x = x -> Qred y = y -> (x:Q) = y)-> x = y. -Proof. - intros (q, Hq) (q', Hq'); simpl; intros H. - assert (H1 := H Hq Hq'). - subst q'. - assert (Hq = Hq'). - apply Eqdep_dec.eq_proofs_unicity; auto; intros. - repeat decide equality. - congruence. -Qed. -- cgit v1.2.3 From 20adaabfa96744442f201287e2900b1575614577 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 26 Feb 2016 20:01:18 +0100 Subject: Qcanon : fix names of lemmas Qcle_alt & Qcge_alt (were Qle_alt & Qge_alt) --- theories/QArith/Qcanon.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 86be28d7b8..078926e321 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -130,12 +130,12 @@ Proof. intros; exact (Qgt_alt p q). Qed. -Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). +Lemma Qcle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). Proof. intros; exact (Qle_alt p q). Qed. -Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). +Lemma Qcge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). Proof. intros; exact (Qge_alt p q). Qed. -- cgit v1.2.3 From 3246b4fd3d03cba93c556986ed1a0f9629e4bb73 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 26 Feb 2016 20:16:00 +0100 Subject: Qcabs : absolute value on normalized rational numbers Qc File contributed by Cédric Auger (a long time ago, sorry!) Qarith and Qc would probably deserve many more results like this one, and a more modern style (for instance qualified names), but this commit is better than nothing... --- theories/QArith/Qcabs.v | 129 +++++++++++++++++++++++++++++++++++++++++++ theories/QArith/Qcanon.v | 10 +--- theories/QArith/Qreduction.v | 22 +++++++- theories/QArith/vo.itarget | 1 + 4 files changed, 150 insertions(+), 12 deletions(-) create mode 100644 theories/QArith/Qcabs.v diff --git a/theories/QArith/Qcabs.v b/theories/QArith/Qcabs.v new file mode 100644 index 0000000000..c0ababfff5 --- /dev/null +++ b/theories/QArith/Qcabs.v @@ -0,0 +1,129 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Qred (Qabs x) = Qabs x. +Proof. intros H; now rewrite (Qred_abs x), H. Qed. + +Definition Qcabs (x:Qc) : Qc := {| canon := Qcabs_canon x (canon x) |}. +Notation "[ q ]" := (Qcabs q) (q at next level, format "[ q ]") : Qc_scope. + +Ltac Qc_unfolds := + unfold Qcabs, Qcminus, Qcopp, Qcplus, Qcmult, Qcle, Q2Qc, this. + +Lemma Qcabs_case (x:Qc) (P : Qc -> Type) : + (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P [x]. +Proof. + intros A B. + apply (Qabs_case x (fun x => forall Hx, P {|this:=x;canon:=Hx|})). + intros; case (Qc_decomp x {|canon:=Hx|}); auto. + intros; case (Qc_decomp (-x) {|canon:=Hx|}); auto. +Qed. + +Lemma Qcabs_pos x : 0 <= x -> [x] = x. +Proof. + intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x). + set (K := canon [x]); simpl in K; case K; clear K. + set (a := x) at 1; case (canon x); subst a; apply Qred_complete. + now apply Qabs_pos. +Qed. + +Lemma Qcabs_neg x : x <= 0 -> [x] = - x. +Proof. + intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x). + set (K := canon [x]); simpl in K; case K; clear K. + now apply Qred_complete; apply Qabs_neg. +Qed. + +Lemma Qcabs_nonneg x : 0 <= [x]. +Proof. intros; apply Qabs_nonneg. Qed. + +Lemma Qcabs_opp x : [(-x)] = [x]. +Proof. + apply Qc_decomp; Qc_unfolds; fold (this x). + set (K := canon [x]); simpl in K; case K; clear K. + case Qred_abs; apply Qred_complete; apply Qabs_opp. +Qed. + +Lemma Qcabs_triangle x y : [x+y] <= [x] + [y]. +Proof. + Qc_unfolds; case Qred_abs; rewrite !Qred_le; apply Qabs_triangle. +Qed. + +Lemma Qcabs_Qcmult x y : [x*y] = [x]*[y]. +Proof. + apply Qc_decomp; Qc_unfolds; fold (this x) (this y); case Qred_abs. + apply Qred_complete; apply Qabs_Qmult. +Qed. + +Lemma Qcabs_Qcminus x y: [x-y] = [y-x]. +Proof. + apply Qc_decomp; Qc_unfolds; fold (this x) (this y) (this (-x)) (this (-y)). + set (a := x) at 2; case (canon x); subst a. + set (a := y) at 1; case (canon y); subst a. + rewrite !Qred_opp; fold (Qred x - Qred y)%Q (Qred y - Qred x)%Q. + repeat case Qred_abs; f_equal; apply Qabs_Qminus. +Qed. + +Lemma Qcle_Qcabs x : x <= [x]. +Proof. apply Qle_Qabs. Qed. + +Lemma Qcabs_triangle_reverse x y : [x] - [y] <= [x - y]. +Proof. + unfold Qcle, Qcabs, Qcminus, Qcplus, Qcopp, Q2Qc, this; + fold (this x) (this y) (this (-x)) (this (-y)). + case Qred_abs; rewrite !Qred_le, !Qred_opp, Qred_abs. + apply Qabs_triangle_reverse. +Qed. + +Lemma Qcabs_Qcle_condition x y : [x] <= y <-> -y <= x <= y. +Proof. + Qc_unfolds; fold (this x) (this y). + destruct (Qabs_Qle_condition x y) as [A B]. + split; intros H. + + destruct (A H) as [X Y]; split; auto. + now case (canon x); apply Qred_le. + + destruct H as [X Y]; apply B; split; auto. + now case (canon y); case Qred_opp. +Qed. + +Lemma Qcabs_diff_Qcle_condition x y r : [x-y] <= r <-> x - r <= y <= x + r. +Proof. + Qc_unfolds; fold (this x) (this y) (this r). + case Qred_abs; repeat rewrite Qred_opp. + set (a := y) at 1; case (canon y); subst a. + set (a := r) at 2; case (canon r); subst a. + set (a := Qred r) at 2 3; + assert (K := canon (Q2Qc r)); simpl in K; case K; clear K; subst a. + set (a := Qred y) at 1; + assert (K := canon (Q2Qc y)); simpl in K; case K; clear K; subst a. + fold (x - Qred y)%Q (x - Qred r)%Q. + destruct (Qabs_diff_Qle_condition x (Qred y) (Qred r)) as [A B]. + split. + + clear B; rewrite !Qred_le. auto. + + clear A; rewrite !Qred_le. auto. +Qed. + +Lemma Qcabs_null x : [x] = 0 -> x = 0. +Proof. + intros H. + destruct (proj1 (Qcabs_Qcle_condition x 0)) as [A B]. + + rewrite H; apply Qcle_refl. + + apply Qcle_antisym; auto. +Qed. \ No newline at end of file diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 078926e321..6bfa47bc55 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -81,14 +81,6 @@ Qed. Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). Arguments Q2Qc q%Q. -Lemma Qred_eq_iff (q q' : Q) : Qred q = Qred q' <-> q == q'. -Proof. - split. - - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q'). - now rewrite E. - - apply Qred_complete. -Qed. - Lemma Q2Qc_eq_iff (q q' : Q) : Q2Qc q = Q2Qc q' <-> q == q'. Proof. split; intro H. @@ -488,7 +480,7 @@ Proof. destruct n; simpl. destruct 1; auto. intros. - now apply Qc_is_canon. + now apply Qc_is_canon. Qed. Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index c50c38b28f..131214f516 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -93,11 +93,17 @@ Proof. Close Scope Z_scope. Qed. +Lemma Qred_eq_iff q q' : Qred q = Qred q' <-> q == q'. +Proof. + split. + - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q'). + now rewrite E. + - apply Qred_complete. +Qed. + Add Morphism Qred : Qred_comp. Proof. - intros q q' H. - rewrite (Qred_correct q); auto. - rewrite (Qred_correct q'); auto. + intros. now rewrite !Qred_correct. Qed. Definition Qplus' (p q : Q) := Qred (Qplus p q). @@ -149,3 +155,13 @@ Theorem Qred_compare: forall x y, Proof. intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. Qed. + +Lemma Qred_le q q' : Qred q <= Qred q' <-> q <= q'. +Proof. + now rewrite !Qle_alt, <- Qred_compare. +Qed. + +Lemma Qred_lt q q' : Qred q < Qred q' <-> q < q'. +Proof. + now rewrite !Qlt_alt, <- Qred_compare. +Qed. diff --git a/theories/QArith/vo.itarget b/theories/QArith/vo.itarget index b3faef8817..b550b47128 100644 --- a/theories/QArith/vo.itarget +++ b/theories/QArith/vo.itarget @@ -2,6 +2,7 @@ Qabs.vo QArith_base.vo QArith.vo Qcanon.vo +Qcabs.vo Qfield.vo Qpower.vo Qreals.vo -- cgit v1.2.3 From 8810dc5bfec0452bfa45f6594382d273c806cc82 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 27 Feb 2016 15:05:39 +0100 Subject: Removing some compatibility layers in Tacinterp. --- tactics/tacinterp.ml | 76 +++++++++++++++++++++------------------------------- 1 file changed, 30 insertions(+), 46 deletions(-) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 43c9ee9be4..9337e604ec 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -23,7 +23,7 @@ open Nametab open Pfedit open Proof_type open Refiner -open Tacmach +open Tacmach.New open Tactic_debug open Constrexpr open Term @@ -718,8 +718,8 @@ let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr (* Interprets a type expression *) -let pf_interp_type ist gl = - interp_type ist (pf_env gl) (project gl) +let pf_interp_type ist env sigma = + interp_type ist env sigma (* Fully evaluate an untyped constr *) let type_uconstr ?(flags = constr_flags) @@ -1240,7 +1240,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with end | TacAbstract (tac,ido) -> Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT - (Option.map (Tacmach.New.of_old (pf_interp_ident ist) gl) ido) (interp_tactic ist tac) + (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) end } | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) @@ -1704,13 +1704,10 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacExact c -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.tactic begin fun gl -> - let (sigma,c_interp) = pf_interp_casted_constr ist gl c in - tclTHEN - (tclEVARS sigma) - (Tactics.exact_no_check c_interp) - gl - end + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let (sigma, c_interp) = pf_interp_casted_constr ist gl c in + Sigma.Unsafe.of_pair (Proofview.V82.tactic (Tactics.exact_no_check c_interp), sigma) + end } end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) @@ -1765,19 +1762,17 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = - let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in + let (sigma,c_interp) = pf_interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,n,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - tclTHEN - (tclEVARS sigma) - (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) - gl - end + let tac = Proofview.V82.tactic (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) in + Sigma.Unsafe.of_pair (tac, sigma) + end } end | TacCofix idopt -> Proofview.Goal.enter { enter = begin fun gl -> @@ -1791,19 +1786,17 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,c) = - let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in + let (sigma,c_interp) = pf_interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - tclTHEN - (tclEVARS sigma) - (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) - gl - end + let tac = Proofview.V82.tactic (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) in + Sigma.Unsafe.of_pair (tac, sigma) + end } end | TacAssert (b,t,ipat,c) -> Proofview.Goal.enter { enter = begin fun gl -> @@ -1844,9 +1837,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in if Locusops.is_nowhere clp then (* We try to fully-typecheck the term *) - let (sigma,c_interp) = - Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl - in + let (sigma,c_interp) = pf_interp_constr ist gl c in let let_tac b na c cl eqpat = let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in @@ -1930,11 +1921,10 @@ and interp_atomic ist tac : unit Proofview.tactic = (Tactics.clear_body l) end } | TacMove (id1,id2) -> - Proofview.V82.tactic begin fun gl -> - Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1) - (interp_move_location ist (pf_env gl) (project gl) id2) - gl - end + Proofview.Goal.enter { enter = begin fun gl -> + Proofview.V82.tactic (Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1) + (interp_move_location ist (pf_env gl) (project gl) id2)) + end } | TacRename l -> Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in @@ -1965,19 +1955,16 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacReduce (r,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in - tclTHEN - (tclEVARS sigma) - (Proofview.V82.of_tactic (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl))) - gl - end + Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) + end } end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.V82.nf_evar_goals <*> - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -2000,9 +1987,8 @@ and interp_atomic ist tac : unit Proofview.tactic = in Sigma.Unsafe.of_pair (c, sigma) end } in - (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)) - gl - end + Proofview.V82.tactic (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)) + end } end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) @@ -2072,9 +2058,7 @@ and interp_atomic ist tac : unit Proofview.tactic = match c with | None -> sigma , None | Some c -> - let (sigma,c_interp) = - Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl - in + let (sigma,c_interp) = pf_interp_constr ist gl c in sigma , Some c_interp in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in -- cgit v1.2.3 From 334302a25bd6c225a95fd82e03a6426497d5106b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 27 Feb 2016 15:40:30 +0100 Subject: Removing Tacmach.New qualification in Tacinterp. --- tactics/tacinterp.ml | 73 ++++++++++++++++++++++++++-------------------------- 1 file changed, 36 insertions(+), 37 deletions(-) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 9337e604ec..d5a1215b87 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -692,7 +692,7 @@ let pf_interp_constr ist gl = let new_interp_constr ist c k = let open Proofview in Proofview.Goal.s_enter { s_enter = begin fun gl -> - let (sigma, c) = interp_constr ist (Goal.env gl) (Tacmach.New.project gl) c in + let (sigma, c) = interp_constr ist (Goal.env gl) (project gl) c in Sigma.Unsafe.of_pair (k c, sigma) end } @@ -860,17 +860,16 @@ let interp_constr_may_eval ist env sigma c = (** TODO: should use dedicated printers *) let rec message_of_value v = let v = Value.normalize v in - let open Tacmach.New in let open Ftactic in if has_type v (topwit wit_tacvalue) then Ftactic.return (str "") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in - Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end } + Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) v) end } else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Tacmach.New.project gl) c) + Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) end } else if has_type v (topwit wit_unit) then Ftactic.return (str "()") @@ -880,16 +879,16 @@ let rec message_of_value v = let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Tacmach.New.project gl) c) p) + Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) end } else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in - Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end } + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) c) end } else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) - (Tacmach.New.project gl) c) + (project gl) c) end } else match Value.to_list v with | Some l -> @@ -1361,7 +1360,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> Ftactic.s_enter { s_enter = begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) @@ -1380,7 +1379,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = interp_app loc ist fv largs | TacFreshId l -> Ftactic.enter { enter = begin fun gl -> - let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Tacmach.New.project gl) l in + let id = interp_fresh_id ist (pf_env gl) (project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) end } | TacPretype c -> @@ -1545,7 +1544,7 @@ and interp_match ist lz constr lmr = end end >>= fun constr -> Ftactic.enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) @@ -1554,7 +1553,7 @@ and interp_match ist lz constr lmr = (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = Ftactic.nf_enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in let hyps = if lr then List.rev hyps else hyps in @@ -1644,7 +1643,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = end >>= fun result -> Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let result = Value.normalize result in try let cresult = coerce_to_closed_constr env result in @@ -1682,7 +1681,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacIntroPattern l -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in Tacticals.New.tclWITHHOLES false (name_atomic ~env @@ -1694,7 +1693,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacIntroMove (ido,hto) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let mloc = interp_move_location ist env sigma hto in let ido = Option.map (interp_ident ist env sigma) ido in name_atomic ~env @@ -1714,7 +1713,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Trace.name_tactic (fun () -> Pp.str"") begin Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let l = List.map (fun (k,c) -> let loc, f = interp_open_constr_with_bindings_loc ist c in (k,(loc,f))) cb @@ -1730,7 +1729,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacElim (ev,(keep,cb),cbo) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in let named_tac = @@ -1741,7 +1740,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacCase (ev,(keep,cb)) -> Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let named_tac = @@ -1753,7 +1752,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacFix (idopt,n) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacFix(idopt,n)) @@ -1777,7 +1776,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacCofix idopt -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacCofix (idopt)) @@ -1801,7 +1800,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacAssert (b,t,ipat,c) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let (sigma,c) = (if Option.is_empty t then interp_constr else interp_type) ist env sigma c in @@ -1814,7 +1813,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacGeneralize cl -> Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in Tacticals.New.tclWITHHOLES false @@ -1832,7 +1831,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let clp = interp_clause ist env sigma clp in let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in if Locusops.is_nowhere clp then @@ -1870,7 +1869,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let sigma,l = List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> (* TODO: move sigma as a side-effect *) @@ -1902,8 +1901,8 @@ and interp_atomic ist tac : unit Proofview.tactic = (* Context management *) | TacClear (b,l) -> Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in + let env = pf_env gl in + let sigma = project gl in let l = interp_hyp_list ist env sigma l in if b then name_atomic ~env (TacClear (b, l)) (Tactics.keep l) else @@ -1913,8 +1912,8 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacClearBody l -> Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in + let env = pf_env gl in + let sigma = project gl in let l = interp_hyp_list ist env sigma l in name_atomic ~env (TacClearBody l) @@ -1927,8 +1926,8 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacRename l -> Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in + let env = pf_env gl in + let sigma = project gl in let l = List.map (fun (id1,id2) -> interp_hyp ist env sigma id1, @@ -1943,7 +1942,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacSplit (ev,bll) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in let named_tac = let tac = Tactics.split_with_bindings ev bll in @@ -1996,7 +1995,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.nf_evar_goals <*> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in Proofview.V82.tactic begin fun gl -> let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in @@ -2023,7 +2022,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacSymmetry c -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let cl = interp_clause ist env sigma c in name_atomic ~env (TacSymmetry cl) @@ -2041,7 +2040,7 @@ and interp_atomic ist tac : unit Proofview.tactic = } in (b,m,keep,f)) l in let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let cl = interp_clause ist env sigma cl in name_atomic ~env (TacRewrite (ev,l,cl,by)) @@ -2053,7 +2052,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (DepInversion (k,c,ids),hyp) -> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let (sigma,c_interp) = match c with | None -> sigma , None @@ -2071,7 +2070,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let hyps = interp_hyp_list ist env sigma idl in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in @@ -2083,7 +2082,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (InversionUsing (c,idl),hyp) -> Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in @@ -2263,7 +2262,7 @@ let dummy_id = Id.of_string "_" let lift_constr_tac_to_ml_tac vars tac = let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let map = function | None -> None | Some id -> -- cgit v1.2.3 From db2c6f0054d3e05f82da7494ce790c04b1976401 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 28 Feb 2016 13:19:47 +0100 Subject: Fixing bug #4596: [rewrite] broke in the past few weeks. Checking that a term was indeed a relation was made too early, as the decomposition function recognized relations of the form "f (g .. (h x y)) with f, g unary and only h binary. We postpone this check to the very end. --- tactics/rewrite.ml | 8 ++++++-- test-suite/bugs/closed/4596.v | 14 ++++++++++++++ 2 files changed, 20 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/4596.v diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 5ca74050a1..803e187ff5 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -468,11 +468,15 @@ let rec decompose_app_rel env evd t = let len = Array.length args in let fargs = Array.sub args 0 (Array.length args - 2) in let rel = mkApp (f, fargs) in - let ty = Retyping.get_type_of env evd rel in - let () = if not (Reduction.is_arity env ty) then error_no_relation () in rel, args.(len - 2), args.(len - 1) | _ -> error_no_relation () +let decompose_app_rel env evd t = + let (rel, t1, t2) = decompose_app_rel env evd t in + let ty = Retyping.get_type_of env evd rel in + let () = if not (Reduction.is_arity env ty) then error_no_relation () in + (rel, t1, t2) + let decompose_applied_relation env sigma (c,l) = let ctype = Retyping.get_type_of env sigma c in let find_rel ty = diff --git a/test-suite/bugs/closed/4596.v b/test-suite/bugs/closed/4596.v new file mode 100644 index 0000000000..592fdb6580 --- /dev/null +++ b/test-suite/bugs/closed/4596.v @@ -0,0 +1,14 @@ +Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms. + +Definition T (x : bool) := x = true. + +Goal forall (S : Type) (b b0 : S -> nat -> bool) (str : S) (p : nat) + (s : forall n : nat, bool) + (s0 s1 : nat -> S -> S), + (forall (str0 : S) (n m : nat), + (if s m then T (b0 (s1 n str0) 0) else T (b (s1 n str0) 0)) -> T (b (s0 n str0) m) -> + T (b str0 m)) -> + T (b str p). +Proof. +intros ???????? H0. +rewrite H0. -- cgit v1.2.3 From 4fcd7fd68986246adb666ed46d066fcf0355bf09 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 20 Feb 2016 14:32:40 +0100 Subject: Slightly contracting code of evarconv.ml. --- pretyping/evarconv.ml | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 0a45ae9fd8..0ccc5b654b 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -322,25 +322,22 @@ let rec evar_conv_x ts env evd pbty term1 term2 = Note: incomplete heuristic... *) let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then ( - let evd, e = + let e = try let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) env evd term1 term2 in - if b then evd, None - else evd, Some (ConversionFailed (env,term1,term2)) - with Univ.UniverseInconsistency e -> evd, Some (UnifUnivInconsistency e) + if b then Success evd + else UnifFailure (evd, ConversionFailed (env,term1,term2)) + with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) in match e with - | None -> Some (evd, e) - | Some e -> - if is_ground_env evd env then Some (evd, Some e) - else None) + | UnifFailure (evd, e) when not (is_ground_env evd env) -> None + | _ -> Some e) else None in match ground_test with - | Some (evd, None) -> Success evd - | Some (evd, Some e) -> UnifFailure (evd,e) + | Some result -> result | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) -- cgit v1.2.3 From 4d25b224b91959b85fcd68c825a307ec684f0bac Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 28 Feb 2016 18:28:14 +0100 Subject: Printing notations: Cleaning in anticipation of fixing #4592. - Making a clear distinction between expressions of the notation which are associated to binding variables only (as in `Notation "'lam' x , P" := (fun x => P)" or `Notation "'exists2' x : t , p & q" := (ex2 (fun x:t => p) (fun x:t => q))') and those which are associated to at list one subterm (e.g. `Notation "x .+1" := (S x)' but also "Notation "{# x | P }" := (ex2 _ (fun y => x = F y) (fun x => P))' as in #4592). The former have type NtnTypeOnlyBinder. - Thus avoiding in particular encoding too early Anonymous as GHole and "Name id" as "GVar id". There is a non-trivial alpha-conversion work to do to get #4592 working. See comments in Notation_ops.add_env. --- interp/constrintern.ml | 10 +-- interp/constrintern.mli | 2 +- interp/notation.ml | 3 +- interp/notation_ops.ml | 183 ++++++++++++++++++++++++++++++++---------------- intf/notation_term.mli | 2 +- toplevel/metasyntax.ml | 20 ++++-- 6 files changed, 146 insertions(+), 74 deletions(-) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 70802d5cba..36f88fc3cc 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -275,7 +275,8 @@ let error_expect_binder_notation_type loc id = let set_var_scope loc id istermvar env ntnvars = try - let idscopes,typ = Id.Map.find id ntnvars in + let isonlybinding,idscopes,typ = Id.Map.find id ntnvars in + if istermvar then isonlybinding := false; let () = if istermvar then (* scopes have no effect on the interpretation of identifiers *) begin match !idscopes with @@ -629,7 +630,7 @@ let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c = let split_by_type ids = List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) -> match typ with - | NtnTypeConstr -> ((x,scl)::l1,l2,l3) + | NtnTypeConstr | NtnTypeOnlyBinder -> ((x,scl)::l1,l2,l3) | NtnTypeConstrList -> (l1,(x,scl)::l2,l3) | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[]) @@ -1845,7 +1846,7 @@ let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c = let interp_notation_constr ?(impls=empty_internalization_env) nenv a = let env = Global.env () in (* [vl] is intended to remember the scope of the free variables of [a] *) - let vl = Id.Map.map (fun typ -> (ref None, typ)) nenv.ninterp_var_type in + let vl = Id.Map.map (fun typ -> (ref true, ref None, typ)) nenv.ninterp_var_type in let c = internalize (Global.env()) {ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impls} false (empty_ltac_sign, vl) a in @@ -1854,7 +1855,8 @@ let interp_notation_constr ?(impls=empty_internalization_env) nenv a = (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in - let vars = Id.Map.map (fun (sc, typ) -> (out_scope !sc, typ)) vl in + let vars = Id.Map.map (fun (isonlybinding, sc, typ) -> + (!isonlybinding, out_scope !sc, typ)) vl in (* Returns [a] and the ordered list of variables with their scopes *) vars, a diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 73ecc437dd..eea76aa310 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -185,7 +185,7 @@ val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr guaranteed to have the same domain as the input one. *) val interp_notation_constr : ?impls:internalization_env -> notation_interp_env -> constr_expr -> - (subscopes * notation_var_internalization_type) Id.Map.t * + (bool * subscopes * notation_var_internalization_type) Id.Map.t * notation_constr (** Globalization options *) diff --git a/interp/notation.ml b/interp/notation.ml index 5c10e0af71..04918bf7dd 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -529,9 +529,10 @@ let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeConstr, NtnTypeConstr -> true +| NtnTypeOnlyBinder, NtnTypeOnlyBinder -> true | NtnTypeConstrList, NtnTypeConstrList -> true | NtnTypeBinderList, NtnTypeBinderList -> true -| (NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList), _ -> false +| (NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList), _ -> false let vars_eq (id1, (sc1, tp1)) (id2, (sc2, tp2)) = diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 51dfadac02..6561000c47 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -567,6 +567,18 @@ let abstract_return_type_context_notation_constr = abstract_return_type_context snd (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) +let is_term_meta id metas = + try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false + with Not_found -> false + +let is_onlybinding_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeOnlyBinder -> true | _ -> false + with Not_found -> false + +let is_bindinglist_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeBinderList -> true | _ -> false + with Not_found -> false + exception No_match let rec alpha_var id1 id2 = function @@ -575,26 +587,67 @@ let rec alpha_var id1 id2 = function | _::idl -> alpha_var id1 id2 idl | [] -> Id.equal id1 id2 -let add_env alp (sigma,sigmalist,sigmabinders) var v = +let add_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var v = (* Check that no capture of binding variables occur *) + (* [alp] is used when matching a pattern "fun x => ... x ... ?var ... x ..." + with an actual term "fun z => ... z ..." when "x" is not bound in the + notation, as in "Notation "'twice_upto' y" := (fun x => x + x + y)". Then + we keep (z,x) in alp, and we have to check that what the [v] which is bound + to [var] does not contain z *) if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match; + (* [alpmetas] is used when matching a pattern "fun x => ... x ... ?var ... x ..." + with an actual term "fun z => ... z ..." when "x" is bound in the + notation and the name "x" cannot be changed to "z", e.g. because + used at another occurrence, as in "Notation "'lam' y , P & Q" := + ((fun y => P),(fun y => Q))". Then, we keep (z,y) in alpmetas, and we + have to check that "fun z => ... z ..." denotes the same term as + "fun x => ... x ... ?var ... x" up to alpha-conversion when [var] + is instantiated by [v]; + Currently, we fail, but, eventually, [x] in [v] could be replaced by [x], + and, in match_, when finding "x" in subterm, failing because of a capture, + and, in match_, when finding "z" in subterm, replacing it with "x", + and, in an even further step, being even more robust, independent of the order, so + that e.g. the notation for ex2 works on "x y |- ex2 (fun x => y=x) (fun y => x=y)" + by giving, say, "exists2 x0, y=x0 & x=x0", but this would typically require the + glob_constr_eq in bind_term_env to be postponed in match_notation_constr, and the + choice of exact variable be done there; but again, this would be a non-trivial + refinement *) + if alpmetas != [] then raise No_match; + (* TODO: handle the case of multiple occs in different scopes *) + ((var,v)::terms,onlybinders,termlists,binderlists) + +let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v = (* TODO: handle the case of multiple occs in different scopes *) - ((var,v)::sigma,sigmalist,sigmabinders) + (terms,(var,v)::onlybinders,termlists,binderlists) -let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v = +let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl = + (terms,onlybinders,termlists,(x,List.rev bl)::binderlists) + +let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = try - let v' = Id.List.assoc var sigma in + let v' = Id.List.assoc var terms in match v, v' with - | GHole _, _ -> fullsigma + | GHole _, _ -> sigma | _, GHole _ -> - add_env alp (Id.List.remove_assoc var sigma,sigmalist,sigmabinders) var v + let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in + add_env alp sigma var v | _, _ -> - if glob_constr_eq v v' then fullsigma + if glob_constr_eq v v' then sigma else raise No_match - with Not_found -> add_env alp fullsigma var v + with Not_found -> add_env alp sigma var v -let bind_binder (sigma,sigmalist,sigmabinders) x bl = - (sigma,sigmalist,(x,List.rev bl)::sigmabinders) +let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = + try + let v' = Id.List.assoc var onlybinders in + match v, v' with + | Anonymous, _ -> alp, sigma + | _, Anonymous -> + let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in + alp, add_binding_env alp sigma var v + | Name id1, Name id2 -> + if Id.equal id1 id2 then alp,sigma + else (fst alp,(id1,id2)::snd alp),sigma + with Not_found -> alp, add_binding_env alp sigma var v let match_fix_kind fk1 fk2 = match (fk1,fk2) with @@ -615,12 +668,16 @@ let match_opt f sigma t1 t2 = match (t1,t2) with | _ -> raise No_match let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with - | (_,Name id2) when Id.List.mem id2 (fst metas) -> - let rhs = match na1 with - | Name id1 -> GVar (Loc.ghost,id1) - | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in - alp, bind_env alp sigma id2 rhs - | (Name id1,Name id2) -> (id1,id2)::alp,sigma + | (na1,Name id2) when is_onlybinding_meta id2 metas -> + bind_binding_env alp sigma id2 na1 + | (Name id1,Name id2) when is_term_meta id2 metas -> + (* We let the non-binding occurrence define the rhs and hence reason up to *) + (* alpha-conversion for the given occurrence of the name (see #)) *) + (fst alp,(id1,id2)::snd alp), sigma + | (Anonymous,Name id2) when is_term_meta id2 metas -> + (* We let the non-binding occurrence define the rhs *) + alp, sigma + | (Name id1,Name id2) -> ((id1,id2)::fst alp, snd alp),sigma | (Anonymous,Anonymous) -> alp,sigma | _ -> raise No_match @@ -645,36 +702,38 @@ let rec match_iterated_binders islambda decls = function ((na,Explicit (*?*), Some c,GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None))::decls) b | b -> (decls,b) -let remove_sigma x (sigmavar,sigmalist,sigmabinders) = - (Id.List.remove_assoc x sigmavar,sigmalist,sigmabinders) +let remove_sigma x (terms,onlybinders,termlists,binderlists) = + (Id.List.remove_assoc x terms,onlybinders,termlists,binderlists) + +let add_ldots_var metas = (ldots_var,((None,[]),NtnTypeConstr))::metas let match_abinderlist_with_app match_fun metas sigma rest x iter termin = let rec aux sigma acc rest = try - let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in - let rest = Id.List.assoc ldots_var (pi1 sigma) in + let (terms,_,_,binderlists as sigma) = match_fun (add_ldots_var metas) sigma rest iter in + let rest = Id.List.assoc ldots_var terms in let b = - match Id.List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false + match Id.List.assoc x binderlists with [b] -> b | _ ->assert false in let sigma = remove_sigma x (remove_sigma ldots_var sigma) in aux sigma (b::acc) rest with No_match when not (List.is_empty acc) -> acc, match_fun metas sigma rest termin in let bl,sigma = aux sigma [] rest in - bind_binder sigma x bl + add_bindinglist_env sigma x bl let match_alist match_fun metas sigma rest x iter termin lassoc = let rec aux sigma acc rest = try - let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in - let rest = Id.List.assoc ldots_var (pi1 sigma) in - let t = Id.List.assoc x (pi1 sigma) in + let (terms,_,_,_ as sigma) = match_fun (add_ldots_var metas) sigma rest iter in + let rest = Id.List.assoc ldots_var terms in + let t = Id.List.assoc x terms in let sigma = remove_sigma x (remove_sigma ldots_var sigma) in aux sigma (t::acc) rest with No_match when not (List.is_empty acc) -> acc, match_fun metas sigma rest termin in - let l,sigma = aux sigma [] rest in - (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma) + let l,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in + (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) let does_not_come_from_already_eta_expanded_var = (* This is hack to avoid looping on a rule with rhs of the form *) @@ -688,11 +747,11 @@ let does_not_come_from_already_eta_expanded_var = (* checked). *) function GVar _ -> false | _ -> true -let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = +let rec match_ inner u alp metas sigma a1 a2 = match (a1,a2) with (* Matching notation variable *) - | r1, NVar id2 when Id.List.mem id2 tmetas -> bind_env alp sigma id2 r1 + | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 r1 (* Matching recursive notations for terms *) | r1, NList (x,_,iter,termin,lassoc) -> @@ -702,25 +761,26 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = | GLambda (_,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name id2,_,b2),termin)-> let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Lambda itself *) - match_in u alp metas (bind_binder sigma x decls) b termin + match_in u alp metas (add_bindinglist_env sigma x decls) b termin | GProd (_,na1,bk,t1,b1), NBinderList (x,_,NProd (Name id2,_,b2),termin) when na1 != Anonymous -> let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Prod itself *) - match_in u alp metas (bind_binder sigma x decls) b termin + match_in u alp metas (add_bindinglist_env sigma x decls) b termin (* Matching recursive notations for binders: general case *) | r, NBinderList (x,_,iter,termin) -> match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin (* Matching individual binders as part of a recursive pattern *) - | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2) when Id.List.mem id blmetas -> - match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2) + when is_bindinglist_meta id metas -> + match_in u alp metas (add_bindinglist_env sigma id [(na,bk,None,t)]) b1 b2 | GProd (_,na,bk,t,b1), NProd (Name id,_,b2) - when Id.List.mem id blmetas && na != Anonymous -> - match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + when is_bindinglist_meta id metas && na != Anonymous -> + match_in u alp metas (add_bindinglist_env sigma id [(na,bk,None,t)]) b1 b2 (* Matching compositionally *) - | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma + | GVar (_,id1), NVar id2 when alpha_var id1 id2 (fst alp) -> sigma | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma | GApp (loc,f1,l1), NApp (f2,l2) -> @@ -799,9 +859,9 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = let t1 = GHole(Loc.ghost,Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in let sigma = match t2 with | NHole _ -> sigma - | NVar id2 -> bind_env alp sigma id2 t1 + | NVar id2 -> bind_term_env alp sigma id2 t1 | _ -> assert false in - match_in u alp metas (bind_binder sigma id [(Name id',Explicit,None,t1)]) + match_in u alp metas (add_bindinglist_env sigma id [(Name id',Explicit,None,t1)]) (mkGApp Loc.ghost b1 (GVar (Loc.ghost,id'))) b2 | (GRec _ | GEvar _), _ @@ -823,14 +883,16 @@ and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 +let term_of_binder = function + | Name id -> GVar (Loc.ghost,id) + | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) + let match_notation_constr u c (metas,pat) = - let test (_, (_, x)) = match x with NtnTypeBinderList -> false | _ -> true in - let vars = List.partition test metas in - let vars = (List.map fst (fst vars), List.map fst (snd vars)) in - let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in + let terms,binders,termlists,binderlists = + match_ false u ([],[]) metas ([],[],[],[]) c pat in (* Reorder canonically the substitution *) - let find x = - try Id.List.assoc x terms + let find_binder x = + try term_of_binder (Id.List.assoc x binders) with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) @@ -838,11 +900,13 @@ let match_notation_constr u c (metas,pat) = List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> match typ with | NtnTypeConstr -> - ((find x, scl)::terms',termlists',binders') + ((Id.List.assoc x terms, scl)::terms',termlists',binders') + | NtnTypeOnlyBinder -> + ((find_binder x, scl)::terms',termlists',binders') | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists',binders') | NtnTypeBinderList -> - (terms',termlists',(Id.List.assoc x binders,scl)::binders')) + (terms',termlists',(Id.List.assoc x binderlists,scl)::binders')) metas ([],[],[]) (* Matching cases pattern *) @@ -851,17 +915,17 @@ let add_patterns_for_params ind l = let nparams = mib.Declarations.mind_nparams in Util.List.addn nparams (PatVar (Loc.ghost,Anonymous)) l -let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v = +let bind_env_cases_pattern (terms,x,termlists,y as sigma) var v = try - let vvar = Id.List.assoc var sigma in - if cases_pattern_eq v vvar then fullsigma else raise No_match + let vvar = Id.List.assoc var terms in + if cases_pattern_eq v vvar then sigma else raise No_match with Not_found -> (* TODO: handle the case of multiple occs in different scopes *) - (var,v)::sigma,sigmalist,x + (var,v)::terms,x,termlists,y -let rec match_cases_pattern metas sigma a1 a2 = +let rec match_cases_pattern metas (terms,x,termlists,y as sigma) a1 a2 = match (a1,a2) with - | r1, NVar id2 when Id.List.mem id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[]) + | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[]) | PatVar (_,Anonymous), NHole _ -> sigma,(0,[]) | PatCstr (loc,(ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> sigma,(0,add_patterns_for_params (fst r1) largs) @@ -876,14 +940,14 @@ let rec match_cases_pattern metas sigma a1 a2 = let l1',more_args = Util.List.chop le2 l1 in (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) | r1, NList (x,_,iter,termin,lassoc) -> - (match_alist (fun (metas,_) -> match_cases_pattern_no_more_args metas) - (metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc),(0,[]) + (match_alist (match_cases_pattern_no_more_args) + metas (terms,(),termlists,()) r1 x iter termin lassoc),(0,[]) | _ -> raise No_match and match_cases_pattern_no_more_args metas sigma a1 a2 = match match_cases_pattern metas sigma a1 a2 with - |out,(_,[]) -> out - |_ -> raise No_match + | out,(_,[]) -> out + | _ -> raise No_match let match_ind_pattern metas sigma ind pats a2 = match a2 with @@ -904,16 +968,15 @@ let reorder_canonically_substitution terms termlists metas = List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> match typ with | NtnTypeConstr -> ((Id.List.assoc x terms, scl)::terms',termlists') + | NtnTypeOnlyBinder -> assert false | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists') | NtnTypeBinderList -> assert false) metas ([],[]) let match_notation_constr_cases_pattern c (metas,pat) = - let vars = List.map fst metas in - let (terms,termlists,()),more_args = match_cases_pattern vars ([],[],()) c pat in + let (terms,(),termlists,()),more_args = match_cases_pattern metas ([],(),[],()) c pat in reorder_canonically_substitution terms termlists metas, more_args let match_notation_constr_ind_pattern ind args (metas,pat) = - let vars = List.map fst metas in - let (terms,termlists,()),more_args = match_ind_pattern vars ([],[],()) ind args pat in + let (terms,(),termlists,()),more_args = match_ind_pattern metas ([],(),[],()) ind args pat in reorder_canonically_substitution terms termlists metas, more_args diff --git a/intf/notation_term.mli b/intf/notation_term.mli index 3a643b99b2..39a36310d1 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -61,7 +61,7 @@ type subscopes = tmp_scope_name option * scope_name list (** Type of the meta-variables of an notation_constr: in a recursive pattern x..y, x carries the sequence of objects bound to the list x..y *) type notation_var_instance_type = - | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList + | NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList (** Type of variables when interpreting a constr_expr as an notation_constr: in a recursive pattern x..y, both x and y carry the individual type diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 0d002aa8e9..98d1a23770 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -1017,9 +1017,10 @@ let make_internalization_vars recvars mainvars typs = let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in maintyps @ extratyps -let make_interpretation_type isrec = function +let make_interpretation_type isrec isonlybinding = function | NtnInternTypeConstr when isrec -> NtnTypeConstrList - | NtnInternTypeConstr | NtnInternTypeIdent -> NtnTypeConstr + | NtnInternTypeConstr | NtnInternTypeIdent -> + if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr | NtnInternTypeBinder when isrec -> NtnTypeBinderList | NtnInternTypeBinder -> error "Type not allowed in recursive notation." @@ -1029,16 +1030,16 @@ let make_interpretation_vars recvars allvars = List.equal String.equal l1 l2 in let check (x, y) = - let (scope1, _) = Id.Map.find x allvars in - let (scope2, _) = Id.Map.find y allvars in + let (_,scope1, _) = Id.Map.find x allvars in + let (_,scope2, _) = Id.Map.find y allvars in if not (eq_subscope scope1 scope2) then error_not_same_scope x y in let () = List.iter check recvars in let useless_recvars = List.map snd recvars in let mainvars = Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in - Id.Map.mapi (fun x (sc, typ) -> - (sc, make_interpretation_type (Id.List.mem_assoc x recvars) typ)) mainvars + Id.Map.mapi (fun x (isonlybinding, sc, typ) -> + (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars let check_rule_productivity l = if List.for_all (function NonTerminal _ -> true | _ -> false) l then @@ -1492,7 +1493,12 @@ let add_syntactic_definition ident (vars,c) local onlyparse = } in let nvars, pat = interp_notation_constr nenv c in let () = nonprintable := nenv.ninterp_only_parse in - let map id = let (sc, _) = Id.Map.find id nvars in (id, sc) in + let map id = + let (isonlybinding,sc, _) = Id.Map.find id nvars in + (* if a notation contains an ltac:, the body is not analyzed + and onlybinding detection fails *) + assert (!nonprintable || not isonlybinding); + (id, sc) in List.map map vars, pat in let onlyparse = match onlyparse with -- cgit v1.2.3 From 48327426b59144f1a7181092068077c5a6df7c60 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 10:45:31 +0100 Subject: Moving the "fix" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 1 - parsing/g_tactic.ml4 | 2 -- printing/pptactic.ml | 1 - tactics/coretactics.ml4 | 7 +++++++ tactics/tacintern.ml | 1 - tactics/tacinterp.ml | 9 --------- tactics/tacsubst.ml | 1 - 7 files changed, 7 insertions(+), 15 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 502f2db4c1..3993f1b371 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -145,7 +145,6 @@ type 'a gen_atomic_tactic_expr = ('nam * 'dtrm intro_pattern_expr located option) option | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg - | TacFix of Id.t option * int | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list | TacCofix of Id.t option | TacMutualCofix of Id.t * (Id.t * 'trm) list diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 77b7b05a39..497819b327 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -555,8 +555,6 @@ GEXTEND Gram TacAtom (!@loc, TacElim (true,cl,el)) | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) - | "fix"; n = natural -> TacAtom (!@loc, TacFix (None,n)) - | "fix"; id = ident; n = natural -> TacAtom (!@loc, TacFix (Some id,n)) | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) | "cofix" -> TacAtom (!@loc, TacCofix None) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 12667d0f24..fe0be9b255 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -828,7 +828,6 @@ module Make ++ pr_opt pr_eliminator cbo) | TacCase (ev,cb) -> hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb) - | TacFix (ido,n) -> hov 1 (primitive "fix" ++ pr_opt pr_id ido ++ pr_intarg n) | TacMutualFix (id,n,l) -> hov 1 ( primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 63fb67e146..c6f59f79e3 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -192,6 +192,13 @@ TACTIC EXTEND admit [ "admit" ] -> [ Proofview.give_up ] END +(* Fix *) + +TACTIC EXTEND fix + [ "fix" natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix None n) ] +| [ "fix" ident(id) natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix (Some id) n) ] +END + (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index cbb9db65c1..b4a595b051 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -491,7 +491,6 @@ let rec intern_atomic lf ist x = TacElim (ev,intern_constr_with_bindings_arg ist cb, Option.map (intern_constr_with_bindings ist) cbo) | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) - | TacFix (idopt,n) -> TacFix (Option.map (intern_ident lf ist) idopt,n) | TacMutualFix (id,n,l) -> let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in TacMutualFix (intern_ident lf ist id, n, List.map f l) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index d5a1215b87..f74ea4fc9b 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1749,15 +1749,6 @@ and interp_atomic ist tac : unit Proofview.tactic = in Tacticals.New.tclWITHHOLES ev named_tac sigma end } - | TacFix (idopt,n) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let idopt = Option.map (interp_ident ist env sigma) idopt in - name_atomic ~env - (TacFix(idopt,n)) - (Proofview.V82.tactic (Tactics.fix idopt n)) - end } | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 4a5fa9828e..f611f03684 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -146,7 +146,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacElim (ev,subst_glob_with_bindings_arg subst cb, Option.map (subst_glob_with_bindings subst) cbo) | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) - | TacFix (idopt,n) as x -> x | TacMutualFix (id,n,l) -> TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) | TacCofix idopt as x -> x -- cgit v1.2.3 From bda8b2e8f90235ca875422f211cb781068b20b3c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 10:54:08 +0100 Subject: Moving the "cofix" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 1 - parsing/g_tactic.ml4 | 2 -- printing/pptactic.ml | 2 -- tactics/coretactics.ml4 | 8 +++++++- tactics/tacintern.ml | 1 - tactics/tacinterp.ml | 9 --------- tactics/tacsubst.ml | 1 - 7 files changed, 7 insertions(+), 17 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 3993f1b371..33a96150c1 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -146,7 +146,6 @@ type 'a gen_atomic_tactic_expr = | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list - | TacCofix of Id.t option | TacMutualCofix of Id.t * (Id.t * 'trm) list | TacAssert of bool * 'tacexpr option * diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 497819b327..6c3918be3a 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -557,8 +557,6 @@ GEXTEND Gram | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) - | "cofix" -> TacAtom (!@loc, TacCofix None) - | "cofix"; id = ident -> TacAtom (!@loc, TacCofix (Some id)) | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index fe0be9b255..05c3b3bf42 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -832,8 +832,6 @@ module Make hov 1 ( primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l) - | TacCofix ido -> - hov 1 (primitive "cofix" ++ pr_opt pr_id ido) | TacMutualCofix (id,l) -> hov 1 ( primitive "cofix" ++ spc () ++ pr_id id ++ spc() diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index c6f59f79e3..27efc06cca 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -199,6 +199,13 @@ TACTIC EXTEND fix | [ "fix" ident(id) natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix (Some id) n) ] END +(* Cofix *) + +TACTIC EXTEND cofix + [ "cofix" ] -> [ Proofview.V82.tactic (Tactics.cofix None) ] +| [ "cofix" ident(id) ] -> [ Proofview.V82.tactic (Tactics.cofix (Some id)) ] +END + (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr @@ -217,7 +224,6 @@ let initial_atomic () = "compute", TacReduce(Cbv Redops.all_flags,nocl); "intro", TacIntroMove(None,MoveLast); "intros", TacIntroPattern []; - "cofix", TacCofix None; ] in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index b4a595b051..e7545597cc 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -494,7 +494,6 @@ let rec intern_atomic lf ist x = | TacMutualFix (id,n,l) -> let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in TacMutualFix (intern_ident lf ist id, n, List.map f l) - | TacCofix idopt -> TacCofix (Option.map (intern_ident lf ist) idopt) | TacMutualCofix (id,l) -> let f (id,c) = (intern_ident lf ist id,intern_type ist c) in TacMutualCofix (intern_ident lf ist id, List.map f l) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index f74ea4fc9b..2a741ee367 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1764,15 +1764,6 @@ and interp_atomic ist tac : unit Proofview.tactic = Sigma.Unsafe.of_pair (tac, sigma) end } end - | TacCofix idopt -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let idopt = Option.map (interp_ident ist env sigma) idopt in - name_atomic ~env - (TacCofix (idopt)) - (Proofview.V82.tactic (Tactics.cofix idopt)) - end } | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"") begin diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index f611f03684..faf068bfd5 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -148,7 +148,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) | TacMutualFix (id,n,l) -> TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) - | TacCofix idopt as x -> x | TacMutualCofix (id,l) -> TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) | TacAssert (b,otac,na,c) -> -- cgit v1.2.3 From d0bc16d1a0626f4137797bbf0c91e972a0ff43ac Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 11:05:26 +0100 Subject: Moving the "clear" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 1 - parsing/g_tactic.ml4 | 4 ---- printing/pptactic.ml | 9 --------- tactics/coretactics.ml4 | 10 ++++++++++ tactics/tacintern.ml | 1 - tactics/tacinterp.ml | 11 ----------- tactics/tacsubst.ml | 1 - test-suite/bugs/closed/3612.v | 3 +++ toplevel/vernacentries.ml | 9 +++++++-- 9 files changed, 20 insertions(+), 29 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 33a96150c1..10c616627a 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -161,7 +161,6 @@ type 'a gen_atomic_tactic_expr = | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis (* Context management *) - | TacClear of bool * 'nam list | TacClearBody of 'nam list | TacMove of 'nam * 'nam move_location | TacRename of ('nam *'nam) list diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 6c3918be3a..ad5f78b46d 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -618,10 +618,6 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Context management *) - | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) - | IDENT "clear"; l = LIST0 id_or_meta -> - let is_empty = match l with [] -> true | _ -> false in - TacAtom (!@loc, TacClear (is_empty, l)) | IDENT "clearbody"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClearBody l) | IDENT "move"; hfrom = id_or_meta; hto = move_location -> TacAtom (!@loc, TacMove (hfrom,hto)) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 05c3b3bf42..c61b80c834 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -793,7 +793,6 @@ module Make let rec pr_atom0 a = tag_atom a (match a with | TacIntroPattern [] -> primitive "intros" | TacIntroMove (None,MoveLast) -> primitive "intro" - | TacClear (true,[]) -> primitive "clear" | t -> str "(" ++ pr_atom1 t ++ str ")" ) @@ -899,14 +898,6 @@ module Make ) (* Context management *) - | TacClear (true,[]) as t -> - pr_atom0 t - | TacClear (keep,l) -> - hov 1 ( - primitive "clear" ++ spc () - ++ (if keep then str "- " else mt ()) - ++ prlist_with_sep spc pr.pr_name l - ) | TacClearBody l -> hov 1 ( primitive "clearbody" ++ spc () diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 27efc06cca..ab97dad706 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -206,6 +206,16 @@ TACTIC EXTEND cofix | [ "cofix" ident(id) ] -> [ Proofview.V82.tactic (Tactics.cofix (Some id)) ] END +(* Clear *) + +TACTIC EXTEND clear + [ "clear" hyp_list(ids) ] -> [ + if List.is_empty ids then Tactics.keep [] + else Proofview.V82.tactic (Tactics.clear ids) + ] +| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] +END + (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index e7545597cc..bea8d3469b 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -525,7 +525,6 @@ let rec intern_atomic lf ist x = let h2 = intern_quantified_hypothesis ist h2 in TacDoubleInduction (h1,h2) (* Context management *) - | TacClear (b,l) -> TacClear (b,List.map (intern_hyp ist) l) | TacClearBody l -> TacClearBody (List.map (intern_hyp ist) l) | TacMove (id1,id2) -> TacMove (intern_hyp ist id1,intern_move_location ist id2) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 2a741ee367..74121d3abe 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1881,17 +1881,6 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacDoubleInduction (h1,h2)) (Elim.h_double_induction h1 h2) (* Context management *) - | TacClear (b,l) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = pf_env gl in - let sigma = project gl in - let l = interp_hyp_list ist env sigma l in - if b then name_atomic ~env (TacClear (b, l)) (Tactics.keep l) - else - (* spiwack: until the tactic is in the monad *) - let tac = Proofview.V82.tactic (fun gl -> Tactics.clear l gl) in - Proofview.Trace.name_tactic (fun () -> Pp.str"") tac - end } | TacClearBody l -> Proofview.Goal.enter { enter = begin fun gl -> let env = pf_env gl in diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index faf068bfd5..0b8dbb6e3a 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -167,7 +167,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDoubleInduction (h1,h2) as x -> x (* Context management *) - | TacClear _ as x -> x | TacClearBody l as x -> x | TacMove (id1,id2) as x -> x | TacRename l as x -> x diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v index 9125ab16dd..25060debe2 100644 --- a/test-suite/bugs/closed/3612.v +++ b/test-suite/bugs/closed/3612.v @@ -35,6 +35,9 @@ Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P) (r : p..1 = q..1) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2), p = q. + +Declare ML Module "coretactics". + Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x)) (xx : @paths (@sigT A (fun x0 : A => B x0)) x x), @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index a6a1546ae3..38832b422f 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -884,8 +884,13 @@ let vernac_set_used_variables e = (str "Unknown variable: " ++ pr_id id)) l; let _, to_clear = set_used_variables l in - vernac_solve - SelectAll None Tacexpr.(TacAtom (Loc.ghost,TacClear(false,to_clear))) false + (** FIXME: too fragile *) + let open Tacexpr in + let tac = { mltac_plugin = "coretactics"; mltac_tactic = "clear" } in + let tac = { mltac_name = tac; mltac_index = 0 } in + let arg = Genarg.in_gen (Genarg.rawwit (Genarg.wit_list Constrarg.wit_var)) to_clear in + let tac = if List.is_empty to_clear then TacId [] else TacML (Loc.ghost, tac, [TacGeneric arg]) in + vernac_solve SelectAll None tac false (*****************************) -- cgit v1.2.3 From 7dd8c2bf4747c94be6f18d7fdd0e3b593f560a2f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 11:20:26 +0100 Subject: Moving the "clearbody" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 1 - parsing/g_tactic.ml4 | 1 - printing/pptactic.ml | 5 ----- tactics/coretactics.ml4 | 6 ++++++ tactics/tacintern.ml | 1 - tactics/tacinterp.ml | 9 --------- tactics/tacsubst.ml | 1 - 7 files changed, 6 insertions(+), 18 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 10c616627a..d936748f2d 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -161,7 +161,6 @@ type 'a gen_atomic_tactic_expr = | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis (* Context management *) - | TacClearBody of 'nam list | TacMove of 'nam * 'nam move_location | TacRename of ('nam *'nam) list diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index ad5f78b46d..04ee02f944 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -618,7 +618,6 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Context management *) - | IDENT "clearbody"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClearBody l) | IDENT "move"; hfrom = id_or_meta; hto = move_location -> TacAtom (!@loc, TacMove (hfrom,hto)) | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index c61b80c834..b1d6fb0c0f 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -898,11 +898,6 @@ module Make ) (* Context management *) - | TacClearBody l -> - hov 1 ( - primitive "clearbody" ++ spc () - ++ prlist_with_sep spc pr.pr_name l - ) | TacMove (id1,id2) -> hov 1 ( primitive "move" diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index ab97dad706..b68aab621e 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -216,6 +216,12 @@ TACTIC EXTEND clear | [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] END +(* Clearbody *) + +TACTIC EXTEND clearbody + [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] +END + (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index bea8d3469b..9775f103f8 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -525,7 +525,6 @@ let rec intern_atomic lf ist x = let h2 = intern_quantified_hypothesis ist h2 in TacDoubleInduction (h1,h2) (* Context management *) - | TacClearBody l -> TacClearBody (List.map (intern_hyp ist) l) | TacMove (id1,id2) -> TacMove (intern_hyp ist id1,intern_move_location ist id2) | TacRename l -> diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 74121d3abe..b2f539fb97 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1881,15 +1881,6 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacDoubleInduction (h1,h2)) (Elim.h_double_induction h1 h2) (* Context management *) - | TacClearBody l -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = pf_env gl in - let sigma = project gl in - let l = interp_hyp_list ist env sigma l in - name_atomic ~env - (TacClearBody l) - (Tactics.clear_body l) - end } | TacMove (id1,id2) -> Proofview.Goal.enter { enter = begin fun gl -> Proofview.V82.tactic (Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1) diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 0b8dbb6e3a..50730eaea1 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -167,7 +167,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDoubleInduction (h1,h2) as x -> x (* Context management *) - | TacClearBody l as x -> x | TacMove (id1,id2) as x -> x | TacRename l as x -> x -- cgit v1.2.3 From 6c4fcb156dea5a71fd227606b87333ae00aacb69 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 11:35:34 +0100 Subject: Moving the "generalize dependent" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 1 - parsing/g_tactic.ml4 | 1 - printing/pptactic.ml | 5 ----- tactics/coretactics.ml4 | 6 ++++++ tactics/tacintern.ml | 1 - tactics/tacinterp.ml | 6 ------ tactics/tacsubst.ml | 1 - 7 files changed, 6 insertions(+), 15 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index d936748f2d..52c07e089a 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -151,7 +151,6 @@ type 'a gen_atomic_tactic_expr = bool * 'tacexpr option * 'dtrm intro_pattern_expr located option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list - | TacGeneralizeDep of 'trm | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * intro_pattern_naming_expr located option diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 04ee02f944..238b9a60f7 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -603,7 +603,6 @@ GEXTEND Gram na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) - | IDENT "generalize"; IDENT "dependent"; c = constr -> TacAtom (!@loc, TacGeneralizeDep c) (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> diff --git a/printing/pptactic.ml b/printing/pptactic.ml index b1d6fb0c0f..f4007e25e1 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -854,11 +854,6 @@ module Make pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) l ) - | TacGeneralizeDep c -> - hov 1 ( - primitive "generalize" ++ spc () ++ str "dependent" - ++ pr_constrarg c - ) | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) | TacLetTac (na,c,cl,b,e) -> diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index b68aab621e..5862e0f8a0 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -222,6 +222,12 @@ TACTIC EXTEND clearbody [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] END +(* Generalize dependent *) + +TACTIC EXTEND generalize_dependent + [ "generalize" "dependent" constr(c) ] -> [ Proofview.V82.tactic (Tactics.generalize_dep c) ] +END + (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 9775f103f8..d5f7c72ec1 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -505,7 +505,6 @@ let rec intern_atomic lf ist x = TacGeneralize (List.map (fun (c,na) -> intern_constr_with_occurrences ist c, intern_name lf ist na) cl) - | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c) | TacLetTac (na,c,cls,b,eqpat) -> let na = intern_name lf ist na in TacLetTac (na,intern_constr ist c, diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index b2f539fb97..d1a47dce5a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1803,12 +1803,6 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacGeneralize cl) (Proofview.V82.tactic (Tactics.generalize_gen cl))) sigma end } - | TacGeneralizeDep c -> - (new_interp_constr ist c) (fun c -> - name_atomic (* spiwack: probably needs a goal environment *) - (TacGeneralizeDep c) - (Proofview.V82.tactic (Tactics.generalize_dep c)) - ) | TacLetTac (na,c,clp,b,eqpat) -> Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_enter { enter = begin fun gl -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 50730eaea1..36e0b4278e 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -154,7 +154,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacAssert (b,Option.map (subst_tactic subst) otac,na,subst_glob_constr subst c) | TacGeneralize cl -> TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) - | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c) | TacLetTac (id,c,clp,b,eqpat) -> TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) -- cgit v1.2.3 From ae3bbff3ca2564fe24bdf3dd517c82807eae9151 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 12:11:52 +0100 Subject: Moving the "symmetry" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 3 --- parsing/g_tactic.ml4 | 2 -- printing/pptactic.ml | 4 ---- tactics/coretactics.ml4 | 1 + tactics/tacintern.ml | 4 ---- tactics/tacinterp.ml | 10 ---------- tactics/tacsubst.ml | 3 --- 7 files changed, 1 insertion(+), 26 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 52c07e089a..3f1d0fd76c 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -170,9 +170,6 @@ type 'a gen_atomic_tactic_expr = | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr | TacChange of 'pat option * 'dtrm * 'nam clause_expr - (* Equivalence relations *) - | TacSymmetry of 'nam clause_expr - (* Equality and inversion *) | TacRewrite of evars_flag * (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 238b9a60f7..4587e321f0 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -625,8 +625,6 @@ GEXTEND Gram | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll)) | IDENT "eexists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (true,bll)) - (* Equivalence relations *) - | IDENT "symmetry"; "in"; cl = in_clause -> TacAtom (!@loc, TacSymmetry cl) (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; diff --git a/printing/pptactic.ml b/printing/pptactic.ml index f4007e25e1..689ac6e4eb 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -935,10 +935,6 @@ module Make ) ++ pr.pr_dconstr c ++ pr_clauses (Some true) pr.pr_name h ) - (* Equivalence relations *) - | TacSymmetry cls -> - primitive "symmetry" ++ pr_clauses (Some true) pr.pr_name cls - (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> hov 1 ( diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 5862e0f8a0..55461ef7c5 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -140,6 +140,7 @@ END TACTIC EXTEND symmetry [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +| [ "symmetry" clause(cl) ] -> [ Tactics.intros_symmetry cl ] END (** Split *) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index d5f7c72ec1..84df21eb81 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -555,10 +555,6 @@ let rec intern_atomic lf ist x = TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, clause_app (intern_hyp_location ist) cl) - (* Equivalence relations *) - | TacSymmetry idopt -> - TacSymmetry (clause_app (intern_hyp_location ist) idopt) - (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index d1a47dce5a..81fbcc6db6 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1974,16 +1974,6 @@ and interp_atomic ist tac : unit Proofview.tactic = end } end - (* Equivalence relations *) - | TacSymmetry c -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let cl = interp_clause ist env sigma c in - name_atomic ~env - (TacSymmetry cl) - (Tactics.intros_symmetry cl) - end } (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 36e0b4278e..142a964454 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -178,9 +178,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacChange (Option.map (subst_glob_constr_or_pattern subst) op, subst_glob_constr subst c, cl) - (* Equivalence relations *) - | TacSymmetry _ as x -> x - (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite (ev, -- cgit v1.2.3 From 293222e49ff81bc1299b3822d2a8c526ca803307 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 12:40:45 +0100 Subject: Moving the "exists" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 3 --- parsing/g_tactic.ml4 | 5 ----- printing/pptactic.ml | 8 -------- tactics/coretactics.ml4 | 23 +++++++++++++++++++++++ tactics/tacintern.ml | 3 --- tactics/tacinterp.ml | 12 ------------ tactics/tacsubst.ml | 3 --- 7 files changed, 23 insertions(+), 34 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 3f1d0fd76c..dae960e0e5 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -163,9 +163,6 @@ type 'a gen_atomic_tactic_expr = | TacMove of 'nam * 'nam move_location | TacRename of ('nam *'nam) list - (* Trmuctors *) - | TacSplit of evars_flag * 'trm bindings list - (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr | TacChange of 'pat option * 'dtrm * 'nam clause_expr diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 4587e321f0..e50eca25be 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -621,11 +621,6 @@ GEXTEND Gram TacAtom (!@loc, TacMove (hfrom,hto)) | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) - (* Constructors *) - | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll)) - | IDENT "eexists"; bll = opt_bindings -> - TacAtom (!@loc, TacSplit (true,bll)) - (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 689ac6e4eb..2c57cb811e 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -725,7 +725,6 @@ module Make (* some shortcuts *) let _pr_bindings = pr_bindings pr.pr_constr pr.pr_lconstr in - let pr_ex_bindings = pr_bindings_gen true pr.pr_constr pr.pr_lconstr in let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in let pr_with_bindings_arg_full = pr_with_bindings_arg in let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in @@ -909,13 +908,6 @@ module Make l ) - (* Constructors *) - | TacSplit (ev,l) -> - hov 1 ( - primitive (with_evars ev "exists") - ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l - ) - (* Conversion *) | TacReduce (r,h) -> hov 1 ( diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 55461ef7c5..2d5ce53075 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -15,6 +15,7 @@ open Misctypes open Genredexpr open Proofview.Notations +open Sigma.Notations DECLARE PLUGIN "coretactics" @@ -145,6 +146,14 @@ END (** Split *) +let rec delayed_list = function +| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } +| x :: l -> + { Tacexpr.delayed = fun env sigma -> + let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in + let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in + Sigma (x :: l, sigma, p +> q) } + TACTIC EXTEND split [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] END @@ -165,6 +174,20 @@ TACTIC EXTEND esplit_with ] END +TACTIC EXTEND exists + [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) + ] +END + +TACTIC EXTEND eexists + [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) + ] +END + (** Intro *) TACTIC EXTEND intros_until diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 84df21eb81..e69d3f61e0 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -531,9 +531,6 @@ let rec intern_atomic lf ist x = intern_hyp ist id1, intern_hyp ist id2) l) - (* Constructors *) - | TacSplit (ev,bll) -> TacSplit (ev,List.map (intern_bindings ist) bll) - (* Conversion *) | TacReduce (r,cl) -> dump_glob_red_expr r; diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 81fbcc6db6..65fdecc29b 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1894,18 +1894,6 @@ and interp_atomic ist tac : unit Proofview.tactic = (Tactics.rename_hyp l) end } - (* Constructors *) - | TacSplit (ev,bll) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in - let named_tac = - let tac = Tactics.split_with_bindings ev bll in - name_atomic ~env (TacSplit (ev, bll)) tac - in - Tacticals.New.tclWITHHOLES ev named_tac sigma - end } (* Conversion *) | TacReduce (r,cl) -> (* spiwack: until the tactic is in the monad *) diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 142a964454..ba9a74d05a 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -169,9 +169,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacMove (id1,id2) as x -> x | TacRename l as x -> x - (* Constructors *) - | TacSplit (ev,bll) -> TacSplit (ev,List.map (subst_bindings subst) bll) - (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) | TacChange (op,c,cl) -> -- cgit v1.2.3 From 1397f791b1699b0f04d971465270d5b2df9a6d7f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 13:32:39 +0100 Subject: Moving the "move" tactic to TACTIC EXTEND. --- intf/tacexpr.mli | 1 - parsing/g_tactic.ml4 | 2 -- printing/pptactic.ml | 6 ------ tactics/coretactics.ml4 | 9 +++++++++ tactics/tacintern.ml | 2 -- tactics/tacinterp.ml | 5 ----- tactics/tacsubst.ml | 1 - 7 files changed, 9 insertions(+), 17 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index dae960e0e5..7366bc03e6 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -160,7 +160,6 @@ type 'a gen_atomic_tactic_expr = | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis (* Context management *) - | TacMove of 'nam * 'nam move_location | TacRename of ('nam *'nam) list (* Conversion *) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index e50eca25be..0c90a8bca4 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -617,8 +617,6 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Context management *) - | IDENT "move"; hfrom = id_or_meta; hto = move_location -> - TacAtom (!@loc, TacMove (hfrom,hto)) | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) (* Equality and inversion *) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 2c57cb811e..36863906ea 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -892,12 +892,6 @@ module Make ) (* Context management *) - | TacMove (id1,id2) -> - hov 1 ( - primitive "move" - ++ brk (1,1) ++ pr.pr_name id1 - ++ Miscprint.pr_move_location pr.pr_name id2 - ) | TacRename l -> hov 1 ( primitive "rename" ++ brk (1,1) diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 2d5ce53075..74d98176a4 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -194,6 +194,15 @@ TACTIC EXTEND intros_until [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] END +(** Move *) + +TACTIC EXTEND move + [ "move" hyp(id) "at" "top" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveFirst) ] +| [ "move" hyp(id) "at" "bottom" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveLast) ] +| [ "move" hyp(id) "after" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveAfter h)) ] +| [ "move" hyp(id) "before" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveBefore h)) ] +END + (** Revert *) TACTIC EXTEND revert diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index e69d3f61e0..a069fd7557 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -524,8 +524,6 @@ let rec intern_atomic lf ist x = let h2 = intern_quantified_hypothesis ist h2 in TacDoubleInduction (h1,h2) (* Context management *) - | TacMove (id1,id2) -> - TacMove (intern_hyp ist id1,intern_move_location ist id2) | TacRename l -> TacRename (List.map (fun (id1,id2) -> intern_hyp ist id1, diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 65fdecc29b..1a8a95158a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1875,11 +1875,6 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacDoubleInduction (h1,h2)) (Elim.h_double_induction h1 h2) (* Context management *) - | TacMove (id1,id2) -> - Proofview.Goal.enter { enter = begin fun gl -> - Proofview.V82.tactic (Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1) - (interp_move_location ist (pf_env gl) (project gl) id2)) - end } | TacRename l -> Proofview.Goal.enter { enter = begin fun gl -> let env = pf_env gl in diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index ba9a74d05a..3f103a290d 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -166,7 +166,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDoubleInduction (h1,h2) as x -> x (* Context management *) - | TacMove (id1,id2) as x -> x | TacRename l as x -> x (* Conversion *) -- cgit v1.2.3 From 508d5a99101097948b6de342295eec0d5c8cbe72 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Mar 2016 18:59:51 +0100 Subject: Fixing bug #4105: poor escaping in the protocol between CoqIDE and coqtop. Printing invalid UTF-8 string startled GTK too much, leading to CoqIDE dying improperly. We now check that all strings outputed by Coq are proper UTF-8. This is not perfect, as CoqIDE will sometimes truncate strings which contains the null character, but at least it should not crash. --- interp/notation.ml | 6 ++++-- lib/unicode.ml | 7 +++++++ lib/unicode.mli | 3 +++ 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/interp/notation.ml b/interp/notation.ml index 5c10e0af71..c4addbf10f 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -314,7 +314,9 @@ let declare_prim_token_interpreter sc interp (patl,uninterp,b) = patl let mkNumeral n = Numeral n -let mkString s = String s +let mkString = function +| None -> None +| Some s -> if Unicode.is_utf8 s then Some (String s) else None let delay dir int loc x = (dir, (fun () -> int loc x)) @@ -326,7 +328,7 @@ let declare_numeral_interpreter sc dir interp (patl,uninterp,inpat) = let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = declare_prim_token_interpreter sc (fun cont loc -> function String s -> delay dir interp loc s | p -> cont loc p) - (patl, (fun r -> Option.map mkString (uninterp r)), inpat) + (patl, (fun r -> mkString (uninterp r)), inpat) let check_required_module loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () diff --git a/lib/unicode.ml b/lib/unicode.ml index 1765e93dcd..cfaa73cc11 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -168,6 +168,13 @@ let next_utf8 s i = (c land 0x3F) lsl 6 + (d land 0x3F) else err () +let is_utf8 s = + let rec check i = + let (off, _) = next_utf8 s i in + check (i + off) + in + try check 0 with End_of_input -> true | Invalid_argument _ -> false + (* Check the well-formedness of an identifier *) let initial_refutation j n s = diff --git a/lib/unicode.mli b/lib/unicode.mli index 520203d435..65e75a20d6 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -26,3 +26,6 @@ val lowercase_first_char : string -> string (** For extraction, turn a unicode string into an ascii-only one *) val is_basic_ascii : string -> bool val ascii_of_ident : string -> string + +(** Validate an UTF-8 string *) +val is_utf8 : string -> bool -- cgit v1.2.3 From 7461aaedef508570fba6334e18fd10d5b32bda0e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Mar 2016 21:35:42 +0100 Subject: Adding a test for the behaviour of open_constr described in #3777. --- test-suite/typeclasses/open_constr.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 test-suite/typeclasses/open_constr.v diff --git a/test-suite/typeclasses/open_constr.v b/test-suite/typeclasses/open_constr.v new file mode 100644 index 0000000000..5f1785c706 --- /dev/null +++ b/test-suite/typeclasses/open_constr.v @@ -0,0 +1,12 @@ +Tactic Notation "opose" open_constr(foo) := pose foo. +Class Foo := Build_Foo : Set. +Axiom f : forall `{Foo}, Set. +Set Printing Implicit. +Goal forall `{Foo}, True. +Proof. + intro H. + pose f. + opose f. + Fail let x := (eval hnf in P) in has_evar x. + let x := (eval hnf in P0) in has_evar x. + -- cgit v1.2.3 From 78b5670a0a1cf7ba31acabe710b311bf13df8745 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Thu, 3 Mar 2016 20:34:35 -0500 Subject: Fix a typo in dev/doc/changes.txt CQQ -> COQ--- dev/doc/changes.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 2f62be9aff..f7621a4076 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -1,5 +1,5 @@ ========================================= -= CHANGES BETWEEN COQ V8.4 AND CQQ V8.5 = += CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = ========================================= ** Refactoring : more mli interfaces and simpler grammar.cma ** -- cgit v1.2.3 From 143bb68613bcb314e2feffd643f539fba9cd3912 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Mar 2016 23:52:15 +0100 Subject: Uniformizing the parsing of argument scopes in Ltac. --- parsing/g_constr.ml4 | 2 +- parsing/g_ltac.ml4 | 9 ++++----- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 0fe0ac42b1..6eeae925a3 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -215,7 +215,7 @@ GEXTEND Gram CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (!@loc, Explicit, None, c) - | "ltac:"; "("; tac = Tactic.tactic_expr; ")" -> + | IDENT "ltac"; ":"; "("; tac = Tactic.tactic_expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in CHole (!@loc, None, IntroAnonymous, Some arg) ] ] diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 0a11d3928a..45d2a09e73 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -111,8 +111,6 @@ GEXTEND Gram | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (g,n,l) | st = simple_tactic -> st - | IDENT "constr"; ":"; c = Constr.constr -> - TacArg(!@loc,ConstrMayEval(ConstrTerm c)) | a = tactic_top_or_arg -> TacArg(!@loc,a) | r = reference; la = LIST0 tactic_arg -> TacArg(!@loc,TacCall (!@loc,r,la)) ] @@ -140,9 +138,7 @@ GEXTEND Gram ; (* Tactic arguments *) tactic_arg: - [ [ "ltac:"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | "ltac:"; n = natural -> TacGeneric (genarg_of_int n) - | a = tactic_top_or_arg -> a + [ [ a = tactic_top_or_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) @@ -151,6 +147,9 @@ GEXTEND Gram (* Can be used as argument and at toplevel in tactic expressions. *) tactic_top_or_arg: [ [ IDENT "uconstr"; ":" ; c = uconstr -> UConstr c + | IDENT "constr"; ":"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) + | IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a + | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) | IDENT "ipattern"; ":"; ipat = simple_intropattern -> TacGeneric (genarg_of_ipattern ipat) | c = constr_eval -> ConstrMayEval c -- cgit v1.2.3 From d5656a6c28f79d59590d4fde60c5158a649d1b65 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 11:16:03 +0100 Subject: Making parentheses mandatory in tactic scopes. --- CHANGES | 2 + parsing/g_ltac.ml4 | 10 ++-- plugins/micromega/Psatz.v | 2 +- plugins/romega/ReflOmegaCore.v | 2 +- plugins/setoid_ring/ArithRing.v | 4 +- plugins/setoid_ring/InitialRing.v | 48 ++++++++-------- plugins/setoid_ring/NArithRing.v | 2 +- plugins/setoid_ring/Ring.v | 6 +- plugins/setoid_ring/ZArithRing.v | 8 +-- test-suite/bugs/closed/3699.v | 4 +- test-suite/bugs/closed/3881.v | 2 +- test-suite/complexity/ring2.v | 2 +- test-suite/success/MatchFail.v | 8 +-- test-suite/success/ltac.v | 14 ++--- theories/Classes/CMorphisms.v | 2 +- theories/Classes/Morphisms.v | 2 +- theories/Classes/SetoidTactics.v | 16 +++--- theories/Numbers/Cyclic/Int31/Ring31.v | 20 +++---- theories/Numbers/Integer/BigZ/BigZ.v | 22 ++++---- theories/Numbers/Natural/BigN/BigN.v | 24 ++++---- theories/Numbers/Rational/BigQ/BigQ.v | 14 ++--- theories/Program/Equality.v | 4 +- theories/Program/Tactics.v | 2 +- theories/Reals/Ranalysis_reg.v | 100 ++++++++++++++++----------------- theories/ZArith/Int.v | 14 ++--- theories/ZArith/Zsqrt_compat.v | 4 +- 26 files changed, 170 insertions(+), 168 deletions(-) diff --git a/CHANGES b/CHANGES index e80a3b4547..ae055cb2f8 100644 --- a/CHANGES +++ b/CHANGES @@ -13,6 +13,8 @@ Tactics - In introduction patterns of the form (pat1,...,patn), n should match the exact number of hypotheses introduced (except for local definitions for which pattern can be omitted, as in regular pattern-matching). +- Tactic scopes in Ltac like constr: and ltac: now require parentheses around + their argument. Program diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 45d2a09e73..b76f5dda25 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -146,11 +146,11 @@ GEXTEND Gram ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_top_or_arg: - [ [ IDENT "uconstr"; ":" ; c = uconstr -> UConstr c - | IDENT "constr"; ":"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) - | IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> + [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> UConstr c + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) + | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a + | IDENT "ltac"; ":"; "("; n = natural; ")" -> TacGeneric (genarg_of_int n) + | IDENT "ipattern"; ":"; "("; ipat = simple_intropattern; ")" -> TacGeneric (genarg_of_ipattern ipat) | c = constr_eval -> ConstrMayEval c | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index 50e0033e59..ba1f8956e3 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -69,7 +69,7 @@ Ltac xpsatz dom d := end in tac. Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1. +Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). Ltac psatzl dom := let tac := lazymatch dom with diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index b84cf25405..36511386ac 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1492,7 +1492,7 @@ with Simplify := match goal with end. Ltac prove_stable x th := - match constr:x with + match constr:(x) with | ?X1 => unfold term_stable, X1; intros; Simplify; simpl; apply th diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v index 04decbce19..5f5b97925f 100644 --- a/plugins/setoid_ring/ArithRing.v +++ b/plugins/setoid_ring/ArithRing.v @@ -32,13 +32,13 @@ Qed. Ltac natcst t := match isnatcst t with true => constr:(N.of_nat t) - | _ => constr:InitialRing.NotConstant + | _ => constr:(InitialRing.NotConstant) end. Ltac Ss_to_add f acc := match f with | S ?f1 => Ss_to_add f1 (S acc) - | _ => constr:(acc + f)%nat + | _ => constr:((acc + f)%nat) end. Ltac natprering := diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 8362c8c261..8fcc077164 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -612,32 +612,32 @@ End GEN_DIV. Ltac inv_gen_phi_pos rI add mul t := let rec inv_cst t := match t with - rI => constr:1%positive - | (add rI rI) => constr:2%positive - | (add rI (add rI rI)) => constr:3%positive + rI => constr:(1%positive) + | (add rI rI) => constr:(2%positive) + | (add rI (add rI rI)) => constr:(3%positive) | (mul (add rI rI) ?p) => (* 2p *) match inv_cst p with - NotConstant => constr:NotConstant - | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *) + NotConstant => constr:(NotConstant) + | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *) | ?p => constr:(xO p) end | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) match inv_cst p with - NotConstant => constr:NotConstant - | 1%positive => constr:NotConstant + NotConstant => constr:(NotConstant) + | 1%positive => constr:(NotConstant) | ?p => constr:(xI p) end - | _ => constr:NotConstant + | _ => constr:(NotConstant) end in inv_cst t. (* The (partial) inverse of gen_phiNword *) Ltac inv_gen_phiNword rO rI add mul opp t := match t with - rO => constr:NwO + rO => constr:(NwO) | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Npos p::nil) end end. @@ -646,10 +646,10 @@ End GEN_DIV. (* The inverse of gen_phiN *) Ltac inv_gen_phiN rO rI add mul t := match t with - rO => constr:0%N + rO => constr:(0%N) | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Npos p) end end. @@ -657,15 +657,15 @@ End GEN_DIV. (* The inverse of gen_phiZ *) Ltac inv_gen_phiZ rO rI add mul opp t := match t with - rO => constr:0%Z + rO => constr:(0%Z) | (opp ?p) => match inv_gen_phi_pos rI add mul p with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Zneg p) end | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Zpos p) end end. @@ -681,7 +681,7 @@ Ltac inv_gen_phi rO rI cO cI t := end. (* A simple tactic recognizing no constant *) - Ltac inv_morph_nothing t := constr:NotConstant. + Ltac inv_morph_nothing t := constr:(NotConstant). Ltac coerce_to_almost_ring set ext rspec := match type of rspec with @@ -825,31 +825,31 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk := (* Tactic for constant *) Ltac isnatcst t := match t with - O => constr:true + O => constr:(true) | S ?p => isnatcst p - | _ => constr:false + | _ => constr:(false) end. Ltac isPcst t := match t with | xI ?p => isPcst p | xO ?p => isPcst p - | xH => constr:true + | xH => constr:(true) (* nat -> positive *) | Pos.of_succ_nat ?n => isnatcst n - | _ => constr:false + | _ => constr:(false) end. Ltac isNcst t := match t with - N0 => constr:true + N0 => constr:(true) | Npos ?p => isPcst p - | _ => constr:false + | _ => constr:(false) end. Ltac isZcst t := match t with - Z0 => constr:true + Z0 => constr:(true) | Zpos ?p => isPcst p | Zneg ?p => isPcst p (* injection nat -> Z *) @@ -857,7 +857,7 @@ Ltac isZcst t := (* injection N -> Z *) | Z.of_N ?n => isNcst n (* *) - | _ => constr:false + | _ => constr:(false) end. diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v index 6c1a79e4ed..54e2789ba4 100644 --- a/plugins/setoid_ring/NArithRing.v +++ b/plugins/setoid_ring/NArithRing.v @@ -15,7 +15,7 @@ Set Implicit Arguments. Ltac Ncst t := match isNcst t with true => t - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]). diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v index a0844100c2..77576cb933 100644 --- a/plugins/setoid_ring/Ring.v +++ b/plugins/setoid_ring/Ring.v @@ -36,9 +36,9 @@ Qed. Ltac bool_cst t := let t := eval hnf in t in match t with - true => constr:true - | false => constr:false - | _ => constr:NotConstant + true => constr:(true) + | false => constr:(false) + | _ => constr:(NotConstant) end. Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v index 9148437278..23784cf33f 100644 --- a/plugins/setoid_ring/ZArithRing.v +++ b/plugins/setoid_ring/ZArithRing.v @@ -17,14 +17,14 @@ Set Implicit Arguments. Ltac Zcst t := match isZcst t with true => t - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Ltac isZpow_coef t := match t with | Zpos ?p => isPcst p - | Z0 => constr:true - | _ => constr:false + | Z0 => constr:(true) + | _ => constr:(false) end. Notation N_of_Z := Z.to_N (only parsing). @@ -32,7 +32,7 @@ Notation N_of_Z := Z.to_N (only parsing). Ltac Zpow_tac t := match isZpow_coef t with | true => constr:(N_of_Z t) - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Ltac Zpower_neg := diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index aad0bb44d5..8dadc2419c 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -65,7 +65,7 @@ Module NonPrim. set (fibermap := fun a0p : hfiber f (f a) => let (a0, p) := a0p in transport P p (d a0)). Set Printing Implicit. - let G := match goal with |- ?G => constr:G end in + let G := match goal with |- ?G => constr:(G) end in first [ match goal with | [ |- (@isconnected_elim n (@hfiber A B f (f a)) (@isconnected_hfiber_conn_map n A B f H (f a)) @@ -142,7 +142,7 @@ Module Prim. set (fibermap := fun a0p : hfiber f (f a) => let (a0, p) := a0p in transport P p (d a0)). Set Printing Implicit. - let G := match goal with |- ?G => constr:G end in + let G := match goal with |- ?G => constr:(G) end in first [ match goal with | [ |- (@isconnected_elim n (@hfiber A B f (f a)) (@isconnected_hfiber_conn_map n A B f H (f a)) diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index 070d1e9c71..a327bbf2a9 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -23,7 +23,7 @@ Proof. pose (fun H => @isequiv_homotopic _ _ ((g o f) o f^-1) _ H (fun b => ap g (eisretr f b))) as k. revert k. - let x := match goal with |- let k := ?x in _ => constr:x end in + let x := match goal with |- let k := ?x in _ => constr:(x) end in intro k; clear k; pose (x _). pose (@isequiv_homotopic _ _ ((g o f) o f^-1) g _ diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v index 52dae265bd..04fa59075b 100644 --- a/test-suite/complexity/ring2.v +++ b/test-suite/complexity/ring2.v @@ -39,7 +39,7 @@ Admitted. Ltac Zcst t := match isZcst t with true => t - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Add Ring Zr : Zth diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v index 7069bba430..8462d36272 100644 --- a/test-suite/success/MatchFail.v +++ b/test-suite/success/MatchFail.v @@ -9,14 +9,14 @@ Require Export ZArithRing. Ltac compute_POS := match goal with | |- context [(Zpos (xI ?X1))] => - let v := constr:X1 in - match constr:v with + let v := constr:(X1) in + match constr:(v) with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xI v) end | |- context [(Zpos (xO ?X1))] => - let v := constr:X1 in - match constr:v with + let v := constr:(X1) in + match constr:(v) with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xO v) end diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 6c4d4ae98f..ce90990594 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -15,7 +15,7 @@ Ltac F x := idtac; G x with G y := idtac; F y. (* Check that Match Context keeps a closure *) -Ltac U := let a := constr:I in +Ltac U := let a := constr:(I) in match goal with | |- _ => apply a end. @@ -75,7 +75,7 @@ Qed. (* Check context binding *) Ltac sym t := - match constr:t with + match constr:(t) with | context C[(?X1 = ?X2)] => context C [X1 = X2] end. @@ -143,7 +143,7 @@ Qed. Ltac check_binding y := cut ((fun y => y) = S). Goal True. -check_binding ipattern:H. +check_binding ipattern:(H). Abort. (* Check that variables explicitly parsed as ltac variables are not @@ -151,7 +151,7 @@ Abort. Ltac afi tac := intros; tac. Goal 1 = 2. -afi ltac:auto. +afi ltac:(auto). Abort. (* Tactic Notation avec listes *) @@ -174,7 +174,7 @@ Abort. empty args *) Goal True. -match constr:@None with @None => exact I end. +match constr:(@None) with @None => exact I end. Abort. (* Check second-order pattern unification *) @@ -218,7 +218,7 @@ Ltac Z1 t := set (x:=t). Ltac Z2 t := t. Goal True -> True. Z1 O. -Z2 ltac:O. +Z2 ltac:(O). exact I. Qed. @@ -302,7 +302,7 @@ Abort. (* Check instantiation of binders using ltac names *) Goal True. -let x := ipattern:y in assert (forall x y, x = y + 0). +let x := ipattern:(y) in assert (forall x y, x = y + 0). intro. destruct y. (* Check that the name is y here *) Abort. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index c41eb2fa29..627a1a4957 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -452,7 +452,7 @@ Ltac partial_application_tactic := let rec do_partial_apps H m cont := match m with | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; - [(do_partial_apps H m' ltac:idtac)|clear H] + [(do_partial_apps H m' ltac:(idtac))|clear H] | _ => cont end in diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 8d942d9087..81b31d783f 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -465,7 +465,7 @@ Ltac partial_application_tactic := let rec do_partial_apps H m cont := match m with | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; - [(do_partial_apps H m' ltac:idtac)|clear H] + [(do_partial_apps H m' ltac:(idtac))|clear H] | _ => cont end in diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index 145d451f0f..190397ae49 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -77,23 +77,23 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y) Tactic Notation "setoid_replace" constr(x) "with" constr(y) "by" tactic3(t) := - setoidreplace (default_relation x y) ltac:t. + setoidreplace (default_relation x y) ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceat (default_relation x y) ltac:t o. + setoidreplaceat (default_relation x y) ltac:(t) o. Tactic Notation "setoid_replace" constr(x) "with" constr(y) "in" hyp(id) "by" tactic3(t) := - setoidreplacein (default_relation x y) id ltac:t. + setoidreplacein (default_relation x y) id ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "in" hyp(id) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceinat (default_relation x y) id ltac:t o. + setoidreplaceinat (default_relation x y) id ltac:(t) o. Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) := @@ -107,13 +107,13 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y) Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "by" tactic3(t) := - setoidreplace (rel x y) ltac:t. + setoidreplace (rel x y) ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceat (rel x y) ltac:t o. + setoidreplaceat (rel x y) ltac:(t) o. Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) @@ -130,14 +130,14 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "in" hyp(id) "by" tactic3(t) := - setoidreplacein (rel x y) id ltac:t. + setoidreplacein (rel x y) id ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "in" hyp(id) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceinat (rel x y) id ltac:t o. + setoidreplaceinat (rel x y) id ltac:(t) o. (** The [add_morphism_tactic] tactic is run at each [Add Morphism] command before giving the hand back to the user to discharge the diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v index 215b8bd581..d160f5f1de 100644 --- a/theories/Numbers/Cyclic/Int31/Ring31.v +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -19,13 +19,13 @@ Local Open Scope list_scope. Ltac isInt31cst_lst l := match l with - | nil => constr:true + | nil => constr:(true) | ?t::?l => match t with | D1 => isInt31cst_lst l | D0 => isInt31cst_lst l - | _ => constr:false + | _ => constr:(false) end - | _ => constr:false + | _ => constr:(false) end. Ltac isInt31cst t := @@ -38,17 +38,17 @@ Ltac isInt31cst t := ::i11::i12::i13::i14::i15::i16::i17::i18::i19::i20 ::i21::i22::i23::i24::i25::i26::i27::i28::i29::i30::nil) in isInt31cst_lst l - | Int31.On => constr:true - | Int31.In => constr:true - | Int31.Tn => constr:true - | Int31.Twon => constr:true - | _ => constr:false + | Int31.On => constr:(true) + | Int31.In => constr:(true) + | Int31.Tn => constr:(true) + | Int31.Twon => constr:(true) + | _ => constr:(false) end. Ltac Int31cst t := match isInt31cst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. (** The generic ring structure inferred from the Cyclic structure *) diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v index ec495d0947..56cb9bbc2c 100644 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -148,26 +148,26 @@ Ltac isBigZcst t := match t with | BigZ.Pos ?t => isBigNcst t | BigZ.Neg ?t => isBigNcst t - | BigZ.zero => constr:true - | BigZ.one => constr:true - | BigZ.two => constr:true - | BigZ.minus_one => constr:true - | _ => constr:false + | BigZ.zero => constr:(true) + | BigZ.one => constr:(true) + | BigZ.two => constr:(true) + | BigZ.minus_one => constr:(true) + | _ => constr:(false) end. Ltac BigZcst t := match isBigZcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. Ltac BigZ_to_N t := match t with | BigZ.Pos ?t => BigN_to_N t - | BigZ.zero => constr:0%N - | BigZ.one => constr:1%N - | BigZ.two => constr:2%N - | _ => constr:NotConstant + | BigZ.zero => constr:(0%N) + | BigZ.one => constr:(1%N) + | BigZ.two => constr:(2%N) + | _ => constr:(NotConstant) end. (** Registration for the "ring" tactic *) diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v index 29a1145e0c..ec1017f505 100644 --- a/theories/Numbers/Natural/BigN/BigN.v +++ b/theories/Numbers/Natural/BigN/BigN.v @@ -119,10 +119,10 @@ Qed. Ltac isStaticWordCst t := match t with - | W0 => constr:true + | W0 => constr:(true) | WW ?t1 ?t2 => match isStaticWordCst t1 with - | false => constr:false + | false => constr:(false) | true => isStaticWordCst t2 end | _ => isInt31cst t @@ -139,30 +139,30 @@ Ltac isBigNcst t := | BigN.N6 ?t => isStaticWordCst t | BigN.Nn ?n ?t => match isnatcst n with | true => isStaticWordCst t - | false => constr:false + | false => constr:(false) end - | BigN.zero => constr:true - | BigN.one => constr:true - | BigN.two => constr:true - | _ => constr:false + | BigN.zero => constr:(true) + | BigN.one => constr:(true) + | BigN.two => constr:(true) + | _ => constr:(false) end. Ltac BigNcst t := match isBigNcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. Ltac BigN_to_N t := match isBigNcst t with | true => eval vm_compute in (BigN.to_N t) - | false => constr:NotConstant + | false => constr:(NotConstant) end. Ltac Ncst t := match isNcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. (** Registration for the "ring" tactic *) diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v index fe38ea4f2d..850afe5345 100644 --- a/theories/Numbers/Rational/BigQ/BigQ.v +++ b/theories/Numbers/Rational/BigQ/BigQ.v @@ -104,18 +104,18 @@ Ltac isBigQcst t := | BigQ.Qz ?t => isBigZcst t | BigQ.Qq ?n ?d => match isBigZcst n with | true => isBigNcst d - | false => constr:false + | false => constr:(false) end - | BigQ.zero => constr:true - | BigQ.one => constr:true - | BigQ.minus_one => constr:true - | _ => constr:false + | BigQ.zero => constr:(true) + | BigQ.one => constr:(true) + | BigQ.minus_one => constr:(true) + | _ => constr:(false) end. Ltac BigQcst t := match isBigQcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. Add Field BigQfield : BigQfieldth diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 27e1ca8444..17f05c5113 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -238,8 +238,8 @@ Ltac inject_left H := Ltac inject_right H := progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H. -Ltac autoinjections_left := repeat autoinjection ltac:inject_left. -Ltac autoinjections_right := repeat autoinjection ltac:inject_right. +Ltac autoinjections_left := repeat autoinjection ltac:(inject_left). +Ltac autoinjections_right := repeat autoinjection ltac:(inject_right). Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 66ca3e577d..7384790dae 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -252,7 +252,7 @@ Ltac autoinjection tac := Ltac inject H := progress (inversion H ; subst*; clear_dups) ; clear H. -Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:inject). +Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:(inject)). (** Destruct an hypothesis by first copying it to avoid dependencies. *) diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v index 2465f03992..e57af7311f 100644 --- a/theories/Reals/Ranalysis_reg.v +++ b/theories/Reals/Ranalysis_reg.v @@ -35,7 +35,7 @@ Qed. (**********) Ltac intro_hyp_glob trm := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => match goal with | |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 @@ -55,7 +55,7 @@ Ltac intro_hyp_glob trm := | _ => idtac end | (?X1 / ?X2)%F => - let aux := constr:X2 in + let aux := constr:(X2) in match goal with | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 @@ -82,7 +82,7 @@ Ltac intro_hyp_glob trm := | _ => idtac end | (/ ?X1)%F => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => intro_hyp_glob X1 @@ -108,7 +108,7 @@ Ltac intro_hyp_glob trm := | (pow_fct _) => idtac | Rabs => idtac | ?X1 => - let p := constr:X1 in + let p := constr:(X1) in match goal with | _:(derivable p) |- _ => idtac | |- (derivable p) => idtac @@ -130,7 +130,7 @@ Ltac intro_hyp_glob trm := (**********) Ltac intro_hyp_pt trm pt := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => match goal with | |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt @@ -156,7 +156,7 @@ Ltac intro_hyp_pt trm pt := | _ => idtac end | (?X1 / ?X2)%F => - let aux := constr:X2 in + let aux := constr:(X2) in match goal with | _:(aux pt <> 0) |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt @@ -202,7 +202,7 @@ Ltac intro_hyp_pt trm pt := | _ => idtac end | (/ ?X1)%F => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with | _:(aux pt <> 0) |- (derivable_pt _ _) => intro_hyp_pt X1 pt @@ -249,7 +249,7 @@ Ltac intro_hyp_pt trm pt := | _ => idtac end | ?X1 => - let p := constr:X1 in + let p := constr:(X1) in match goal with | _:(derivable_pt p pt) |- _ => idtac | |- (derivable_pt p pt) => idtac @@ -578,89 +578,89 @@ Ltac is_cont_glob := (**********) Ltac rew_term trm := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 + X4)) - | _ => constr:(p1 + p2)%F + | _ => constr:((p1 + p2)%F) end - | _ => constr:(p1 + p2)%F + | _ => constr:((p1 + p2)%F) end | (?X1 - ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 - X4)) - | _ => constr:(p1 - p2)%F + | _ => constr:((p1 - p2)%F) end - | _ => constr:(p1 - p2)%F + | _ => constr:((p1 - p2)%F) end | (?X1 / ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 / X4)) - | _ => constr:(p1 / p2)%F + | _ => constr:((p1 / p2)%F) end | _ => - match constr:p2 with - | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F - | _ => constr:(p1 / p2)%F + match constr:(p2) with + | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F) + | _ => constr:((p1 / p2)%F) end end | (?X1 * / ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 / X4)) - | _ => constr:(p1 / p2)%F + | _ => constr:((p1 / p2)%F) end | _ => - match constr:p2 with - | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F - | _ => constr:(p1 / p2)%F + match constr:(p2) with + | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F) + | _ => constr:((p1 / p2)%F) end end | (?X1 * ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 * X4)) - | _ => constr:(p1 * p2)%F + | _ => constr:((p1 * p2)%F) end - | _ => constr:(p1 * p2)%F + | _ => constr:((p1 * p2)%F) end | (- ?X1) => let p := rew_term X1 in - match constr:p with + match constr:(p) with | (fct_cte ?X2) => constr:(fct_cte (- X2)) - | _ => constr:(- p)%F + | _ => constr:((- p)%F) end | (/ ?X1) => let p := rew_term X1 in - match constr:p with + match constr:(p) with | (fct_cte ?X2) => constr:(fct_cte (/ X2)) - | _ => constr:(/ p)%F + | _ => constr:((/ p)%F) end - | (?X1 AppVar) => constr:X1 + | (?X1 AppVar) => constr:(X1) | (?X1 ?X2) => let p := rew_term X2 in - match constr:p with + match constr:(p) with | (fct_cte ?X3) => constr:(fct_cte (X1 X3)) | _ => constr:(comp X1 p) end - | AppVar => constr:id + | AppVar => constr:(id) | (AppVar ^ ?X1) => constr:(pow_fct X1) | (?X1 ^ ?X2) => let p := rew_term X1 in - match constr:p with + match constr:(p) with | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3)) | _ => constr:(comp (pow_fct X2) p) end @@ -669,7 +669,7 @@ Ltac rew_term trm := (**********) Ltac deriv_proof trm pt := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in constr:(derivable_pt_plus X1 X2 pt p1 p2) @@ -684,14 +684,14 @@ Ltac deriv_proof trm pt := | id:(?X2 pt <> 0) |- _ => let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in constr:(derivable_pt_div X1 X2 pt p1 p2 id) - | _ => constr:False + | _ => constr:(False) end | (/ ?X1)%F => match goal with | id:(?X1 pt <> 0) |- _ => let p1 := deriv_proof X1 pt in constr:(derivable_pt_inv X1 pt p1 id) - | _ => constr:False + | _ => constr:(False) end | (comp ?X1 ?X2) => let pt_f1 := eval cbv beta in (X2 pt) in @@ -710,21 +710,21 @@ Ltac deriv_proof trm pt := | sqrt => match goal with | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id) - | _ => constr:False + | _ => constr:(False) end | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt) | ?X1 => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with - | id:(derivable_pt aux pt) |- _ => constr:id + | id:(derivable_pt aux pt) |- _ => constr:(id) | id:(derivable aux) |- _ => constr:(id pt) - | _ => constr:False + | _ => constr:(False) end end. (**********) Ltac simplify_derive trm pt := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => try rewrite derive_pt_plus; simplify_derive X1 pt; simplify_derive X2 pt @@ -753,7 +753,7 @@ Ltac simplify_derive trm pt := | Rsqr => try rewrite derive_pt_Rsqr | sqrt => try rewrite derive_pt_sqrt | ?X1 => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ => try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2); diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index d210792f9a..32e13d3892 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -225,11 +225,11 @@ Module MoreInt (Import I:Int). (** [int] to [ExprI] *) Ltac i2ei trm := - match constr:trm with - | 0 => constr:EI0 - | 1 => constr:EI1 - | 2 => constr:EI2 - | 3 => constr:EI3 + match constr:(trm) with + | 0 => constr:(EI0) + | 1 => constr:(EI1) + | 2 => constr:(EI2) + | 3 => constr:(EI3) | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIadd ex ey) | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIsub ex ey) | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImul ex ey) @@ -241,7 +241,7 @@ Module MoreInt (Import I:Int). (** [Z] to [ExprZ] *) with z2ez trm := - match constr:trm with + match constr:(trm) with | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZadd ex ey) | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZsub ex ey) | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmul ex ey) @@ -254,7 +254,7 @@ Module MoreInt (Import I:Int). (** [Prop] to [ExprP] *) Ltac p2ep trm := - match constr:trm with + match constr:(trm) with | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey) | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey) | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey) diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v index b80eb4451e..f4baba1902 100644 --- a/theories/ZArith/Zsqrt_compat.v +++ b/theories/ZArith/Zsqrt_compat.v @@ -30,12 +30,12 @@ Local Open Scope Z_scope. Ltac compute_POS := match goal with | |- context [(Zpos (xI ?X1))] => - match constr:X1 with + match constr:(X1) with | context [1%positive] => fail 1 | _ => rewrite (Pos2Z.inj_xI X1) end | |- context [(Zpos (xO ?X1))] => - match constr:X1 with + match constr:(X1) with | context [1%positive] => fail 1 | _ => rewrite (Pos2Z.inj_xO X1) end -- cgit v1.2.3 From 098d283e58966124cfe0e97a3229a9e7e6284120 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 15:04:35 +0100 Subject: Removing the UConstr entry of the tactic_arg AST. This was redundant with the wit_uconstr generic argument, so there was no real point on keeping it there. --- intf/tacexpr.mli | 11 ----------- parsing/g_ltac.ml4 | 3 ++- printing/pptactic.ml | 7 ------- tactics/tacintern.ml | 3 +-- tactics/tacinterp.ml | 5 ----- tactics/tacsubst.ml | 1 - 6 files changed, 3 insertions(+), 27 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 7366bc03e6..f2a567c00d 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -180,7 +180,6 @@ type 'a gen_atomic_tactic_expr = constraint 'a = < term:'trm; - utrm: 'utrm; dterm: 'dtrm; pattern:'pat; constant:'cst; @@ -195,7 +194,6 @@ constraint 'a = < and 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval - | UConstr of 'utrm | Reference of 'ref | TacCall of Loc.t * 'ref * 'a gen_tactic_arg list @@ -206,7 +204,6 @@ and 'a gen_tactic_arg = constraint 'a = < term:'trm; - utrm: 'utrm; dterm: 'dtrm; pattern:'pat; constant:'cst; @@ -285,7 +282,6 @@ and 'a gen_tactic_expr = constraint 'a = < term:'t; - utrm: 'utrm; dterm: 'dtrm; pattern:'p; constant:'c; @@ -300,7 +296,6 @@ and 'a gen_tactic_fun_ast = constraint 'a = < term:'t; - utrm: 'utrm; dterm: 'dtrm; pattern:'p; constant:'c; @@ -313,7 +308,6 @@ constraint 'a = < (** Globalized tactics *) type g_trm = glob_constr_and_expr -type g_utrm = g_trm type g_pat = glob_constr_pattern_and_expr type g_cst = evaluable_global_reference and_short_name or_var type g_ref = ltac_constant located or_var @@ -321,7 +315,6 @@ type g_nam = Id.t located type g_dispatch = < term:g_trm; - utrm:g_utrm; dterm:g_trm; pattern:g_pat; constant:g_cst; @@ -343,7 +336,6 @@ type glob_tactic_arg = (** Raw tactics *) type r_trm = constr_expr -type r_utrm = r_trm type r_pat = constr_pattern_expr type r_cst = reference or_by_notation type r_ref = reference @@ -352,7 +344,6 @@ type r_lev = rlevel type r_dispatch = < term:r_trm; - utrm:r_utrm; dterm:r_trm; pattern:r_pat; constant:r_cst; @@ -374,7 +365,6 @@ type raw_tactic_arg = (** Interpreted tactics *) type t_trm = Term.constr -type t_utrm = Glob_term.closed_glob_constr type t_pat = constr_pattern type t_cst = evaluable_global_reference type t_ref = ltac_constant located @@ -382,7 +372,6 @@ type t_nam = Id.t type t_dispatch = < term:t_trm; - utrm:t_utrm; dterm:g_trm; pattern:t_pat; constant:t_cst; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index b76f5dda25..4da32c9b26 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -28,6 +28,7 @@ let arg_of_expr = function let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c let reference_to_id = function | Libnames.Ident (loc, id) -> (loc, id) @@ -146,7 +147,7 @@ GEXTEND Gram ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_top_or_arg: - [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> UConstr c + [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> TacGeneric (genarg_of_uconstr c) | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a | IDENT "ltac"; ":"; "("; n = natural; ")" -> TacGeneric (genarg_of_int n) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 36863906ea..fdc1288aec 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -696,7 +696,6 @@ module Make type 'a printer = { pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; pr_constr : 'trm -> std_ppcmds; - pr_uconstr : 'utrm -> std_ppcmds; pr_lconstr : 'trm -> std_ppcmds; pr_dconstr : 'dtrm -> std_ppcmds; pr_pattern : 'pat -> std_ppcmds; @@ -711,7 +710,6 @@ module Make constraint 'a = < term :'trm; - utrm :'utrm; dterm :'dtrm; pattern :'pat; constant :'cst; @@ -1153,8 +1151,6 @@ module Make pr.pr_reference r | ConstrMayEval c -> pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c - | UConstr c -> - keyword "uconstr:" ++ pr.pr_uconstr c | TacFreshId l -> keyword "fresh" ++ pr_fresh_ids l | TacPretype c -> @@ -1182,7 +1178,6 @@ module Make let pr = { pr_tactic = pr_raw_tactic_level; pr_constr = pr_constr_expr; - pr_uconstr = pr_constr_expr; pr_dconstr = pr_constr_expr; pr_lconstr = pr_lconstr_expr; pr_pattern = pr_constr_pattern_expr; @@ -1213,7 +1208,6 @@ module Make let pr = { pr_tactic = prtac; pr_constr = pr_and_constr_expr (pr_glob_constr_env env); - pr_uconstr = pr_and_constr_expr (pr_glob_constr_env env); pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); @@ -1255,7 +1249,6 @@ module Make let pr = { pr_tactic = pr_glob_tactic_level env; pr_constr = pr_constr_env env Evd.empty; - pr_uconstr = pr_closed_glob_env env Evd.empty; pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); pr_lconstr = pr_lconstr_env env Evd.empty; pr_pattern = pr_constr_pattern_env env Evd.empty; diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index a069fd7557..89dc843cb8 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -651,7 +651,7 @@ and intern_tactic_as_arg loc onlytac ist a = | TacCall _ | Reference _ | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a - | ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> + | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> if onlytac then error_tactic_expected loc else TacArg (loc,a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -665,7 +665,6 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | UConstr c -> UConstr (intern_constr ist c) | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f | TacCall (loc,f,l) -> TacCall (loc, diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 1a8a95158a..bf5f9ddc86 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1365,11 +1365,6 @@ and interp_tacarg ist arg : Val.t Ftactic.t = let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) end } - | UConstr c -> - Ftactic.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - Ftactic.return (Value.of_uconstr (interp_uconstr ist env c)) - end } | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist r | TacCall (loc,f,l) -> diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 3f103a290d..55941c1ca6 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -247,7 +247,6 @@ and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | UConstr c -> UConstr (subst_glob_constr subst c) | TacCall (_loc,f,l) -> TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) | TacFreshId _ as x -> x -- cgit v1.2.3 From 5b4fd2f5a3c6d031d551f9b5730fe30a69337c76 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 15:47:27 +0100 Subject: Exchanging roles of tactic_arg and tactic_top_or_arg entries. The tactic_arg entry was essentially a hack to keep parsing constrs as tactic arguments. We rather use tactic_top_or_arg as the true entry for tactic arguments now. --- parsing/g_ltac.ml4 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 4da32c9b26..06675baa7d 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -112,8 +112,8 @@ GEXTEND Gram | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (g,n,l) | st = simple_tactic -> st - | a = tactic_top_or_arg -> TacArg(!@loc,a) - | r = reference; la = LIST0 tactic_arg -> + | a = tactic_arg -> TacArg(!@loc,a) + | r = reference; la = LIST0 tactic_arg_compat -> TacArg(!@loc,TacCall (!@loc,r,la)) ] | "0" [ "("; a = tactic_expr; ")" -> a @@ -137,16 +137,16 @@ GEXTEND Gram body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] ; - (* Tactic arguments *) - tactic_arg: - [ [ a = tactic_top_or_arg -> a + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_top_or_arg: + tactic_arg: [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> TacGeneric (genarg_of_uconstr c) | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a -- cgit v1.2.3 From 8e77752080b6f0da3ce396e7537db9676e848a70 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 15:55:02 +0100 Subject: Replacing ad-hoc tactic scopes by generic ones using [create_ltac_quotations]. --- parsing/egramcoq.ml | 21 ++++++++++++--------- parsing/egramcoq.mli | 10 +++++----- parsing/g_ltac.ml4 | 8 +------- tactics/coretactics.ml4 | 2 ++ tactics/extraargs.ml4 | 14 ++++++++++++++ 5 files changed, 34 insertions(+), 21 deletions(-) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 465073b7aa..2cf590b1d8 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -379,24 +379,27 @@ let with_grammar_rule_protection f x = let ltac_quotations = ref String.Set.empty -let create_ltac_quotation name cast wit e = +let create_ltac_quotation name cast (e, l) = let () = if String.Set.mem name !ltac_quotations then failwith ("Ltac quotation " ^ name ^ " already registered") in let () = ltac_quotations := String.Set.add name !ltac_quotations in + let entry = match l with + | None -> Aentry (name_of_entry e) + | Some l -> Aentryl (name_of_entry e, l) + in (* let level = Some "1" in *) let level = None in - let assoc = Some Extend.RightA in + let assoc = None in let rule = - Next (Next (Next (Stop, + Next (Next (Next (Next (Next (Stop, Atoken (Lexer.terminal name)), Atoken (Lexer.terminal ":")), - Aentry (name_of_entry e)) - in - let action v _ _ loc = - let arg = TacGeneric (Genarg.in_gen (Genarg.rawwit wit) (cast (loc, v))) in - TacArg (loc, arg) + Atoken (Lexer.terminal "(")), + entry), + Atoken (Lexer.terminal ")")) in + let action _ v _ _ _ loc = cast (loc, v) in let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Tactic.tactic_expr None (None, [gram]) + Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 17524971f2..23eaa64eec 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -62,8 +62,8 @@ val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b (** {5 Adding tactic quotations} *) -val create_ltac_quotation : string -> ('grm Loc.located -> 'raw) -> - ('raw, 'glb, 'top) genarg_type -> 'grm Gram.entry -> unit -(** [create_ltac_quotation name f wit e] adds a quotation rule to Ltac, that is, - Ltac grammar now accepts arguments of the form ["name" ":" ], and - generates a generic argument using [f] on the entry parsed by [e]. *) +val create_ltac_quotation : string -> + ('grm Loc.located -> Tacexpr.raw_tactic_arg) -> ('grm Gram.entry * int option) -> unit +(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, + Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and + generates an argument using [f] on the entry parsed by [e]. *) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 06675baa7d..e4ca936a69 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -147,13 +147,7 @@ GEXTEND Gram ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_arg: - [ [ IDENT "uconstr"; ":"; "("; c = Constr.lconstr; ")" -> TacGeneric (genarg_of_uconstr c) - | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> ConstrMayEval (ConstrTerm c) - | IDENT "ltac"; ":"; "("; a = tactic_expr LEVEL "5"; ")" -> arg_of_expr a - | IDENT "ltac"; ":"; "("; n = natural; ")" -> TacGeneric (genarg_of_int n) - | IDENT "ipattern"; ":"; "("; ipat = simple_intropattern; ")" -> - TacGeneric (genarg_of_ipattern ipat) - | c = constr_eval -> ConstrMayEval c + [ [ c = constr_eval -> ConstrMayEval c | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l | IDENT "type_term"; c=uconstr -> TacPretype c | IDENT "numgoals" -> TacNumgoals ] ] diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 74d98176a4..7da6df717e 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -19,6 +19,8 @@ open Sigma.Notations DECLARE PLUGIN "coretactics" +(** Basic tactics *) + TACTIC EXTEND reflexivity [ "reflexivity" ] -> [ Tactics.intros_reflexivity ] END diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 8f336cdb30..9946aea82a 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -17,6 +17,20 @@ open Tacinterp open Misctypes open Locus +(** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) + +let create_generic_quotation name e wit = + let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in + Egramcoq.create_ltac_quotation name inject (e, None) + +let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Constrarg.wit_uconstr +let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Constrarg.wit_constr +let () = create_generic_quotation "ipattern" Pcoq.Tactic.simple_intropattern Constrarg.wit_intro_pattern +let () = create_generic_quotation "int" Pcoq.Prim.integer Stdarg.wit_int +let () = + let inject (loc, v) = Tacexpr.Tacexp v in + Egramcoq.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5) + (* Rewriting orientation *) let _ = Metasyntax.add_token_obj "<-" -- cgit v1.2.3 From cbc3a5f16871adb399689f7673a2a29a82dbf0cb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 16:30:40 +0100 Subject: All arguments defined through ARGUMENT EXTEND declare a tactic scope. Amongs other things, it kind of fixes bug #4492, even though you cannot really take advantage of the parsed data for now. --- CHANGES | 3 +++ grammar/argextend.ml4 | 7 +++++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/CHANGES b/CHANGES index ae055cb2f8..7de1015275 100644 --- a/CHANGES +++ b/CHANGES @@ -15,6 +15,9 @@ Tactics for which pattern can be omitted, as in regular pattern-matching). - Tactic scopes in Ltac like constr: and ltac: now require parentheses around their argument. +- Every generic argument type declares a tactic scope of the form "name:(...)" + where name is the name of the argument. This generalizes the constr: and ltac: + instances. Program diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 13f7611131..65dc237bb7 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -231,8 +231,11 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = <:str_item< do { Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule - $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$ } - >> ] + $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$; + Egramcoq.create_ltac_quotation $se$ + (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit $wit$) v)) + ($lid:s$, None) + } >> ] let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in -- cgit v1.2.3 From b98e4857a13a4014c65882af5321ebdb09f41890 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 4 Mar 2016 17:40:10 +0100 Subject: Rename Ephemeron -> CEphemeron. Fixes compilation of Coq with OCaml 4.03 beta 1. --- checker/check.mllib | 2 +- dev/printers.mllib | 2 +- kernel/csymtable.ml | 6 +- kernel/entries.mli | 2 +- kernel/pre_env.ml | 8 +-- kernel/pre_env.mli | 2 +- kernel/safe_typing.ml | 4 +- kernel/term_typing.ml | 4 +- lib/cEphemeron.ml | 89 +++++++++++++++++++++++++++ lib/cEphemeron.mli | 52 ++++++++++++++++ lib/ephemeron.ml | 89 --------------------------- lib/ephemeron.mli | 52 ---------------- lib/future.ml | 8 +-- lib/lib.mllib | 2 +- plugins/funind/functional_principles_types.ml | 2 +- plugins/funind/indfun_common.ml | 2 +- plugins/funind/indfun_common.mli | 2 +- proofs/proof_global.ml | 28 ++++----- stm/asyncTaskQueue.ml | 2 +- toplevel/obligations.ml | 16 ++--- 20 files changed, 187 insertions(+), 187 deletions(-) create mode 100644 lib/cEphemeron.ml create mode 100644 lib/cEphemeron.mli delete mode 100644 lib/ephemeron.ml delete mode 100644 lib/ephemeron.mli diff --git a/checker/check.mllib b/checker/check.mllib index 0d36e3a0f1..902ab9ddf6 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -32,7 +32,7 @@ CStack Util Ppstyle Errors -Ephemeron +CEphemeron Future CUnix System diff --git a/dev/printers.mllib b/dev/printers.mllib index ab7e9fc346..ad9a5d75e6 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -48,7 +48,7 @@ Rtree Heap Genarg Stateid -Ephemeron +CEphemeron Future RemoteCounter Monad diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index fc7e1b9374..7e1a5d5b7e 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -131,8 +131,8 @@ let key rk = match !rk with | None -> raise NotEvaluated | Some k -> - try Ephemeron.get k - with Ephemeron.InvalidKey -> raise NotEvaluated + try CEphemeron.get k + with CEphemeron.InvalidKey -> raise NotEvaluated (************************) (* traduction des patch *) @@ -171,7 +171,7 @@ let rec slot_for_getglobal env kn = | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) - rk := Some (Ephemeron.create pos); + rk := Some (CEphemeron.create pos); pos and slot_for_fv env fv = diff --git a/kernel/entries.mli b/kernel/entries.mli index b2a77dd950..f94068f31e 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -104,7 +104,7 @@ type side_eff = | SEscheme of (inductive * constant * Declarations.constant_body * seff_env) list * string type side_effect = { - from_env : Declarations.structure_body Ephemeron.key; + from_env : Declarations.structure_body CEphemeron.key; eff : side_eff; } diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index e1fe02595a..df3495569a 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -25,7 +25,7 @@ open Declarations (* The key attached to each constant is used by the VM to retrieve previous *) (* evaluations of the constant. It is essentially an index in the symbols table *) (* used by the VM. *) -type key = int Ephemeron.key option ref +type key = int CEphemeron.key option ref (** Linking information for the native compiler. *) @@ -50,17 +50,17 @@ type stratification = { } type val_kind = - | VKvalue of (values * Id.Set.t) Ephemeron.key + | VKvalue of (values * Id.Set.t) CEphemeron.key | VKnone type lazy_val = val_kind ref let force_lazy_val vk = match !vk with | VKnone -> None -| VKvalue v -> try Some (Ephemeron.get v) with Ephemeron.InvalidKey -> None +| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None let dummy_lazy_val () = ref VKnone -let build_lazy_val vk key = vk := VKvalue (Ephemeron.create key) +let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) type named_vals = (Id.t * lazy_val) list diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 23f9a3f419..99d3e2e252 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -19,7 +19,7 @@ type link_info = | LinkedInteractive of string | NotLinked -type key = int Ephemeron.key option ref +type key = int CEphemeron.key option ref type constant_key = constant_body * (link_info ref * key) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 4c3264861e..0926d35f6d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -231,11 +231,11 @@ let constant_entry_of_private_constant = function let private_con_of_con env c = let cbo = Environ.lookup_constant c env.env in - { Entries.from_env = Ephemeron.create env.revstruct; + { Entries.from_env = CEphemeron.create env.revstruct; Entries.eff = Entries.SEsubproof (c,cbo,get_opaque_body env.env cbo) } let private_con_of_scheme ~kind env cl = - { Entries.from_env = Ephemeron.create env.revstruct; + { Entries.from_env = CEphemeron.create env.revstruct; Entries.eff = Entries.SEscheme( List.map (fun (i,c) -> let cbo = Environ.lookup_constant c env.env in diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 510f43542f..fdbd1e3b19 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -126,14 +126,14 @@ let check_signatures curmb sl = | None -> None, None | Some curmb -> try - let mb = Ephemeron.get mb in + let mb = CEphemeron.get mb in match sl with | None -> sl, None | Some n -> if List.length mb >= how_many && CList.skipn how_many mb == curmb then Some (n + how_many), Some mb else None, None - with Ephemeron.InvalidKey -> None, None in + with CEphemeron.InvalidKey -> None, None in let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in sl diff --git a/lib/cEphemeron.ml b/lib/cEphemeron.ml new file mode 100644 index 0000000000..a38ea11e10 --- /dev/null +++ b/lib/cEphemeron.ml @@ -0,0 +1,89 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* boxed_key = + (* TODO: take a random value here. Is there a random function in OCaml? *) + let bid = ref 0 in + (* According to OCaml Gc module documentation, Pervasives.ref is one of the + few ways of getting a boxed value the compiler will never alias. *) + fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid) + +(* A phantom type to preserve type safety *) +type 'a key = boxed_key + +(* Comparing keys with == grants that if a key is unmarshalled (in the same + process where it was created or in another one) it is not mistaken for + an already existing one (unmarshal has no right to alias). If the initial + value of bid is taken at random, then one also avoids potential collisions *) +module HT = Hashtbl.Make(struct + type t = key_type ref + let equal k1 k2 = k1 == k2 + let hash id = !id +end) + +(* A key is the (unique) value inside a boxed key, hence it does not + keep its corresponding boxed key reachable (replacing key_type by boxed_key + would make the key always reachable) *) +let values : Obj.t HT.t = HT.create 1001 + +(* To avoid a race contidion between the finalization function and + get/create on the values hashtable, the finalization function just + enqueues in an imperative list the item to be collected. Being the list + imperative, even if the Gc enqueue an item while run_collection is operating, + the tail of the list is eventually set to Empty on completion. + Kudos to the authors of Why3 that came up with this solution for their + implementation of weak hash tables! *) +type imperative_list = cell ref +and cell = Empty | Item of key_type ref * imperative_list + +let collection_queue : imperative_list ref = ref (ref Empty) + +let enqueue x = collection_queue := ref (Item (!x, !collection_queue)) + +let run_collection () = + let rec aux l = match !l with + | Empty -> () + | Item (k, tl) -> HT.remove values k; aux tl in + let l = !collection_queue in + aux l; + l := Empty + +(* The only reference to the boxed key is the one returned, when the user drops + it the value eventually disappears from the values table above *) +let create (v : 'a) : 'a key = + run_collection (); + let k = mk_key () in + HT.add values !k (Obj.repr v); + Gc.finalise enqueue k; + k + +(* Avoid raising Not_found *) +exception InvalidKey +let get (k : 'a key) : 'a = + run_collection (); + try Obj.obj (HT.find values !k) + with Not_found -> raise InvalidKey + +(* Simple utils *) +let default k v = + try get k + with InvalidKey -> v + +let iter_opt k f = + match + try Some (get k) + with InvalidKey -> None + with + | None -> () + | Some v -> f v + +let clear () = run_collection () diff --git a/lib/cEphemeron.mli b/lib/cEphemeron.mli new file mode 100644 index 0000000000..1200e4e208 --- /dev/null +++ b/lib/cEphemeron.mli @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a key + +(* May raise InvalidKey *) +exception InvalidKey +val get : 'a key -> 'a + +(* These never fail. *) +val iter_opt : 'a key -> ('a -> unit) -> unit +val default : 'a key -> 'a -> 'a + +val clear : unit -> unit diff --git a/lib/ephemeron.ml b/lib/ephemeron.ml deleted file mode 100644 index a38ea11e10..0000000000 --- a/lib/ephemeron.ml +++ /dev/null @@ -1,89 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* boxed_key = - (* TODO: take a random value here. Is there a random function in OCaml? *) - let bid = ref 0 in - (* According to OCaml Gc module documentation, Pervasives.ref is one of the - few ways of getting a boxed value the compiler will never alias. *) - fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid) - -(* A phantom type to preserve type safety *) -type 'a key = boxed_key - -(* Comparing keys with == grants that if a key is unmarshalled (in the same - process where it was created or in another one) it is not mistaken for - an already existing one (unmarshal has no right to alias). If the initial - value of bid is taken at random, then one also avoids potential collisions *) -module HT = Hashtbl.Make(struct - type t = key_type ref - let equal k1 k2 = k1 == k2 - let hash id = !id -end) - -(* A key is the (unique) value inside a boxed key, hence it does not - keep its corresponding boxed key reachable (replacing key_type by boxed_key - would make the key always reachable) *) -let values : Obj.t HT.t = HT.create 1001 - -(* To avoid a race contidion between the finalization function and - get/create on the values hashtable, the finalization function just - enqueues in an imperative list the item to be collected. Being the list - imperative, even if the Gc enqueue an item while run_collection is operating, - the tail of the list is eventually set to Empty on completion. - Kudos to the authors of Why3 that came up with this solution for their - implementation of weak hash tables! *) -type imperative_list = cell ref -and cell = Empty | Item of key_type ref * imperative_list - -let collection_queue : imperative_list ref = ref (ref Empty) - -let enqueue x = collection_queue := ref (Item (!x, !collection_queue)) - -let run_collection () = - let rec aux l = match !l with - | Empty -> () - | Item (k, tl) -> HT.remove values k; aux tl in - let l = !collection_queue in - aux l; - l := Empty - -(* The only reference to the boxed key is the one returned, when the user drops - it the value eventually disappears from the values table above *) -let create (v : 'a) : 'a key = - run_collection (); - let k = mk_key () in - HT.add values !k (Obj.repr v); - Gc.finalise enqueue k; - k - -(* Avoid raising Not_found *) -exception InvalidKey -let get (k : 'a key) : 'a = - run_collection (); - try Obj.obj (HT.find values !k) - with Not_found -> raise InvalidKey - -(* Simple utils *) -let default k v = - try get k - with InvalidKey -> v - -let iter_opt k f = - match - try Some (get k) - with InvalidKey -> None - with - | None -> () - | Some v -> f v - -let clear () = run_collection () diff --git a/lib/ephemeron.mli b/lib/ephemeron.mli deleted file mode 100644 index 1200e4e208..0000000000 --- a/lib/ephemeron.mli +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a key - -(* May raise InvalidKey *) -exception InvalidKey -val get : 'a key -> 'a - -(* These never fail. *) -val iter_opt : 'a key -> ('a -> unit) -> unit -val default : 'a key -> 'a -> 'a - -val clear : unit -> unit diff --git a/lib/future.ml b/lib/future.ml index 5cd2beba91..e8f33db5e1 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -62,7 +62,7 @@ and 'a comp = | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = - | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) Ephemeron.key + | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) CEphemeron.key | Finished of 'a and 'a computation = 'a comput ref @@ -70,13 +70,13 @@ and 'a computation = 'a comput ref let unnamed = "unnamed" let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x = - ref (Ongoing (name, Ephemeron.create (uuid, f, Pervasives.ref x))) + ref (Ongoing (name, CEphemeron.create (uuid, f, Pervasives.ref x))) let get x = match !x with | Finished v -> unnamed, UUID.invalid, id, ref (Val (v,None)) | Ongoing (name, x) -> - try let uuid, fix, c = Ephemeron.get x in name, uuid, fix, c - with Ephemeron.InvalidKey -> + try let uuid, fix, c = CEphemeron.get x in name, uuid, fix, c + with CEphemeron.InvalidKey -> name, UUID.invalid, id, ref (Exn (NotHere name, Exninfo.null)) type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ] diff --git a/lib/lib.mllib b/lib/lib.mllib index f3f6ad8fc7..6805ce4919 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -15,6 +15,6 @@ Rtree Heap Unionfind Genarg -Ephemeron +CEphemeron Future RemoteCounter diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index c47602bda0..18200307a8 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -291,7 +291,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - get_proof_clean true, Ephemeron.create hook + get_proof_clean true, CEphemeron.create hook end diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index aa47e26192..2449678a13 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -163,7 +163,7 @@ let save with_clean id const (locality,_,kind) hook = (locality, ConstRef kn) in if with_clean then Pfedit.delete_current_proof (); - Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); + CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 23f1da1ba7..e5c756f564 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -47,7 +47,7 @@ val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> - unit Lemmas.declaration_hook Ephemeron.key -> unit + unit Lemmas.declaration_hook CEphemeron.key -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and abort the proof diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index f22cdbcc8e..541f299d4f 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -36,7 +36,7 @@ let find_proof_mode n = Errors.error (Format.sprintf "No proof mode named \"%s\"." n) let register_proof_mode ({name = n} as m) = - Hashtbl.add proof_modes n (Ephemeron.create m) + Hashtbl.add proof_modes n (CEphemeron.create m) (* initial mode: standard mode *) let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) } @@ -52,7 +52,7 @@ let _ = optname = "default proof mode" ; optkey = ["Default";"Proof";"Mode"] ; optread = begin fun () -> - (Ephemeron.default !default_proof_mode standard).name + (CEphemeron.default !default_proof_mode standard).name end; optwrite = begin fun n -> default_proof_mode := find_proof_mode n @@ -83,12 +83,12 @@ type closed_proof = proof_object * proof_terminator type pstate = { pid : Id.t; - terminator : proof_terminator Ephemeron.key; + terminator : proof_terminator CEphemeron.key; endline_tactic : Tacexpr.raw_tactic_expr option; section_vars : Context.section_context option; proof : Proof.proof; strength : Decl_kinds.goal_kind; - mode : proof_mode Ephemeron.key; + mode : proof_mode CEphemeron.key; universe_binders: universe_binders option; } @@ -103,11 +103,11 @@ let current_proof_mode = ref !default_proof_mode let update_proof_mode () = match !pstates with | { mode = m } :: _ -> - Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); + CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); current_proof_mode := m; - Ephemeron.iter_opt !current_proof_mode (fun x -> x.set ()) + CEphemeron.iter_opt !current_proof_mode (fun x -> x.set ()) | _ -> - Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); + CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); current_proof_mode := find_proof_mode "No" (* combinators for the current_proof lists *) @@ -215,9 +215,9 @@ let set_proof_mode mn = set_proof_mode (find_proof_mode mn) (get_current_proof_name ()) let activate_proof_mode mode = - Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) + CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) let disactivate_proof_mode mode = - Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ()) + CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ()) (** [start_proof sigma id str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -230,7 +230,7 @@ let disactivate_proof_mode mode = let start_proof sigma id ?pl str goals terminator = let initial_state = { pid = id; - terminator = Ephemeron.create terminator; + terminator = CEphemeron.create terminator; proof = Proof.start sigma goals; endline_tactic = None; section_vars = None; @@ -242,7 +242,7 @@ let start_proof sigma id ?pl str goals terminator = let start_dependent_proof id ?pl str goals terminator = let initial_state = { pid = id; - terminator = Ephemeron.create terminator; + terminator = CEphemeron.create terminator; proof = Proof.dependent_start goals; endline_tactic = None; section_vars = None; @@ -375,7 +375,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = in { id = pid; entries = entries; persistence = strength; universes = (universes, binders) }, - fun pr_ending -> Ephemeron.get terminator pr_ending + fun pr_ending -> CEphemeron.get terminator pr_ending type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context @@ -423,11 +423,11 @@ let close_proof ~keep_body_ucst_separate fix_exn = (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -let get_terminator () = Ephemeron.get ( cur_pstate() ).terminator +let get_terminator () = CEphemeron.get ( cur_pstate() ).terminator let set_terminator hook = match !pstates with | [] -> raise NoCurrentProof - | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps + | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index cc97326047..5f018ec39d 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -314,7 +314,7 @@ module Make(T : Task) = struct let response = slave_respond request in report_status "Idle"; marshal_response (Option.get !slave_oc) response; - Ephemeron.clear () + CEphemeron.clear () with | MarshalError s -> pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2 diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 7e0d30a63e..615257a1c8 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -324,11 +324,11 @@ type program_info_aux = { prg_sign: named_context_val; } -type program_info = program_info_aux Ephemeron.key +type program_info = program_info_aux CEphemeron.key let get_info x = - try Ephemeron.get x - with Ephemeron.InvalidKey -> + try CEphemeron.get x + with CEphemeron.InvalidKey -> Errors.anomaly Pp.(str "Program obligation can't be accessed by a worker") let assumption_message = Declare.assumption_message @@ -461,7 +461,7 @@ let subst_deps_obl obls obl = module ProgMap = Map.Make(Id) -let map_replace k v m = ProgMap.add k (Ephemeron.create v) (ProgMap.remove k m) +let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] @@ -682,7 +682,7 @@ let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind let map_cardinal m = let i = ref 0 in ProgMap.iter (fun _ v -> - if snd (Ephemeron.get v).prg_obligations > 0 then incr i) m; + if snd (CEphemeron.get v).prg_obligations > 0 then incr i) m; !i exception Found of program_info @@ -690,7 +690,7 @@ exception Found of program_info let map_first m = try ProgMap.iter (fun _ v -> - if snd (Ephemeron.get v).prg_obligations > 0 then + if snd (CEphemeron.get v).prg_obligations > 0 then raise (Found v)) m; assert(false) with Found x -> x @@ -1016,7 +1016,7 @@ let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definit else ( let len = Array.length obls in let _ = Flags.if_verbose msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in - progmap_add n (Ephemeron.create prg); + progmap_add n (CEphemeron.create prg); let res = auto_solve_obligations (Some n) tactic in match res with | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res @@ -1030,7 +1030,7 @@ let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(r (fun (n, b, t, imps, obls) -> let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook - in progmap_add n (Ephemeron.create prg)) l; + in progmap_add n (CEphemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> if finished then finished -- cgit v1.2.3 From 18a5eb4ecfcb7c2fbb315719c09e3d5fc0a3574e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 16:56:08 +0100 Subject: Adding some standard arguments in tactic scopes. This is not perfect and repeats what we do in Pcoq, but it is hard to factorize because rules defined in Pcoq do not have the same precedence. For instance, constr as a Tactic Notation argument is a Pcoq.Constr.constr while as a quotation argument is a Pcoq.Constr.lconstr. We should think of a fix in the long run, but for now it is reasonable to duplicate code. --- tactics/extraargs.ml4 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 9946aea82a..98868e8f91 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -23,10 +23,15 @@ let create_generic_quotation name e wit = let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in Egramcoq.create_ltac_quotation name inject (e, None) +let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int +let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string + +let () = create_generic_quotation "ident" Pcoq.Prim.ident Constrarg.wit_ident +let () = create_generic_quotation "reference" Pcoq.Prim.reference Constrarg.wit_ref let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Constrarg.wit_uconstr let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Constrarg.wit_constr let () = create_generic_quotation "ipattern" Pcoq.Tactic.simple_intropattern Constrarg.wit_intro_pattern -let () = create_generic_quotation "int" Pcoq.Prim.integer Stdarg.wit_int +let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Constrarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in Egramcoq.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5) -- cgit v1.2.3 From 120053a50f87bd53398eedc887fa5e979f56f112 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 4 Mar 2016 18:17:56 +0100 Subject: This fix is probably not enough to justify that there are no problems with primitive projections and prop. ext. or univalence, but at least it prevents known proofs of false (see discussion on #4588). --- kernel/inductive.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 80dc690422..fbe0920bcf 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -814,7 +814,15 @@ let rec subterm_specif renv stack t = | Proj (p, c) -> let subt = subterm_specif renv stack c in (match subt with - | Subterm (s, wf) -> Subterm (Strict, wf) + | Subterm (s, wf) -> + (* We take the subterm specs of the constructor of the record *) + let wf_args = (dest_subterms wf).(0) in + (* We extract the tree of the projected argument *) + let kn = Projection.constant p in + let cb = lookup_constant kn renv.env in + let pb = Option.get cb.const_proj in + let n = pb.proj_arg in + Subterm (Strict, List.nth wf_args n) | Dead_code -> Dead_code | Not_subterm -> Not_subterm) -- cgit v1.2.3 From 35cc038e96395b0f4eaaeed3a5a48e6da2293f7e Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 4 Mar 2016 19:01:35 +0100 Subject: Fix #4607: do not read native code files if native compiler was disabled. --- library/library.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/library/library.ml b/library/library.ml index 79e5792c02..ccda57c2c5 100644 --- a/library/library.ml +++ b/library/library.ml @@ -171,9 +171,8 @@ let register_loaded_library m = let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in - (* This will not produce errors or warnings if the native compiler was - not enabled *) - Nativelib.link_library ~prefix ~dirname ~basename:f + if not Coq_config.no_native_compiler then + Nativelib.link_library ~prefix ~dirname ~basename:f in let rec aux = function | [] -> link m; [libname] -- cgit v1.2.3 From 32baedf7a3aebb96f7dd2c7d90a1aef40ed93792 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Mar 2016 18:16:31 +0100 Subject: Fixing bug #4608: Anomaly "output_value: abstract value (outside heap)". The ARGUMENT EXTEND statement was wrongly using a CompatLoc instead of a Loc, and this was not detected by typing "thanks" to the Gram.action magic. When using CAMLP4, this was wreaking havoc at runtime, but not when using CAMLP5, as the locations where sharing the same representation. --- grammar/argextend.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 8def9537cb..cb0f7d2d31 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -120,7 +120,7 @@ let make_possibly_empty_subentries loc s cl = let make_act loc act pil = let rec make = function - | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >> + | [] -> <:expr< Pcoq.Gram.action (fun loc -> let loc = Compat.to_coqloc loc in ($act$ : 'a)) >> | GramNonTerminal (_,t,_,Some p) :: tl -> let p = Names.Id.to_string p in <:expr< -- cgit v1.2.3 From c6d6e27330f0a1c9e89b6b60953d4df757edfdb8 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Mar 2016 18:13:23 +0100 Subject: Exporting build_selector, a component of discriminate, for use in congruence. --- tactics/equality.ml | 37 +++++++++++++++++++------------------ tactics/equality.mli | 5 +++++ 2 files changed, 24 insertions(+), 18 deletions(-) diff --git a/tactics/equality.ml b/tactics/equality.ml index 453f81af57..8eadd4aeec 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -861,13 +861,13 @@ let descend_then env sigma head dirn = *) -(* [construct_discriminator env dirn headval] - constructs a case-split on [headval], with the [dirn]-th branch - giving [True], and all the rest giving False. *) +(* [construct_discriminator env sigma dirn c ind special default]] + constructs a case-split on [c] of type [ind], with the [dirn]-th + branch giving [special], and all the rest giving [default]. *) -let construct_discriminator env sigma dirn c sort = +let build_selector env sigma dirn c ind special default = let IndType(indf,_) = - try find_rectype env sigma (get_type_of env sigma c) + try find_rectype env sigma ind with Not_found -> (* one can find Rel(k) in case of dependent constructors like T := c : (A:Set)A->T and a discrimination @@ -879,25 +879,29 @@ let construct_discriminator env sigma dirn c sort = dependent types.") in let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in + let typ = Retyping.get_type_of env sigma default in let (mib,mip) = lookup_mind_specif env ind in - let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in - let p = it_mkLambda_or_LetIn (mkSort sort_0) deparsign in + let p = it_mkLambda_or_LetIn typ deparsign in let cstrs = get_constructors env indf in let build_branch i = - let endpt = if Int.equal i dirn then true_0 else false_0 in + let endpt = if Int.equal i dirn then special else default in it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) -let rec build_discriminator env sigma dirn c sort = function - | [] -> construct_discriminator env sigma dirn c sort +let rec build_discriminator env sigma dirn c = function + | [] -> + let ind = get_type_of env sigma c in + let true_0,false_0 = + build_coq_True(),build_coq_False() in + build_selector env sigma dirn c ind true_0 false_0 | ((sp,cnum),argnum)::l -> let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in - let subval = build_discriminator cnum_env sigma dirn newc sort l in + let subval = build_discriminator cnum_env sigma dirn newc l in kont subval (build_coq_False (),mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is @@ -959,11 +963,11 @@ let apply_on_clause (f,t) clause = | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause -let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = +let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in let discriminator = - build_discriminator e_env sigma dirn (mkVar e) sort cpath in + build_discriminator e_env sigma dirn (mkVar e) cpath in let sigma,(pf, absurd_term), eff = discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in @@ -978,13 +982,11 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in match find_positions env sigma t1 t2 with | Inr _ -> tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> - let sort = pf_apply get_type_of gl concl in - discr_positions env sigma u eq_clause cpath dirn sort + discr_positions env sigma u eq_clause cpath dirn end } let onEquality with_evars tac (c,lbindc) = @@ -1414,12 +1416,11 @@ let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (L let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = Proofview.Goal.nf_enter { enter = begin fun gl -> - let sort = pf_apply get_type_of gl (Proofview.Goal.concl gl) in let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u clause cpath dirn sort + discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) ntac (clenv_value clause) 0 | Inr posns -> diff --git a/tactics/equality.mli b/tactics/equality.mli index f84dafb31f..458d8f3722 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -117,3 +117,8 @@ val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic val replace_term : bool option -> constr -> clause -> unit Proofview.tactic val set_eq_dec_scheme_kind : mutual scheme_kind -> unit + +(* [build_selector env sigma i c t u v] matches on [c] of + type [t] and returns [u] in branch [i] and [v] on other branches *) +val build_selector : env -> evar_map -> int -> constr -> types -> + constr -> constr -> constr -- cgit v1.2.3 From eb0feed6d22c11c44e7091c64ce5b1c9d5af987a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Mar 2016 18:23:05 +0100 Subject: Using build_selector from Equality as a replacement of the selector in cctac which does not support indices properly. Incidentally, this should fix a failure in RelationAlgebra, where making prod_applist more robust (e8c47b652) revealed the discriminate bug in congruence. --- plugins/cc/cctac.ml | 25 +++++-------------------- test-suite/success/cc.v | 7 ++++++- 2 files changed, 11 insertions(+), 21 deletions(-) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index b52f156a1b..a1aff12d4f 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -223,24 +223,9 @@ let make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) -let build_projection intype outtype (cstr:pconstructor) special default gls= - let env=pf_env gls in - let (h,argv) = try destApp intype with DestKO -> (intype,[||]) in - let ind,u=destInd h in - let types=Inductiveops.arities_of_constructors env (ind,u) in - let lp=Array.length types in - let ci=pred (snd(fst cstr)) in - let branch i= - let ti= prod_appvect types.(i) argv in - let rc=fst (decompose_prod_assum ti) in - let head= - if Int.equal i ci then special else default in - it_mkLambda_or_LetIn head rc in - let branches=Array.init lp branch in - let casee=mkRel 1 in - let pred=mkLambda(Anonymous,intype,outtype) in - let case_info=make_case_info (pf_env gls) ind RegularStyle in - let body= mkCase(case_info, pred, casee, branches) in +let build_projection intype (cstr:pconstructor) special default gls= + let ci= (snd(fst cstr)) in + let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in mkLambda(Name id,intype,body) @@ -322,7 +307,7 @@ let rec proof_tac p : unit Proofview.tactic = let outtype = (* Termops.refresh_universes *) (type_of default) in let special=mkRel (1+nargs-argind) in let proj = - Tacmach.New.of_old (build_projection intype outtype cstr special default) gl + Tacmach.New.of_old (build_projection intype cstr special default) gl in let injt= app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in @@ -391,7 +376,7 @@ let discriminate_tac (cstr,u as cstru) p = let outtype = mkSort outtype in let pred=mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in - let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in + let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in let injt=app_global _f_equal [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v index a70d919635..dc0527d826 100644 --- a/test-suite/success/cc.v +++ b/test-suite/success/cc.v @@ -129,5 +129,10 @@ Qed. End bug_2447. +(* congruence was supposed to do discriminate but it was bugged for + types with indices *) - +Inductive I : nat -> Type := C : I 0 | D : I 0. +Goal ~C=D. +congruence. +Qed. -- cgit v1.2.3 From 8d828a124d66a79b6e35c02097b05df252d1e1d4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 03:02:01 +0100 Subject: Moving Eauto to a simple ML file. --- plugins/funind/functional_principles_proofs.ml | 2 +- tactics/eauto.ml | 528 +++++++++++++++++++ tactics/eauto.ml4 | 667 ------------------------- tactics/eauto.mli | 14 +- tactics/g_auto.ml4 | 130 +++++ tactics/hightactics.mllib | 2 +- theories/Init/Notations.v | 1 - 7 files changed, 668 insertions(+), 676 deletions(-) create mode 100644 tactics/eauto.ml delete mode 100644 tactics/eauto.ml4 diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index c8f8a19e5b..02cd819f4a 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1407,7 +1407,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) (* rewrite *) (* ) *) - Eauto.gen_eauto (false,5) [] (Some []) + Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) ] gls diff --git a/tactics/eauto.ml b/tactics/eauto.ml new file mode 100644 index 0000000000..a118f2642f --- /dev/null +++ b/tactics/eauto.ml @@ -0,0 +1,528 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let t1 = Tacmach.New.pf_unsafe_type_of gl c in + let t2 = Tacmach.New.pf_concl gl in + if occur_existential t1 || occur_existential t2 then + Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) + else exact_check c + end } + +let assumption id = e_give_exact (mkVar id) + +let e_assumption = + Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) + end } + +let registered_e_assumption = + Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) + (Tacmach.New.pf_ids_of_hyps gl)) + end } + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + +(************************************************************************) +(* PROLOG tactic *) +(************************************************************************) + +(*s Tactics handling a list of goals. *) + +(* first_goal : goal list sigma -> goal sigma *) + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then error "first_goal"; + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) + +let apply_tac_list tac glls = + let (sigr,lg) = unpackage glls in + match lg with + | (g1::rest) -> + let gl = apply_sig_tac sigr tac g1 in + repackage sigr (gl@rest) + | _ -> error "apply_tac_list" + +let one_step l gl = + [Proofview.V82.of_tactic Tactics.intro] + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) + @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) + +let rec prolog l n gl = + if n <= 0 then error "prolog - failure"; + let prol = (prolog l (n-1)) in + (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl + +let out_term = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + +let prolog_tac l n = + Proofview.V82.tactic begin fun gl -> + let map c = + let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in + out_term c + in + let l = List.map map l in + try (prolog l n gl) + with UserError ("Refiner.tclFIRST",_) -> + errorlabstrm "Prolog.prolog" (str "Prolog failed.") + end + +open Auto +open Unification + +(***************************************************************************) +(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) +(***************************************************************************) + +let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) + +let unify_e_resolve poly flags (c,clenv) = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + Proofview.V82.tactic + (fun gls -> + let clenv' = clenv_unique_resolver ~flags clenv' gls in + tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) + end } + +let hintmap_of hdc concl = + match hdc with + | None -> fun db -> Hint_db.map_none db + | Some hdc -> + if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) + else (fun db -> Hint_db.map_auto hdc concl db) + (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) + +let e_exact poly flags (c,clenv) = + let (c, _, _) = c in + let clenv', subst = + if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst + in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) + +let rec e_trivial_fail_db db_list local_db = + let next = Proofview.Goal.nf_enter { enter = begin fun gl -> + let d = Tacmach.New.pf_last_hyp gl in + let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in + e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) + end } in + Proofview.Goal.enter { enter = begin fun gl -> + let tacl = + registered_e_assumption :: + (Tacticals.New.tclTHEN Tactics.intro next) :: + (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) + in + Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) + end } + +and e_my_find_search db_list local_db hdc concl = + let hint_of_db = hintmap_of hdc concl in + let hintl = + List.map_append (fun db -> + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) + in + let tac_of_hint = + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> + let b = match Hints.repr_hint t with + | Unfold_nth _ -> 1 + | _ -> b + in + (b, + let tac = function + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) + | Res_pf_THEN_trivial_fail (term,cl) -> + Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) + (e_trivial_fail_db db_list local_db) + | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl + | Extern tacast -> conclPattern concl p tacast + in + let tac = run_hint t tac in + (tac, lazy (pr_hint t))) + in + List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db gl = + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try priority (e_my_find_search db_list local_db hd gl) + with Not_found -> [] + +let e_possible_resolve db_list local_db gl = + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) + with Not_found -> [] + +let find_first_goal gls = + try first_goal gls with UserError _ -> assert false + +(*s The following module [SearchProblem] is used to instantiate the generic + exploration functor [Explore.Make]. *) + +type search_state = { + priority : int; + depth : int; (*r depth of search before failing *) + tacres : goal list sigma; + last_tactic : std_ppcmds Lazy.t; + dblist : hint_db list; + localdb : hint_db list; + prev : prev_search_state; + local_lemmas : Tacexpr.delayed_open_constr list; +} + +and prev_search_state = (* for info eauto *) + | Unknown + | Init + | State of search_state + +module SearchProblem = struct + + type state = search_state + + let success s = List.is_empty (sig_it s.tacres) + +(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) + + let filter_tactics glls l = +(* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) +(* let evars = Evarutil.nf_evars (Refiner.project glls) in *) +(* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) + let rec aux = function + | [] -> [] + | (tac, cost, pptac) :: tacl -> + try + let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in +(* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) +(* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) + (lgls, cost, pptac) :: aux tacl + with e when Errors.noncritical e -> + let e = Errors.push e in + Refiner.catch_failerror e; aux tacl + in aux l + + (* Ordering of states is lexicographic on depth (greatest first) then + number of remaining goals. *) + let compare s s' = + let d = s'.depth - s.depth in + let d' = Int.compare s.priority s'.priority in + let nbgoals s = List.length (sig_it s.tacres) in + if not (Int.equal d 0) then d + else if not (Int.equal d' 0) then d' + else Int.compare (nbgoals s) (nbgoals s') + + let branching s = + if Int.equal s.depth 0 then + [] + else + let ps = if s.prev == Unknown then Unknown else State s in + let lg = s.tacres in + let nbgl = List.length (sig_it lg) in + assert (nbgl > 0); + let g = find_first_goal lg in + let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in + let assumption_tacs = + let tacs = List.map map_assum (pf_ids_of_hyps g) in + let l = filter_tactics s.tacres tacs in + List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = List.tl s.localdb; + prev = ps; local_lemmas = s.local_lemmas}) l + in + let intro_tac = + let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in + List.map + (fun (lgls, cost, pp) -> + let g' = first_goal lgls in + let hintl = + make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in + let ldb = Hint_db.add_list (pf_env g') (project g') + hintl (List.hd s.localdb) in + { depth = s.depth; priority = cost; tacres = lgls; + last_tactic = pp; dblist = s.dblist; + localdb = ldb :: List.tl s.localdb; prev = ps; + local_lemmas = s.local_lemmas}) + l + in + let rec_tacs = + let l = + filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + in + List.map + (fun (lgls, cost, pp) -> + let nbgl' = List.length (sig_it lgls) in + if nbgl' < nbgl then + { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; + prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; + local_lemmas = s.local_lemmas } + else + let newlocal = + let hyps = pf_hyps g in + List.map (fun gl -> + let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in + let hyps' = pf_hyps gls in + if hyps' == hyps then List.hd s.localdb + else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) + (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) + in + { depth = pred s.depth; priority = cost; tacres = lgls; + dblist = s.dblist; last_tactic = pp; prev = ps; + localdb = newlocal @ List.tl s.localdb; + local_lemmas = s.local_lemmas }) + l + in + List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + + let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + (Lazy.force s.last_tactic)) + +end + +module Search = Explore.Make(SearchProblem) + +(** Utilities for debug eauto / info eauto *) + +let global_debug_eauto = ref false +let global_info_eauto = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Debug Eauto"; + Goptions.optkey = ["Debug";"Eauto"]; + Goptions.optread = (fun () -> !global_debug_eauto); + Goptions.optwrite = (:=) global_debug_eauto } + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Info Eauto"; + Goptions.optkey = ["Info";"Eauto"]; + Goptions.optread = (fun () -> !global_info_eauto); + Goptions.optwrite = (:=) global_info_eauto } + +let mk_eauto_dbg d = + if d == Debug || !global_debug_eauto then Debug + else if d == Info || !global_info_eauto then Info + else Off + +let pr_info_nop = function + | Info -> msg_debug (str "idtac.") + | _ -> () + +let pr_dbg_header = function + | Off -> () + | Debug -> msg_debug (str "(* debug eauto : *)") + | Info -> msg_debug (str "(* info eauto : *)") + +let pr_info dbg s = + if dbg != Info then () + else + let rec loop s = + match s.prev with + | Unknown | Init -> s.depth + | State sp -> + let mindepth = loop sp in + let indent = String.make (mindepth - sp.depth) ' ' in + msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + mindepth + in + ignore (loop s) + +(** Eauto main code *) + +let make_initial_state dbg n gl dblist localdb lems = + { depth = n; + priority = 0; + tacres = tclIDTAC gl; + last_tactic = lazy (mt()); + dblist = dblist; + localdb = [localdb]; + prev = if dbg == Info then Init else Unknown; + local_lemmas = lems; + } + +let e_search_auto debug (in_depth,p) lems db_list gl = + let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in + let d = mk_eauto_dbg debug in + let tac = match in_depth,d with + | (true,Debug) -> Search.debug_depth_first + | (true,_) -> Search.depth_first + | (false,Debug) -> Search.debug_breadth_first + | (false,_) -> Search.breadth_first + in + try + pr_dbg_header d; + let s = tac (make_initial_state d p gl db_list local_db lems) in + pr_info d s; + s.tacres + with Not_found -> + pr_info_nop d; + error "eauto: search failed" + +(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) +(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) + +let eauto_with_bases ?(debug=Off) np lems db_list = + tclTRY (e_search_auto debug np lems db_list) + +let eauto ?(debug=Off) np lems dbnames = + let db_list = make_db_list dbnames in + tclTRY (e_search_auto debug np lems db_list) + +let full_eauto ?(debug=Off) n lems gl = + let dbnames = current_db_names () in + let dbnames = String.Set.remove "v62" dbnames in + let db_list = List.map searchtable_map (String.Set.elements dbnames) in + tclTRY (e_search_auto debug n lems db_list) gl + +let gen_eauto ?(debug=Off) np lems = function + | None -> Proofview.V82.tactic (full_eauto ~debug np lems) + | Some l -> Proofview.V82.tactic (eauto ~debug np lems l) + +let make_depth = function + | None -> !default_search_depth + | Some d -> d + +let make_dimension n = function + | None -> (true,make_depth n) + | Some d -> (false,d) + +let cons a l = a :: l + +let autounfolds db occs cls gl = + let unfolds = List.concat (List.map (fun dbname -> + let db = try searchtable_map dbname + with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + in + let (ids, csts) = Hint_db.unfolds db in + let hyps = pf_ids_of_hyps gl in + let ids = Idset.filter (fun id -> List.mem id hyps) ids in + Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts + (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) + in Proofview.V82.of_tactic (unfold_option unfolds cls) gl + +let autounfold db cls = + Proofview.V82.tactic begin fun gl -> + let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in + let tac = autounfolds db in + tclMAP (function + | OnHyp (id,occs,where) -> tac occs (Some (id,where)) + | OnConcl occs -> tac occs None) + cls gl + end + +let autounfold_tac db cls = + Proofview.tclUNIT () >>= fun () -> + let dbs = match db with + | None -> String.Set.elements (current_db_names ()) + | Some [] -> ["core"] + | Some l -> l + in + autounfold dbs cls + +let unfold_head env (ids, csts) c = + let rec aux c = + match kind_of_term c with + | Var id when Id.Set.mem id ids -> + (match Environ.named_body id env with + | Some b -> true, b + | None -> false, c) + | Const (cst,u as c) when Cset.mem cst csts -> + true, Environ.constant_value_in env c + | App (f, args) -> + (match aux f with + | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) + | false, _ -> + let done_, args' = + Array.fold_left_i (fun i (done_, acc) arg -> + if done_ then done_, arg :: acc + else match aux arg with + | true, arg' -> true, arg' :: acc + | false, arg' -> false, arg :: acc) + (false, []) args + in + if done_ then true, mkApp (f, Array.of_list (List.rev args')) + else false, c) + | _ -> + let done_ = ref false in + let c' = map_constr (fun c -> + if !done_ then c else + let x, c' = aux c in + done_ := x; c') c + in !done_, c' + in aux c + +let autounfold_one db cl = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let st = + List.fold_left (fun (i,c) dbname -> + let db = try searchtable_map dbname + with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + in + let (ids, csts) = Hint_db.unfolds db in + (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db + in + let did, c' = unfold_head env st + (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) + in + if did then + match cl with + | Some hyp -> change_in_hyp None (make_change_arg c') hyp + | None -> convert_concl_no_check c' DEFAULTcast + else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") + end } diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 deleted file mode 100644 index f2d26ec86b..0000000000 --- a/tactics/eauto.ml4 +++ /dev/null @@ -1,667 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let t1 = Tacmach.New.pf_unsafe_type_of gl c in - let t2 = Tacmach.New.pf_concl gl in - if occur_existential t1 || occur_existential t2 then - Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) - else exact_check c - end } - -let assumption id = e_give_exact (mkVar id) - -let e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) - end } - -TACTIC EXTEND eassumption -| [ "eassumption" ] -> [ e_assumption ] -END - -TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ e_give_exact c ] -END - -let registered_e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) - (Tacmach.New.pf_ids_of_hyps gl)) - end } - -let eval_uconstrs ist cs = - let flags = { - Pretyping.use_typeclasses = false; - use_unif_heuristics = true; - use_hook = Some Pfedit.solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true - } in - List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs - -(************************************************************************) -(* PROLOG tactic *) -(************************************************************************) - -(*s Tactics handling a list of goals. *) - -(* first_goal : goal list sigma -> goal sigma *) - -let first_goal gls = - let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in - if List.is_empty gl then error "first_goal"; - { Evd.it = List.hd gl; Evd.sigma = sig_0; } - -(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) - -let apply_tac_list tac glls = - let (sigr,lg) = unpackage glls in - match lg with - | (g1::rest) -> - let gl = apply_sig_tac sigr tac g1 in - repackage sigr (gl@rest) - | _ -> error "apply_tac_list" - -let one_step l gl = - [Proofview.V82.of_tactic Tactics.intro] - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) - @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) - -let rec prolog l n gl = - if n <= 0 then error "prolog - failure"; - let prol = (prolog l (n-1)) in - (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl - -let out_term = function - | IsConstr (c, _) -> c - | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) - -let prolog_tac l n gl = - let map c = - let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in - let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in - out_term c - in - let l = List.map map l in - try (prolog l n gl) - with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" (str "Prolog failed.") - -TACTIC EXTEND prolog -| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> - [ Proofview.V82.tactic (prolog_tac (eval_uconstrs ist l) n) ] -END - -open Auto -open Unification - -(***************************************************************************) -(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) -(***************************************************************************) - -let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) - -let unify_e_resolve poly flags (c,clenv) = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let clenv', c = connect_hint_clenv poly c clenv gl in - Proofview.V82.tactic - (fun gls -> - let clenv' = clenv_unique_resolver ~flags clenv' gls in - tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) - end } - -let hintmap_of hdc concl = - match hdc with - | None -> fun db -> Hint_db.map_none db - | Some hdc -> - if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) - else (fun db -> Hint_db.map_auto hdc concl db) - (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) - -let e_exact poly flags (c,clenv) = - let (c, _, _) = c in - let clenv', subst = - if poly then Clenv.refresh_undefined_univs clenv - else clenv, Univ.empty_level_subst - in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) - -let rec e_trivial_fail_db db_list local_db = - let next = Proofview.Goal.nf_enter { enter = begin fun gl -> - let d = Tacmach.New.pf_last_hyp gl in - let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in - e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) - end } in - Proofview.Goal.enter { enter = begin fun gl -> - let tacl = - registered_e_assumption :: - (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) - in - Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) - end } - -and e_my_find_search db_list local_db hdc concl = - let hint_of_db = hintmap_of hdc concl in - let hintl = - List.map_append (fun db -> - let flags = auto_flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, {pri = b; pat = p; code = t; poly = poly}) -> - let b = match Hints.repr_hint t with - | Unfold_nth _ -> 1 - | _ -> b - in - (b, - let tac = function - | Res_pf (term,cl) -> unify_resolve poly st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) - | Give_exact (c,cl) -> e_exact poly st (c,cl) - | Res_pf_THEN_trivial_fail (term,cl) -> - Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) - (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl - | Extern tacast -> conclPattern concl p tacast - in - let tac = run_hint t tac in - (tac, lazy (pr_hint t))) - in - List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in - try priority (e_my_find_search db_list local_db hd gl) - with Not_found -> [] - -let e_possible_resolve db_list local_db gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in - try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) - with Not_found -> [] - -let find_first_goal gls = - try first_goal gls with UserError _ -> assert false - -(*s The following module [SearchProblem] is used to instantiate the generic - exploration functor [Explore.Make]. *) - -type search_state = { - priority : int; - depth : int; (*r depth of search before failing *) - tacres : goal list sigma; - last_tactic : std_ppcmds Lazy.t; - dblist : hint_db list; - localdb : hint_db list; - prev : prev_search_state; - local_lemmas : Tacexpr.delayed_open_constr list; -} - -and prev_search_state = (* for info eauto *) - | Unknown - | Init - | State of search_state - -module SearchProblem = struct - - type state = search_state - - let success s = List.is_empty (sig_it s.tacres) - -(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) - - let filter_tactics glls l = -(* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) -(* let evars = Evarutil.nf_evars (Refiner.project glls) in *) -(* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) - let rec aux = function - | [] -> [] - | (tac, cost, pptac) :: tacl -> - try - let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in -(* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) -(* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) - (lgls, cost, pptac) :: aux tacl - with e when Errors.noncritical e -> - let e = Errors.push e in - Refiner.catch_failerror e; aux tacl - in aux l - - (* Ordering of states is lexicographic on depth (greatest first) then - number of remaining goals. *) - let compare s s' = - let d = s'.depth - s.depth in - let d' = Int.compare s.priority s'.priority in - let nbgoals s = List.length (sig_it s.tacres) in - if not (Int.equal d 0) then d - else if not (Int.equal d' 0) then d' - else Int.compare (nbgoals s) (nbgoals s') - - let branching s = - if Int.equal s.depth 0 then - [] - else - let ps = if s.prev == Unknown then Unknown else State s in - let lg = s.tacres in - let nbgl = List.length (sig_it lg) in - assert (nbgl > 0); - let g = find_first_goal lg in - let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in - let assumption_tacs = - let tacs = List.map map_assum (pf_ids_of_hyps g) in - let l = filter_tactics s.tacres tacs in - List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = List.tl s.localdb; - prev = ps; local_lemmas = s.local_lemmas}) l - in - let intro_tac = - let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in - List.map - (fun (lgls, cost, pp) -> - let g' = first_goal lgls in - let hintl = - make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in - let ldb = Hint_db.add_list (pf_env g') (project g') - hintl (List.hd s.localdb) in - { depth = s.depth; priority = cost; tacres = lgls; - last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb; prev = ps; - local_lemmas = s.local_lemmas}) - l - in - let rec_tacs = - let l = - filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) - in - List.map - (fun (lgls, cost, pp) -> - let nbgl' = List.length (sig_it lgls) in - if nbgl' < nbgl then - { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; - prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; - local_lemmas = s.local_lemmas } - else - let newlocal = - let hyps = pf_hyps g in - List.map (fun gl -> - let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in - let hyps' = pf_hyps gls in - if hyps' == hyps then List.hd s.localdb - else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) - (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) - in - { depth = pred s.depth; priority = cost; tacres = lgls; - dblist = s.dblist; last_tactic = pp; prev = ps; - localdb = newlocal @ List.tl s.localdb; - local_lemmas = s.local_lemmas }) - l - in - List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - - let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ - (Lazy.force s.last_tactic)) - -end - -module Search = Explore.Make(SearchProblem) - -(** Utilities for debug eauto / info eauto *) - -let global_debug_eauto = ref false -let global_info_eauto = ref false - -let _ = - Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; - Goptions.optname = "Debug Eauto"; - Goptions.optkey = ["Debug";"Eauto"]; - Goptions.optread = (fun () -> !global_debug_eauto); - Goptions.optwrite = (:=) global_debug_eauto } - -let _ = - Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; - Goptions.optname = "Info Eauto"; - Goptions.optkey = ["Info";"Eauto"]; - Goptions.optread = (fun () -> !global_info_eauto); - Goptions.optwrite = (:=) global_info_eauto } - -let mk_eauto_dbg d = - if d == Debug || !global_debug_eauto then Debug - else if d == Info || !global_info_eauto then Info - else Off - -let pr_info_nop = function - | Info -> msg_debug (str "idtac.") - | _ -> () - -let pr_dbg_header = function - | Off -> () - | Debug -> msg_debug (str "(* debug eauto : *)") - | Info -> msg_debug (str "(* info eauto : *)") - -let pr_info dbg s = - if dbg != Info then () - else - let rec loop s = - match s.prev with - | Unknown | Init -> s.depth - | State sp -> - let mindepth = loop sp in - let indent = String.make (mindepth - sp.depth) ' ' in - msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); - mindepth - in - ignore (loop s) - -(** Eauto main code *) - -let make_initial_state dbg n gl dblist localdb lems = - { depth = n; - priority = 0; - tacres = tclIDTAC gl; - last_tactic = lazy (mt()); - dblist = dblist; - localdb = [localdb]; - prev = if dbg == Info then Init else Unknown; - local_lemmas = lems; - } - -let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in - let d = mk_eauto_dbg debug in - let tac = match in_depth,d with - | (true,Debug) -> Search.debug_depth_first - | (true,_) -> Search.depth_first - | (false,Debug) -> Search.debug_breadth_first - | (false,_) -> Search.breadth_first - in - try - pr_dbg_header d; - let s = tac (make_initial_state d p gl db_list local_db lems) in - pr_info d s; - s.tacres - with Not_found -> - pr_info_nop d; - error "eauto: search failed" - -(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) -(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) - -let eauto_with_bases ?(debug=Off) np lems db_list = - tclTRY (e_search_auto debug np lems db_list) - -let eauto ?(debug=Off) np lems dbnames = - let db_list = make_db_list dbnames in - tclTRY (e_search_auto debug np lems db_list) - -let full_eauto ?(debug=Off) n lems gl = - let dbnames = current_db_names () in - let dbnames = String.Set.remove "v62" dbnames in - let db_list = List.map searchtable_map (String.Set.elements dbnames) in - tclTRY (e_search_auto debug n lems db_list) gl - -let gen_eauto ?(debug=Off) np lems = function - | None -> full_eauto ~debug np lems - | Some l -> eauto ~debug np lems l - -let make_depth = function - | None -> !default_search_depth - | Some d -> d - -let make_dimension n = function - | None -> (true,make_depth n) - | Some d -> (false,d) - -open Genarg -open G_auto - -let hintbases = G_auto.hintbases -let wit_hintbases = G_auto.wit_hintbases - -TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (make_dimension n p) (eval_uconstrs ist lems) db) ] -END - -TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) - hintbases(db) ] -> - [ match db with - | None -> new_full_auto (make_depth n) (eval_uconstrs ist lems) - | Some l -> new_auto (make_depth n) (eval_uconstrs ist lems) l ] -END - -TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) (eval_uconstrs ist lems) db) ] -END - -TACTIC EXTEND info_eauto -| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) (eval_uconstrs ist lems) db) ] -END - -TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (true, make_depth p) (eval_uconstrs ist lems) db) ] -END - -let cons a l = a :: l - -let autounfolds db occs cls gl = - let unfolds = List.concat (List.map (fun dbname -> - let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - let hyps = pf_ids_of_hyps gl in - let ids = Idset.filter (fun id -> List.mem id hyps) ids in - Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in Proofview.V82.of_tactic (unfold_option unfolds cls) gl - -let autounfold db cls gl = - let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in - let tac = autounfolds db in - tclMAP (function - | OnHyp (id,occs,where) -> tac occs (Some (id,where)) - | OnConcl occs -> tac occs None) - cls gl - -let autounfold_tac db cls gl = - let dbs = match db with - | None -> String.Set.elements (current_db_names ()) - | Some [] -> ["core"] - | Some l -> l - in - autounfold dbs cls gl - -TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause(cl) ] -> [ Proofview.V82.tactic (autounfold_tac db cl) ] -END - -let unfold_head env (ids, csts) c = - let rec aux c = - match kind_of_term c with - | Var id when Id.Set.mem id ids -> - (match Environ.named_body id env with - | Some b -> true, b - | None -> false, c) - | Const (cst,u as c) when Cset.mem cst csts -> - true, Environ.constant_value_in env c - | App (f, args) -> - (match aux f with - | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) - | false, _ -> - let done_, args' = - Array.fold_left_i (fun i (done_, acc) arg -> - if done_ then done_, arg :: acc - else match aux arg with - | true, arg' -> true, arg' :: acc - | false, arg' -> false, arg :: acc) - (false, []) args - in - if done_ then true, mkApp (f, Array.of_list (List.rev args')) - else false, c) - | _ -> - let done_ = ref false in - let c' = map_constr (fun c -> - if !done_ then c else - let x, c' = aux c in - done_ := x; c') c - in !done_, c' - in aux c - -let autounfold_one db cl = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let st = - List.fold_left (fun (i,c) dbname -> - let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db - in - let did, c' = unfold_head env st - (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) - in - if did then - match cl with - | Some hyp -> change_in_hyp None (make_change_arg c') hyp - | None -> convert_concl_no_check c' DEFAULTcast - else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") - end } - -(* Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *) -(* (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *) -(* in unfold_option unfolds cl *) - -(* let db = try searchtable_map dbname *) -(* with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) *) -(* in *) -(* let (ids, csts) = Hint_db.unfolds db in *) -(* Cset.fold (fun cst -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *) -(* (Id.Set.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *) -(* (tclFAIL 0 (mt())) db *) - -TACTIC EXTEND autounfold_one -| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> - [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, InHyp)) ] -| [ "autounfold_one" hintbases(db) ] -> - [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] - END - -TACTIC EXTEND autounfoldify -| [ "autounfoldify" constr(x) ] -> [ - Proofview.V82.tactic ( - let db = match kind_of_term x with - | Const (c,_) -> Label.to_string (con_label c) - | _ -> assert false - in autounfold ["core";db] onConcl - )] -END - -TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ - let table = try Some (searchtable_map base) with Not_found -> None in - match table with - | None -> - let msg = str "Hint table " ++ str base ++ str " not found" in - Tacticals.New.tclZEROMSG msg - | Some t -> - let state = Hint_db.transparent_state t in - unify ~state x y - ] -END - - -TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ] -END - -let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom - -ARGUMENT EXTEND hints_path_atom - TYPED AS hints_path_atom - PRINTED BY pr_hints_path_atom -| [ global_list(g) ] -> [ PathHints (List.map Nametab.global g) ] -| [ "*" ] -> [ PathAny ] -END - -let pr_hints_path prc prx pry c = Hints.pp_hints_path c - -ARGUMENT EXTEND hints_path - TYPED AS hints_path - PRINTED BY pr_hints_path -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ "!" hints_path(p) ] -> [ PathStar p ] -| [ "emp" ] -> [ PathEmpty ] -| [ "eps" ] -> [ PathEpsilon ] -| [ hints_path_atom(a) ] -> [ PathAtom a ] -| [ hints_path(p) "|" hints_path(q) ] -> [ PathOr (p, q) ] -| [ hints_path(p) ";" hints_path(q) ] -> [ PathSeq (p, q) ] -END - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND opthints - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ ":" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ None ] -END - -VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - let entry = HintsCutEntry p in - Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (match dbnames with None -> ["core"] | Some l -> l) entry ] -END diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 0a490c65d8..8812093d5f 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -10,22 +10,24 @@ open Term open Proof_type open Hints -val hintbases : hint_db_name list option Pcoq.Gram.entry - -val wit_hintbases : hint_db_name list option Genarg.uniform_genarg_type - val e_assumption : unit Proofview.tactic val registered_e_assumption : unit Proofview.tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic +val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic + val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> - hint_db_name list option -> tactic + hint_db_name list option -> unit Proofview.tactic val eauto_with_bases : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic -val autounfold : hint_db_name list -> Locus.clause -> tactic +val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic +val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic +val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic + +val make_dimension : int option -> int option -> bool * int diff --git a/tactics/g_auto.ml4 b/tactics/g_auto.ml4 index 3a2cee9f72..f4fae763fd 100644 --- a/tactics/g_auto.ml4 +++ b/tactics/g_auto.ml4 @@ -16,6 +16,15 @@ DECLARE PLUGIN "g_auto" (* Hint bases *) + +TACTIC EXTEND eassumption +| [ "eassumption" ] -> [ Eauto.e_assumption ] +END + +TACTIC EXTEND eexact +| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +END + let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases ARGUMENT EXTEND hintbases @@ -45,6 +54,8 @@ ARGUMENT EXTEND auto_using | [ ] -> [ [] ] END +(** Auto *) + TACTIC EXTEND trivial | [ "trivial" auto_using(lems) hintbases(db) ] -> [ Auto.h_trivial (eval_uconstrs ist lems) db ] @@ -74,3 +85,122 @@ TACTIC EXTEND debug_auto | [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] END + +(** Eauto *) + +TACTIC EXTEND prolog +| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> + [ Eauto.prolog_tac (eval_uconstrs ist l) n ] +END + +let make_depth n = snd (Eauto.make_dimension n None) + +TACTIC EXTEND eauto +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND new_eauto +| [ "new" "auto" int_or_var_opt(n) auto_using(lems) + hintbases(db) ] -> + [ match db with + | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] +END + +TACTIC EXTEND debug_eauto +| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_eauto +| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND dfs_eauto +| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND autounfold +| [ "autounfold" hintbases(db) clause(cl) ] -> [ Eauto.autounfold_tac db cl ] +END + +TACTIC EXTEND autounfold_one +| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] +| [ "autounfold_one" hintbases(db) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + END + +TACTIC EXTEND autounfoldify +| [ "autounfoldify" constr(x) ] -> [ + let db = match Term.kind_of_term x with + | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) + | _ -> assert false + in Eauto.autounfold ["core";db] Locusops.onConcl + ] +END + +TACTIC EXTEND unify +| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ + let table = try Some (Hints.searchtable_map base) with Not_found -> None in + match table with + | None -> + let msg = str "Hint table " ++ str base ++ str " not found" in + Tacticals.New.tclZEROMSG msg + | Some t -> + let state = Hints.Hint_db.transparent_state t in + Tactics.unify ~state x y + ] +END + + +TACTIC EXTEND convert_concl_no_check +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +END + +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom + +ARGUMENT EXTEND hints_path_atom + TYPED AS hints_path_atom + PRINTED BY pr_hints_path_atom +| [ global_list(g) ] -> [ Hints.PathHints (List.map Nametab.global g) ] +| [ "*" ] -> [ Hints.PathAny ] +END + +let pr_hints_path prc prx pry c = Hints.pp_hints_path c + +ARGUMENT EXTEND hints_path + TYPED AS hints_path + PRINTED BY pr_hints_path +| [ "(" hints_path(p) ")" ] -> [ p ] +| [ "!" hints_path(p) ] -> [ Hints.PathStar p ] +| [ "emp" ] -> [ Hints.PathEmpty ] +| [ "eps" ] -> [ Hints.PathEpsilon ] +| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] +| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] +| [ hints_path(p) ";" hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND opthints + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ ":" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ None ] +END + +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ + let entry = Hints.HintsCutEntry p in + Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (match dbnames with None -> ["core"] | Some l -> l) entry ] +END diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 30e97f62d5..0d73cc27aa 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,8 +1,8 @@ Extraargs Coretactics Extratactics -G_auto Eauto +G_auto Class_tactics G_class Rewrite diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 55eb699be6..65ea8028d1 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -86,7 +86,6 @@ Open Scope type_scope. Declare ML Module "coretactics". Declare ML Module "extratactics". Declare ML Module "g_auto". -Declare ML Module "eauto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". Declare ML Module "g_rewrite". -- cgit v1.2.3 From 8f6d74c1e771966e3dd44704805a1e848af4802a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 03:42:51 +0100 Subject: Splitting the nsatz ML module into an implementation and a grammar files. --- plugins/nsatz/g_nsatz.ml4 | 17 ++ plugins/nsatz/nsatz.ml | 590 ++++++++++++++++++++++++++++++++++++++ plugins/nsatz/nsatz.ml4 | 598 --------------------------------------- plugins/nsatz/nsatz_plugin.mllib | 1 + 4 files changed, 608 insertions(+), 598 deletions(-) create mode 100644 plugins/nsatz/g_nsatz.ml4 create mode 100644 plugins/nsatz/nsatz.ml delete mode 100644 plugins/nsatz/nsatz.ml4 diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 new file mode 100644 index 0000000000..0da6305304 --- /dev/null +++ b/plugins/nsatz/g_nsatz.ml4 @@ -0,0 +1,17 @@ +DECLARE PLUGIN "nsatz_plugin" + +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Proofview.V82.tactic (Nsatz.nsatz_compute lt) ] +END diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml new file mode 100644 index 0000000000..ee1904a660 --- /dev/null +++ b/plugins/nsatz/nsatz.ml @@ -0,0 +1,590 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 1 + let puis = power_big_int_positive_int + + (* a et b positifs, résultat positif *) + let rec pgcd a b = + if equal b coef0 + then a + else if lt a b then pgcd b a else pgcd b (modulo a b) + + + (* signe du pgcd = signe(a)*signe(b) si non nuls. *) + let pgcd2 a b = + if equal a coef0 then b + else if equal b coef0 then a + else let c = pgcd (abs a) (abs b) in + if ((lt coef0 a)&&(lt b coef0)) + ||((lt coef0 b)&&(lt a coef0)) + then opp c else c +end + +(* +module Ent = struct + type t = Entiers.entiers + let of_int = Entiers.ent_of_int + let of_num x = Entiers.ent_of_string(Num.string_of_num x) + let to_num x = Num.num_of_string (Entiers.string_of_ent x) + let equal = Entiers.eq_ent + let lt = Entiers.lt_ent + let le = Entiers.le_ent + let abs = Entiers.abs_ent + let plus =Entiers.add_ent + let mult = Entiers.mult_ent + let sub = Entiers.moins_ent + let opp = Entiers.opp_ent + let div = Entiers.div_ent + let modulo = Entiers.mod_ent + let coef0 = Entiers.ent0 + let coef1 = Entiers.ent1 + let to_string = Entiers.string_of_ent + let to_int x = Entiers.int_of_ent x + let hash x =Entiers.hash_ent x + let signe = Entiers.signe_ent + + let rec puis p n = match n with + 0 -> coef1 + |_ -> (mult p (puis p (n-1))) + + (* a et b positifs, résultat positif *) + let rec pgcd a b = + if equal b coef0 + then a + else if lt a b then pgcd b a else pgcd b (modulo a b) + + + (* signe du pgcd = signe(a)*signe(b) si non nuls. *) + let pgcd2 a b = + if equal a coef0 then b + else if equal b coef0 then a + else let c = pgcd (abs a) (abs b) in + if ((lt coef0 a)&&(lt b coef0)) + ||((lt coef0 b)&&(lt a coef0)) + then opp c else c +end +*) + +(* ------------------------------------------------------------------------- *) +(* ------------------------------------------------------------------------- *) + +type vname = string + +type term = + | Zero + | Const of Num.num + | Var of vname + | Opp of term + | Add of term * term + | Sub of term * term + | Mul of term * term + | Pow of term * int + +let const n = + if eq_num n num_0 then Zero else Const n +let pow(p,i) = if Int.equal i 1 then p else Pow(p,i) +let add = function + (Zero,q) -> q + | (p,Zero) -> p + | (p,q) -> Add(p,q) +let mul = function + (Zero,_) -> Zero + | (_,Zero) -> Zero + | (p,Const n) when eq_num n num_1 -> p + | (Const n,q) when eq_num n num_1 -> q + | (p,q) -> Mul(p,q) + +let unconstr = mkRel 1 + +let tpexpr = + lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") +let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") +let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") +let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") +let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") +let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") +let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") +let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") + +let datatypes = ["Init";"Datatypes"] +let binnums = ["Numbers";"BinNums"] + +let tlist = lazy (gen_constant "CC" datatypes "list") +let lnil = lazy (gen_constant "CC" datatypes "nil") +let lcons = lazy (gen_constant "CC" datatypes "cons") + +let tz = lazy (gen_constant "CC" binnums "Z") +let z0 = lazy (gen_constant "CC" binnums "Z0") +let zpos = lazy (gen_constant "CC" binnums "Zpos") +let zneg = lazy(gen_constant "CC" binnums "Zneg") + +let pxI = lazy(gen_constant "CC" binnums "xI") +let pxO = lazy(gen_constant "CC" binnums "xO") +let pxH = lazy(gen_constant "CC" binnums "xH") + +let nN0 = lazy (gen_constant "CC" binnums "N0") +let nNpos = lazy(gen_constant "CC" binnums "Npos") + +let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) + +let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] +let tllp () = mkt_app tlist [tlp()] + +let rec mkt_pos n = + if n =/ num_1 then Lazy.force pxH + else if mod_num n num_2 =/ num_0 then + mkt_app pxO [mkt_pos (quo_num n num_2)] + else + mkt_app pxI [mkt_pos (quo_num n num_2)] + +let mkt_n n = + if Num.eq_num n num_0 + then Lazy.force nN0 + else mkt_app nNpos [mkt_pos n] + +let mkt_z z = + if z =/ num_0 then Lazy.force z0 + else if z >/ num_0 then + mkt_app zpos [mkt_pos z] + else + mkt_app zneg [mkt_pos ((Int 0) -/ z)] + +let rec mkt_term t = match t with +| Zero -> mkt_term (Const num_0) +| Const r -> let (n,d) = numdom r in + mkt_app ttconst [Lazy.force tz; mkt_z n] +| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] +| Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] +| Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] +| Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] +| Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] +| Pow (t1,n) -> if Int.equal n 0 then + mkt_app ttconst [Lazy.force tz; mkt_z num_1] +else + mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] + +let rec parse_pos p = + match kind_of_term p with +| App (a,[|p2|]) -> + if eq_constr a (Lazy.force pxO) then num_2 */ (parse_pos p2) + else num_1 +/ (num_2 */ (parse_pos p2)) +| _ -> num_1 + +let parse_z z = + match kind_of_term z with +| App (a,[|p2|]) -> + if eq_constr a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2)) +| _ -> num_0 + +let parse_n z = + match kind_of_term z with +| App (a,[|p2|]) -> + parse_pos p2 +| _ -> num_0 + +let rec parse_term p = + match kind_of_term p with +| App (a,[|_;p2|]) -> + if eq_constr a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2)) + else if eq_constr a (Lazy.force ttconst) then Const (parse_z p2) + else if eq_constr a (Lazy.force ttopp) then Opp (parse_term p2) + else Zero +| App (a,[|_;p2;p3|]) -> + if eq_constr a (Lazy.force ttadd) then Add (parse_term p2, parse_term p3) + else if eq_constr a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3) + else if eq_constr a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3) + else if eq_constr a (Lazy.force ttpow) then + Pow (parse_term p2, int_of_num (parse_n p3)) + else Zero +| _ -> Zero + +let rec parse_request lp = + match kind_of_term lp with + | App (_,[|_|]) -> [] + | App (_,[|_;p;lp1|]) -> + (parse_term p)::(parse_request lp1) + |_-> assert false + +let nvars = ref 0 + +let set_nvars_term t = + let rec aux t = + match t with + | Zero -> () + | Const r -> () + | Var v -> let n = int_of_string v in + nvars:= max (!nvars) n + | Opp t1 -> aux t1 + | Add (t1,t2) -> aux t1; aux t2 + | Sub (t1,t2) -> aux t1; aux t2 + | Mul (t1,t2) -> aux t1; aux t2 + | Pow (t1,n) -> aux t1 + in aux t + +let string_of_term p = + let rec aux p = + match p with + | Zero -> "0" + | Const r -> string_of_num r + | Var v -> "x"^v + | Opp t1 -> "(-"^(aux t1)^")" + | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")" + | Sub (t1,t2) -> "("^(aux t1)^"-"^(aux t2)^")" + | Mul (t1,t2) -> "("^(aux t1)^"*"^(aux t2)^")" + | Pow (t1,n) -> (aux t1)^"^"^(string_of_int n) + in aux p + + +(*********************************************************************** + Coefficients: recursive polynomials + *) + +module Coef = BigInt +(*module Coef = Ent*) +module Poly = Polynom.Make(Coef) +module PIdeal = Ideal.Make(Poly) +open PIdeal + +(* term to sparse polynomial + varaibles <=np are in the coefficients +*) + +let term_pol_sparse np t= + let d = !nvars in + let rec aux t = +(* info ("conversion de: "^(string_of_term t)^"\n");*) + let res = + match t with + | Zero -> zeroP + | Const r -> + if Num.eq_num r num_0 + then zeroP + else polconst d (Poly.Pint (Coef.of_num r)) + | Var v -> + let v = int_of_string v in + if v <= np + then polconst d (Poly.x v) + else gen d v + | Opp t1 -> oppP (aux t1) + | Add (t1,t2) -> plusP (aux t1) (aux t2) + | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2)) + | Mul (t1,t2) -> multP (aux t1) (aux t2) + | Pow (t1,n) -> puisP (aux t1) n + in +(* info ("donne: "^(stringP res)^"\n");*) + res + in + let res= aux t in + res + +(* sparse polynomial to term *) + +let polrec_to_term p = + let rec aux p = + match p with + |Poly.Pint n -> const (Coef.to_num n) + |Poly.Prec (v,coefs) -> + let res = ref Zero in + Array.iteri + (fun i c -> + res:=add(!res, mul(aux c, + pow (Var (string_of_int v), + i)))) + coefs; + !res + in aux p + +(* approximation of the Horner form used in the tactic ring *) + +let pol_sparse_to_term n2 p = + (* info "pol_sparse_to_term ->\n";*) + let p = PIdeal.repr p in + let rec aux p = + match p with + [] -> const (num_of_string "0") + | (a,m)::p1 -> + let n = (Array.length m)-1 in + let (i0,e0) = + List.fold_left (fun (r,d) (a,m) -> + let i0= ref 0 in + for k=1 to n do + if m.(k)>0 + then i0:=k + done; + if Int.equal !i0 0 + then (r,d) + else if !i0 > r + then (!i0, m.(!i0)) + else if Int.equal !i0 r && m.(!i0) + if m.(i0)>=e0 + then (m.(i0)<-m.(i0)-e0; + p1:=(a,m)::(!p1)) + else p2:=(a,m)::(!p2)) + p; + let vm = + if Int.equal e0 1 + then Var (string_of_int (i0)) + else pow (Var (string_of_int (i0)),e0) in + add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2)))) + in (*info "-> pol_sparse_to_term\n";*) + aux p + + +let remove_list_tail l i = + let rec aux l i = + if List.is_empty l + then [] + else if i<0 + then l + else if Int.equal i 0 + then List.tl l + else + match l with + |(a::l1) -> + a::(aux l1 (i-1)) + |_ -> assert false + in + List.rev (aux (List.rev l) i) + +(* + lq = [cn+m+1 n+m ...cn+m+1 1] + lci=[[cn+1 n,...,cn1 1] + ... + [cn+m n+m-1,...,cn+m 1]] + + removes intermediate polynomials not useful to compute the last one. + *) + +let remove_zeros zero lci = + let n = List.length (List.hd lci) in + let m=List.length lci in + let u = Array.make m false in + let rec utiles k = + if k>=m + then () + else ( + u.(k)<-true; + let lc = List.nth lci k in + for i=0 to List.length lc - 1 do + if not (zero (List.nth lc i)) + then utiles (i+k+1); + done) + in utiles 0; + let lr = ref [] in + for i=0 to m-1 do + if u.(i) + then lr:=(List.nth lci i)::(!lr) + done; + let lr=List.rev !lr in + let lr = List.map + (fun lc -> + let lcr=ref lc in + for i=0 to m-1 do + if not u.(i) + then lcr:=remove_list_tail !lcr (m-i+(n-m)) + done; + !lcr) + lr in + info ("useless spolynomials: " + ^string_of_int (m-List.length lr)^"\n"); + info ("useful spolynomials: " + ^string_of_int (List.length lr)^"\n"); + lr + +let theoremedeszeros lpol p = + let t1 = Unix.gettimeofday() in + let m = !nvars in + let (lp0,p,cert) = in_ideal m lpol p in + let lpc = List.rev !poldepcontent in + info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1)); + (cert,lp0,p,lpc) + +open Ideal + +let theoremedeszeros_termes lp = + nvars:=0;(* mise a jour par term_pol_sparse *) + List.iter set_nvars_term lp; + match lp with + | Const (Int sugarparam)::Const (Int nparam)::lp -> + ((match sugarparam with + |0 -> info "computation without sugar\n"; + lexico:=false; + sugar_flag := false; + divide_rem_with_critical_pair := false + |1 -> info "computation with sugar\n"; + lexico:=false; + sugar_flag := true; + divide_rem_with_critical_pair := false + |2 -> info "ordre lexico computation without sugar\n"; + lexico:=true; + sugar_flag := false; + divide_rem_with_critical_pair := false + |3 -> info "ordre lexico computation with sugar\n"; + lexico:=true; + sugar_flag := true; + divide_rem_with_critical_pair := false + |4 -> info "computation without sugar, division by pairs\n"; + lexico:=false; + sugar_flag := false; + divide_rem_with_critical_pair := true + |5 -> info "computation with sugar, division by pairs\n"; + lexico:=false; + sugar_flag := true; + divide_rem_with_critical_pair := true + |6 -> info "ordre lexico computation without sugar, division by pairs\n"; + lexico:=true; + sugar_flag := false; + divide_rem_with_critical_pair := true + |7 -> info "ordre lexico computation with sugar, division by pairs\n"; + lexico:=true; + sugar_flag := true; + divide_rem_with_critical_pair := true + | _ -> error "nsatz: bad parameter" + ); + let m= !nvars in + let lvar=ref [] in + for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done; + lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *) + name_var:=!lvar; + let lp = List.map (term_pol_sparse nparam) lp in + match lp with + | [] -> assert false + | p::lp1 -> + let lpol = List.rev lp1 in + let (cert,lp0,p,_lct) = theoremedeszeros lpol p in + info "cert ok\n"; + let lc = cert.last_comb::List.rev cert.gb_comb in + match remove_zeros (fun x -> equal x zeroP) lc with + | [] -> assert false + | (lq::lci) -> + (* lci commence par les nouveaux polynomes *) + let m= !nvars in + let c = pol_sparse_to_term m (polconst m cert.coef) in + let r = Pow(Zero,cert.power) in + let lci = List.rev lci in + let lci = List.map (List.map (pol_sparse_to_term m)) lci in + let lq = List.map (pol_sparse_to_term m) lq in + info ("number of parametres: "^string_of_int nparam^"\n"); + info "term computed\n"; + (c,r,lci,lq) + ) + |_ -> assert false + + +(* version avec hash-consing du certificat: +let nsatz lpol = + Hashtbl.clear Dansideal.hmon; + Hashtbl.clear Dansideal.coefpoldep; + Hashtbl.clear Dansideal.sugartbl; + Hashtbl.clear Polynomesrec.hcontentP; + init_constants (); + let lp= parse_request lpol in + let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in + let certif = certificat_vers_polynome_creux rthz in + let certif = hash_certif certif in + let certif = certif_term certif in + let c = mkt_term c in + info "constr computed\n"; + (c, certif) +*) + +let nsatz lpol = + let lp= parse_request lpol in + let (c,r,lci,lq) = theoremedeszeros_termes lp in + let res = [c::r::lq]@lci in + let res = List.map (fun lx -> List.map mkt_term lx) res in + let res = + List.fold_right + (fun lt r -> + let ltterm = + List.fold_right + (fun t r -> + mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r]) + lt + (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in + mkt_app lcons [tlp ();ltterm;r]) + res + (mkt_app lnil [tlp ()]) in + info "term computed\n"; + res + +let return_term t = + let a = + mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in + generalize [a] + +let nsatz_compute t = + let lpol = + try nsatz t + with Ideal.NotInIdeal -> + error "nsatz cannot solve this problem" in + return_term lpol + + diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4 deleted file mode 100644 index ced53d82f4..0000000000 --- a/plugins/nsatz/nsatz.ml4 +++ /dev/null @@ -1,598 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 1 - let puis = power_big_int_positive_int - - (* a et b positifs, résultat positif *) - let rec pgcd a b = - if equal b coef0 - then a - else if lt a b then pgcd b a else pgcd b (modulo a b) - - - (* signe du pgcd = signe(a)*signe(b) si non nuls. *) - let pgcd2 a b = - if equal a coef0 then b - else if equal b coef0 then a - else let c = pgcd (abs a) (abs b) in - if ((lt coef0 a)&&(lt b coef0)) - ||((lt coef0 b)&&(lt a coef0)) - then opp c else c -end - -(* -module Ent = struct - type t = Entiers.entiers - let of_int = Entiers.ent_of_int - let of_num x = Entiers.ent_of_string(Num.string_of_num x) - let to_num x = Num.num_of_string (Entiers.string_of_ent x) - let equal = Entiers.eq_ent - let lt = Entiers.lt_ent - let le = Entiers.le_ent - let abs = Entiers.abs_ent - let plus =Entiers.add_ent - let mult = Entiers.mult_ent - let sub = Entiers.moins_ent - let opp = Entiers.opp_ent - let div = Entiers.div_ent - let modulo = Entiers.mod_ent - let coef0 = Entiers.ent0 - let coef1 = Entiers.ent1 - let to_string = Entiers.string_of_ent - let to_int x = Entiers.int_of_ent x - let hash x =Entiers.hash_ent x - let signe = Entiers.signe_ent - - let rec puis p n = match n with - 0 -> coef1 - |_ -> (mult p (puis p (n-1))) - - (* a et b positifs, résultat positif *) - let rec pgcd a b = - if equal b coef0 - then a - else if lt a b then pgcd b a else pgcd b (modulo a b) - - - (* signe du pgcd = signe(a)*signe(b) si non nuls. *) - let pgcd2 a b = - if equal a coef0 then b - else if equal b coef0 then a - else let c = pgcd (abs a) (abs b) in - if ((lt coef0 a)&&(lt b coef0)) - ||((lt coef0 b)&&(lt a coef0)) - then opp c else c -end -*) - -(* ------------------------------------------------------------------------- *) -(* ------------------------------------------------------------------------- *) - -type vname = string - -type term = - | Zero - | Const of Num.num - | Var of vname - | Opp of term - | Add of term * term - | Sub of term * term - | Mul of term * term - | Pow of term * int - -let const n = - if eq_num n num_0 then Zero else Const n -let pow(p,i) = if Int.equal i 1 then p else Pow(p,i) -let add = function - (Zero,q) -> q - | (p,Zero) -> p - | (p,q) -> Add(p,q) -let mul = function - (Zero,_) -> Zero - | (_,Zero) -> Zero - | (p,Const n) when eq_num n num_1 -> p - | (Const n,q) when eq_num n num_1 -> q - | (p,q) -> Mul(p,q) - -let unconstr = mkRel 1 - -let tpexpr = - lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") -let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") -let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") -let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") -let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") -let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") -let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") -let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") - -let datatypes = ["Init";"Datatypes"] -let binnums = ["Numbers";"BinNums"] - -let tlist = lazy (gen_constant "CC" datatypes "list") -let lnil = lazy (gen_constant "CC" datatypes "nil") -let lcons = lazy (gen_constant "CC" datatypes "cons") - -let tz = lazy (gen_constant "CC" binnums "Z") -let z0 = lazy (gen_constant "CC" binnums "Z0") -let zpos = lazy (gen_constant "CC" binnums "Zpos") -let zneg = lazy(gen_constant "CC" binnums "Zneg") - -let pxI = lazy(gen_constant "CC" binnums "xI") -let pxO = lazy(gen_constant "CC" binnums "xO") -let pxH = lazy(gen_constant "CC" binnums "xH") - -let nN0 = lazy (gen_constant "CC" binnums "N0") -let nNpos = lazy(gen_constant "CC" binnums "Npos") - -let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) - -let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] -let tllp () = mkt_app tlist [tlp()] - -let rec mkt_pos n = - if n =/ num_1 then Lazy.force pxH - else if mod_num n num_2 =/ num_0 then - mkt_app pxO [mkt_pos (quo_num n num_2)] - else - mkt_app pxI [mkt_pos (quo_num n num_2)] - -let mkt_n n = - if Num.eq_num n num_0 - then Lazy.force nN0 - else mkt_app nNpos [mkt_pos n] - -let mkt_z z = - if z =/ num_0 then Lazy.force z0 - else if z >/ num_0 then - mkt_app zpos [mkt_pos z] - else - mkt_app zneg [mkt_pos ((Int 0) -/ z)] - -let rec mkt_term t = match t with -| Zero -> mkt_term (Const num_0) -| Const r -> let (n,d) = numdom r in - mkt_app ttconst [Lazy.force tz; mkt_z n] -| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] -| Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] -| Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] -| Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] -| Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] -| Pow (t1,n) -> if Int.equal n 0 then - mkt_app ttconst [Lazy.force tz; mkt_z num_1] -else - mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] - -let rec parse_pos p = - match kind_of_term p with -| App (a,[|p2|]) -> - if eq_constr a (Lazy.force pxO) then num_2 */ (parse_pos p2) - else num_1 +/ (num_2 */ (parse_pos p2)) -| _ -> num_1 - -let parse_z z = - match kind_of_term z with -| App (a,[|p2|]) -> - if eq_constr a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2)) -| _ -> num_0 - -let parse_n z = - match kind_of_term z with -| App (a,[|p2|]) -> - parse_pos p2 -| _ -> num_0 - -let rec parse_term p = - match kind_of_term p with -| App (a,[|_;p2|]) -> - if eq_constr a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2)) - else if eq_constr a (Lazy.force ttconst) then Const (parse_z p2) - else if eq_constr a (Lazy.force ttopp) then Opp (parse_term p2) - else Zero -| App (a,[|_;p2;p3|]) -> - if eq_constr a (Lazy.force ttadd) then Add (parse_term p2, parse_term p3) - else if eq_constr a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3) - else if eq_constr a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3) - else if eq_constr a (Lazy.force ttpow) then - Pow (parse_term p2, int_of_num (parse_n p3)) - else Zero -| _ -> Zero - -let rec parse_request lp = - match kind_of_term lp with - | App (_,[|_|]) -> [] - | App (_,[|_;p;lp1|]) -> - (parse_term p)::(parse_request lp1) - |_-> assert false - -let nvars = ref 0 - -let set_nvars_term t = - let rec aux t = - match t with - | Zero -> () - | Const r -> () - | Var v -> let n = int_of_string v in - nvars:= max (!nvars) n - | Opp t1 -> aux t1 - | Add (t1,t2) -> aux t1; aux t2 - | Sub (t1,t2) -> aux t1; aux t2 - | Mul (t1,t2) -> aux t1; aux t2 - | Pow (t1,n) -> aux t1 - in aux t - -let string_of_term p = - let rec aux p = - match p with - | Zero -> "0" - | Const r -> string_of_num r - | Var v -> "x"^v - | Opp t1 -> "(-"^(aux t1)^")" - | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")" - | Sub (t1,t2) -> "("^(aux t1)^"-"^(aux t2)^")" - | Mul (t1,t2) -> "("^(aux t1)^"*"^(aux t2)^")" - | Pow (t1,n) -> (aux t1)^"^"^(string_of_int n) - in aux p - - -(*********************************************************************** - Coefficients: recursive polynomials - *) - -module Coef = BigInt -(*module Coef = Ent*) -module Poly = Polynom.Make(Coef) -module PIdeal = Ideal.Make(Poly) -open PIdeal - -(* term to sparse polynomial - varaibles <=np are in the coefficients -*) - -let term_pol_sparse np t= - let d = !nvars in - let rec aux t = -(* info ("conversion de: "^(string_of_term t)^"\n");*) - let res = - match t with - | Zero -> zeroP - | Const r -> - if Num.eq_num r num_0 - then zeroP - else polconst d (Poly.Pint (Coef.of_num r)) - | Var v -> - let v = int_of_string v in - if v <= np - then polconst d (Poly.x v) - else gen d v - | Opp t1 -> oppP (aux t1) - | Add (t1,t2) -> plusP (aux t1) (aux t2) - | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2)) - | Mul (t1,t2) -> multP (aux t1) (aux t2) - | Pow (t1,n) -> puisP (aux t1) n - in -(* info ("donne: "^(stringP res)^"\n");*) - res - in - let res= aux t in - res - -(* sparse polynomial to term *) - -let polrec_to_term p = - let rec aux p = - match p with - |Poly.Pint n -> const (Coef.to_num n) - |Poly.Prec (v,coefs) -> - let res = ref Zero in - Array.iteri - (fun i c -> - res:=add(!res, mul(aux c, - pow (Var (string_of_int v), - i)))) - coefs; - !res - in aux p - -(* approximation of the Horner form used in the tactic ring *) - -let pol_sparse_to_term n2 p = - (* info "pol_sparse_to_term ->\n";*) - let p = PIdeal.repr p in - let rec aux p = - match p with - [] -> const (num_of_string "0") - | (a,m)::p1 -> - let n = (Array.length m)-1 in - let (i0,e0) = - List.fold_left (fun (r,d) (a,m) -> - let i0= ref 0 in - for k=1 to n do - if m.(k)>0 - then i0:=k - done; - if Int.equal !i0 0 - then (r,d) - else if !i0 > r - then (!i0, m.(!i0)) - else if Int.equal !i0 r && m.(!i0) - if m.(i0)>=e0 - then (m.(i0)<-m.(i0)-e0; - p1:=(a,m)::(!p1)) - else p2:=(a,m)::(!p2)) - p; - let vm = - if Int.equal e0 1 - then Var (string_of_int (i0)) - else pow (Var (string_of_int (i0)),e0) in - add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2)))) - in (*info "-> pol_sparse_to_term\n";*) - aux p - - -let remove_list_tail l i = - let rec aux l i = - if List.is_empty l - then [] - else if i<0 - then l - else if Int.equal i 0 - then List.tl l - else - match l with - |(a::l1) -> - a::(aux l1 (i-1)) - |_ -> assert false - in - List.rev (aux (List.rev l) i) - -(* - lq = [cn+m+1 n+m ...cn+m+1 1] - lci=[[cn+1 n,...,cn1 1] - ... - [cn+m n+m-1,...,cn+m 1]] - - removes intermediate polynomials not useful to compute the last one. - *) - -let remove_zeros zero lci = - let n = List.length (List.hd lci) in - let m=List.length lci in - let u = Array.make m false in - let rec utiles k = - if k>=m - then () - else ( - u.(k)<-true; - let lc = List.nth lci k in - for i=0 to List.length lc - 1 do - if not (zero (List.nth lc i)) - then utiles (i+k+1); - done) - in utiles 0; - let lr = ref [] in - for i=0 to m-1 do - if u.(i) - then lr:=(List.nth lci i)::(!lr) - done; - let lr=List.rev !lr in - let lr = List.map - (fun lc -> - let lcr=ref lc in - for i=0 to m-1 do - if not u.(i) - then lcr:=remove_list_tail !lcr (m-i+(n-m)) - done; - !lcr) - lr in - info ("useless spolynomials: " - ^string_of_int (m-List.length lr)^"\n"); - info ("useful spolynomials: " - ^string_of_int (List.length lr)^"\n"); - lr - -let theoremedeszeros lpol p = - let t1 = Unix.gettimeofday() in - let m = !nvars in - let (lp0,p,cert) = in_ideal m lpol p in - let lpc = List.rev !poldepcontent in - info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1)); - (cert,lp0,p,lpc) - -open Ideal - -let theoremedeszeros_termes lp = - nvars:=0;(* mise a jour par term_pol_sparse *) - List.iter set_nvars_term lp; - match lp with - | Const (Int sugarparam)::Const (Int nparam)::lp -> - ((match sugarparam with - |0 -> info "computation without sugar\n"; - lexico:=false; - sugar_flag := false; - divide_rem_with_critical_pair := false - |1 -> info "computation with sugar\n"; - lexico:=false; - sugar_flag := true; - divide_rem_with_critical_pair := false - |2 -> info "ordre lexico computation without sugar\n"; - lexico:=true; - sugar_flag := false; - divide_rem_with_critical_pair := false - |3 -> info "ordre lexico computation with sugar\n"; - lexico:=true; - sugar_flag := true; - divide_rem_with_critical_pair := false - |4 -> info "computation without sugar, division by pairs\n"; - lexico:=false; - sugar_flag := false; - divide_rem_with_critical_pair := true - |5 -> info "computation with sugar, division by pairs\n"; - lexico:=false; - sugar_flag := true; - divide_rem_with_critical_pair := true - |6 -> info "ordre lexico computation without sugar, division by pairs\n"; - lexico:=true; - sugar_flag := false; - divide_rem_with_critical_pair := true - |7 -> info "ordre lexico computation with sugar, division by pairs\n"; - lexico:=true; - sugar_flag := true; - divide_rem_with_critical_pair := true - | _ -> error "nsatz: bad parameter" - ); - let m= !nvars in - let lvar=ref [] in - for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done; - lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *) - name_var:=!lvar; - let lp = List.map (term_pol_sparse nparam) lp in - match lp with - | [] -> assert false - | p::lp1 -> - let lpol = List.rev lp1 in - let (cert,lp0,p,_lct) = theoremedeszeros lpol p in - info "cert ok\n"; - let lc = cert.last_comb::List.rev cert.gb_comb in - match remove_zeros (fun x -> equal x zeroP) lc with - | [] -> assert false - | (lq::lci) -> - (* lci commence par les nouveaux polynomes *) - let m= !nvars in - let c = pol_sparse_to_term m (polconst m cert.coef) in - let r = Pow(Zero,cert.power) in - let lci = List.rev lci in - let lci = List.map (List.map (pol_sparse_to_term m)) lci in - let lq = List.map (pol_sparse_to_term m) lq in - info ("number of parametres: "^string_of_int nparam^"\n"); - info "term computed\n"; - (c,r,lci,lq) - ) - |_ -> assert false - - -(* version avec hash-consing du certificat: -let nsatz lpol = - Hashtbl.clear Dansideal.hmon; - Hashtbl.clear Dansideal.coefpoldep; - Hashtbl.clear Dansideal.sugartbl; - Hashtbl.clear Polynomesrec.hcontentP; - init_constants (); - let lp= parse_request lpol in - let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in - let certif = certificat_vers_polynome_creux rthz in - let certif = hash_certif certif in - let certif = certif_term certif in - let c = mkt_term c in - info "constr computed\n"; - (c, certif) -*) - -let nsatz lpol = - let lp= parse_request lpol in - let (c,r,lci,lq) = theoremedeszeros_termes lp in - let res = [c::r::lq]@lci in - let res = List.map (fun lx -> List.map mkt_term lx) res in - let res = - List.fold_right - (fun lt r -> - let ltterm = - List.fold_right - (fun t r -> - mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r]) - lt - (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in - mkt_app lcons [tlp ();ltterm;r]) - res - (mkt_app lnil [tlp ()]) in - info "term computed\n"; - res - -let return_term t = - let a = - mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in - generalize [a] - -let nsatz_compute t = - let lpol = - try nsatz t - with Ideal.NotInIdeal -> - error "nsatz cannot solve this problem" in - return_term lpol - -TACTIC EXTEND nsatz_compute -| [ "nsatz_compute" constr(lt) ] -> [ Proofview.V82.tactic (nsatz_compute lt) ] -END - - diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mllib index a25e649d0f..e991fb76f7 100644 --- a/plugins/nsatz/nsatz_plugin.mllib +++ b/plugins/nsatz/nsatz_plugin.mllib @@ -2,4 +2,5 @@ Utile Polynom Ideal Nsatz +G_nsatz Nsatz_plugin_mod -- cgit v1.2.3 From b18bc8d5fe64d395197b172b5574f03d50d8157d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 03:56:11 +0100 Subject: Removing useless grammar.cma dependencies. --- plugins/setoid_ring/newring.ml | 2 -- tactics/eauto.ml | 2 -- tactics/eqdecide.ml | 2 -- tactics/rewrite.ml | 2 -- tactics/tauto.ml | 2 -- 5 files changed, 10 deletions(-) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 37a8959767..7ef89b7a0e 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pp open Errors open Util diff --git a/tactics/eauto.ml b/tactics/eauto.ml index a118f2642f..0449467598 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pp open Errors open Util diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 7c821ddcb5..7d0df2f522 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -12,8 +12,6 @@ (* by Eduardo Gimenez *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Errors open Util open Names diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 9532354632..1be78c2add 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Names open Pp open Errors diff --git a/tactics/tauto.ml b/tactics/tauto.ml index 67ef25d49f..d3e0b1f449 100644 --- a/tactics/tauto.ml +++ b/tactics/tauto.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Term open Hipattern open Names -- cgit v1.2.3 From d3653c6da5770dfc4d439639b49193e30172763a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 15:10:27 +0100 Subject: Fixing bug #4610: Fails to build with camlp4 since the TACTIC EXTEND move. We just reuse the same one weird old trick in CAMLP4 to compare keywords and identifiers as tokens. Note though that the commit 982460743 does not fix the keyword vs. identifier issue in CAMLP4, so that the corresponding test fails. This means that since that commit, some code compiling with CAMLP5 does not when using CAMLP4, making it a second-class citizen. --- dev/printers.mllib | 2 +- grammar/grammar.mllib | 2 +- parsing/compat.ml4 | 2 +- parsing/tok.mli | 1 + 4 files changed, 4 insertions(+), 3 deletions(-) diff --git a/dev/printers.mllib b/dev/printers.mllib index 21868203f8..39e4b1cdb1 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -19,6 +19,7 @@ Pp_control Loc CList CString +Tok Compat Flags Control @@ -153,7 +154,6 @@ Library States Genprint -Tok Lexer Ppextend Pputils diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 4432f4306e..fc7cb392bf 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -49,8 +49,8 @@ Stdarg Constrarg Constrexpr_ops -Compat Tok +Compat Lexer Entry Pcoq diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 0e416fe32c..c482c694e1 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -276,7 +276,7 @@ ELSE module Gramext = G let stoken tok = match tok with | Tok.KEYWORD s -> Gramext.Skeyword s - | tok -> Gramext.Stoken ((=) tok, G.Token.to_string tok) + | tok -> Gramext.Stoken (Tok.equal tok, G.Token.to_string tok) END IFDEF CAMLP5_6_00 THEN diff --git a/parsing/tok.mli b/parsing/tok.mli index 416ce468e3..54b747952a 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -20,6 +20,7 @@ type t = | BULLET of string | EOI +val equal : t -> t -> bool val extract_string : t -> string val to_string : t -> string (* Needed to fit Camlp4 signature *) -- cgit v1.2.3 From 6ecbc9990a49a0dd51970c7fc8b13f39f02be773 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 18:34:39 +0100 Subject: Moving Ltac traces to Tacexpr and Tacinterp. --- dev/printers.mllib | 1 - intf/tacexpr.mli | 12 ++++++++++++ proofs/proof_type.ml | 52 --------------------------------------------------- proofs/proof_type.mli | 16 ---------------- proofs/proofs.mllib | 1 - tactics/tacinterp.ml | 2 ++ tactics/tacinterp.mli | 2 ++ tactics/tacsubst.ml | 2 ++ tactics/tacsubst.mli | 4 ++++ toplevel/cerrors.ml | 2 +- toplevel/himsg.ml | 22 +++++++++++----------- toplevel/himsg.mli | 2 +- 12 files changed, 35 insertions(+), 83 deletions(-) delete mode 100644 proofs/proof_type.ml diff --git a/dev/printers.mllib b/dev/printers.mllib index 39e4b1cdb1..34bde1ac27 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -174,7 +174,6 @@ Implicit_quantifiers Constrintern Modintern Constrextern -Proof_type Goal Miscprint Logic diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index f2a567c00d..b1dc174d4b 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -394,3 +394,15 @@ type tactic_arg = type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen + +(** Traces *) + +type ltac_call_kind = + | LtacMLCall of glob_tactic_expr + | LtacNotationCall of KerName.t + | LtacNameCall of ltac_constant + | LtacAtomCall of glob_atomic_tactic_expr + | LtacVarCall of Id.t * glob_tactic_expr + | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map + +type ltac_trace = (Loc.t * ltac_call_kind) list diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml deleted file mode 100644 index dd2c7b253d..0000000000 --- a/proofs/proof_type.ml +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* goal list sigma - -type prim_rule = - | Cut of bool * bool * Id.t * types - | FixRule of Id.t * int * (Id.t * int * constr) list * int - | Cofix of Id.t * (Id.t * constr) list * int - | Refine of constr - | Thin of Id.t list - | Move of Id.t * Id.t move_location - -(** Nowadays, the only rules we'll consider are the primitive rules *) - -type rule = prim_rule - -(** Ltac traces *) - -type ltac_call_kind = - | LtacMLCall of glob_tactic_expr - | LtacNotationCall of KerName.t - | LtacNameCall of ltac_constant - | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map - -type ltac_trace = (Loc.t * ltac_call_kind) list - -let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index aa05f58ab6..b4c9dae2a3 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -57,19 +57,3 @@ type rule = prim_rule type goal = Goal.goal type tactic = goal sigma -> goal list sigma - -(** Ltac traces *) - -(** TODO: Move those definitions somewhere sensible *) - -type ltac_call_kind = - | LtacMLCall of glob_tactic_expr - | LtacNotationCall of KerName.t - | LtacNameCall of ltac_constant - | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map - -type ltac_trace = (Loc.t * ltac_call_kind) list - -val ltac_trace_info : ltac_trace Exninfo.t diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 1bd701cb9b..47a637575f 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,7 +2,6 @@ Miscprint Goal Evar_refiner Proof_using -Proof_type Proof_errors Logic Proofview diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index bf5f9ddc86..82252610a8 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -44,6 +44,8 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration +let ltac_trace_info = Tacsubst.ltac_trace_info + let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> let Val.Dyn (t, _) = v in match Val.eq t (val_tag wit) with diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index c5da3494cb..31327873e9 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -14,6 +14,8 @@ open Genarg open Redexpr open Misctypes +val ltac_trace_info : ltac_trace Exninfo.t + module Value : sig type t = Val.t diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 55941c1ca6..17cb8ad19b 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -18,6 +18,8 @@ open Genredexpr open Patternops open Pretyping +let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () + (** Substitution of tactics at module closing time *) (** For generic arguments, we declare and store substitutions diff --git a/tactics/tacsubst.mli b/tactics/tacsubst.mli index c1bf272579..8b686c5cec 100644 --- a/tactics/tacsubst.mli +++ b/tactics/tacsubst.mli @@ -11,6 +11,10 @@ open Mod_subst open Genarg open Misctypes +(** TODO: Move those definitions somewhere sensible *) + +val ltac_trace_info : ltac_trace Exninfo.t + (** Substitution of tactics at module closing time *) val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 600683d359..91ef45393c 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -120,7 +120,7 @@ let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, let err = Errors.make_anomaly msg in Util.iraise (err, info) in - let ltac_trace = Exninfo.get info Proof_type.ltac_trace_info in + let ltac_trace = Exninfo.get info Tacsubst.ltac_trace_info in let loc = Option.default Loc.ghost (Loc.get_loc info) in match ltac_trace with | None -> e diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index de7ec61c81..1af09dd845 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -1247,9 +1247,9 @@ let explain_reduction_tactic_error = function let is_defined_ltac trace = let rec aux = function - | (_, Proof_type.LtacNameCall f) :: tail -> + | (_, Tacexpr.LtacNameCall f) :: tail -> not (Tacenv.is_ltac_for_ml_tactic f) - | (_, Proof_type.LtacAtomCall _) :: tail -> + | (_, Tacexpr.LtacAtomCall _) :: tail -> false | _ :: tail -> aux tail | [] -> false in @@ -1258,17 +1258,17 @@ let is_defined_ltac trace = let explain_ltac_call_trace last trace loc = let calls = last :: List.rev_map snd trace in let pr_call ck = match ck with - | Proof_type.LtacNotationCall kn -> quote (KerName.print kn) - | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) - | Proof_type.LtacMLCall t -> + | Tacexpr.LtacNotationCall kn -> quote (KerName.print kn) + | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Tacexpr.LtacMLCall t -> quote (Pptactic.pr_glob_tactic (Global.env()) t) - | Proof_type.LtacVarCall (id,t) -> + | Tacexpr.LtacVarCall (id,t) -> quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" - | Proof_type.LtacAtomCall te -> + | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) (Tacexpr.TacAtom (Loc.ghost,te))) - | Proof_type.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> + | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> quote (pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then strbrk " (with " ++ @@ -1282,7 +1282,7 @@ let explain_ltac_call_trace last trace loc = | [] -> mt () | _ -> let kind_of_last_call = match List.last calls with - | Proof_type.LtacConstrInterp _ -> ", last term evaluation failed." + | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." | _ -> ", last call failed." in hov 0 (str "In nested Ltac calls to " ++ @@ -1290,9 +1290,9 @@ let explain_ltac_call_trace last trace loc = let skip_extensions trace = let rec aux = function - | (_,Proof_type.LtacNameCall f as tac) :: _ + | (_,Tacexpr.LtacNameCall f as tac) :: _ when Tacenv.is_ltac_for_ml_tactic f -> [tac] - | (_,(Proof_type.LtacNotationCall _ | Proof_type.LtacMLCall _) as tac) + | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) :: _ -> [tac] | t :: tail -> t :: aux tail | [] -> [] in diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index 3ef98380b5..50bbd15c6d 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -37,7 +37,7 @@ val explain_reduction_tactic_error : Tacred.reduction_tactic_error -> std_ppcmds val extract_ltac_trace : - Proof_type.ltac_trace -> Loc.t -> std_ppcmds option * Loc.t + Tacexpr.ltac_trace -> Loc.t -> std_ppcmds option * Loc.t val explain_module_error : Modops.module_typing_error -> std_ppcmds -- cgit v1.2.3 From 9e96794d6a4327761ce1ff992351199919431be1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 19:01:38 +0100 Subject: Moving Tactic_debug to tactics/ folder. --- dev/printers.mllib | 2 +- printing/pptactic.ml | 11 -- printing/pptacticsig.mli | 5 + proofs/proofs.mllib | 1 - proofs/tactic_debug.ml | 319 --------------------------------------------- proofs/tactic_debug.mli | 79 ----------- tactics/tacinterp.ml | 15 ++- tactics/tacsubst.ml | 2 - tactics/tacsubst.mli | 4 - tactics/tactic_debug.ml | 324 ++++++++++++++++++++++++++++++++++++++++++++++ tactics/tactic_debug.mli | 77 +++++++++++ tactics/tactics.mllib | 1 + toplevel/cerrors.ml | 2 +- toplevel/vernacentries.ml | 12 -- 14 files changed, 423 insertions(+), 431 deletions(-) delete mode 100644 proofs/tactic_debug.ml delete mode 100644 proofs/tactic_debug.mli create mode 100644 tactics/tactic_debug.ml create mode 100644 tactics/tactic_debug.mli diff --git a/dev/printers.mllib b/dev/printers.mllib index 34bde1ac27..d8fb2b906c 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -187,13 +187,13 @@ Proofview Proof Proof_global Pfedit -Tactic_debug Decl_mode Ppconstr Entry Pcoq Printer Pptactic +Tactic_debug Ppdecl_proof Egramml Egramcoq diff --git a/printing/pptactic.ml b/printing/pptactic.ml index fdc1288aec..7d5e7772c3 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1415,17 +1415,6 @@ let () = let printer _ _ prtac = prtac (0, E) in declare_extra_genarg_pprule wit_tactic printer printer printer -let _ = Hook.set Tactic_debug.tactic_printer - (fun x -> pr_glob_tactic (Global.env()) x) - -let _ = Hook.set Tactic_debug.match_pattern_printer - (fun env sigma hyp -> pr_match_pattern (pr_constr_pattern_env env sigma) hyp) - -let _ = Hook.set Tactic_debug.match_rule_printer - (fun rl -> - pr_match_rule false (pr_glob_tactic (Global.env())) - (fun (_,p) -> pr_constr_pattern p) rl) - module Richpp = struct include Make (Ppconstr.Richpp) (struct diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index c5ec6bb092..b98b6c67e7 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -67,4 +67,9 @@ module type Pp = sig ('constr -> std_ppcmds) -> ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds + val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds + + val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('b, 'a) match_rule -> std_ppcmds + end diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 47a637575f..08556d62ec 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -11,6 +11,5 @@ Redexpr Refiner Tacmach Pfedit -Tactic_debug Clenv Clenvtac diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml deleted file mode 100644 index d33278ff8d..0000000000 --- a/proofs/tactic_debug.ml +++ /dev/null @@ -1,319 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mt()) - -let explain_logic_error_no_anomaly = ref (fun e -> mt()) - -let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) -let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) - -(* Prints the goal *) - -let db_pr_goal gl = - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let penv = print_named_context env in - let pc = print_constr_env env concl in - str" " ++ hv 0 (penv ++ fnl () ++ - str "============================" ++ fnl () ++ - str" " ++ pc) ++ fnl () - -let db_pr_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let pg = db_pr_goal gl in - Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end } - - -(* Prints the commands *) -let help () = - msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ - str " h/? = Help" ++ fnl() ++ - str " r = Run times" ++ fnl() ++ - str " r = Run up to next idtac " ++ fnl() ++ - str " s = Skip" ++ fnl() ++ - str " x = Exit") - -(* Prints the goal and the command to be executed *) -let goal_com tac = - Proofview.tclTHEN - db_pr_goal - (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ Hook.get prtac tac))) - -(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] - expressions. It avoids parametrizing everything over a - reference. *) -let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) - -let rec drop_spaces inst i = - if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) - else i - -let possibly_unquote s = - if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then - String.sub s 1 (String.length s - 2) - else - s - -(* (Re-)initialize debugger *) -let db_initialize = - let open Proofview.NonLogical in - (skip:=0) >> (skipped:=0) >> (breakpoint:=None) - -let int_of_string s = - try Proofview.NonLogical.return (int_of_string s) - with e -> Proofview.NonLogical.raise e - -let string_get s i = - try Proofview.NonLogical.return (String.get s i) - with e -> Proofview.NonLogical.raise e - -(* Gives the number of steps or next breakpoint of a run command *) -let run_com inst = - let open Proofview.NonLogical in - string_get inst 0 >>= fun first_char -> - if first_char ='r' then - let i = drop_spaces inst 1 in - if String.length inst > i then - let s = String.sub inst i (String.length inst - i) in - if inst.[0] >= '0' && inst.[0] <= '9' then - int_of_string s >>= fun num -> - (if num<0 then invalid_arg "run_com" else return ()) >> - (skip:=num) >> (skipped:=0) - else - breakpoint:=Some (possibly_unquote s) - else - invalid_arg "run_com" - else - invalid_arg "run_com" - -(* Prints the run counter *) -let run ini = - let open Proofview.NonLogical in - if not ini then - begin - Proofview.NonLogical.print_notice (str"\b\r\b\r") >> - !skipped >>= fun skipped -> - msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) - end >> - !skipped >>= fun x -> - skipped := x+1 - else - return () - -(* Prints the prompt *) -let rec prompt level = - (* spiwack: avoid overriding by the open below *) - let runtrue = run true in - begin - let open Proofview.NonLogical in - Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> - let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in - Proofview.NonLogical.catch Proofview.NonLogical.read_line - begin function (e, info) -> match e with - | End_of_file -> exit - | e -> raise ~info e - end - >>= fun inst -> - match inst with - | "" -> return (DebugOn (level+1)) - | "s" -> return (DebugOff) - | "x" -> Proofview.NonLogical.print_char '\b' >> exit - | "h"| "?" -> - begin - help () >> - prompt level - end - | _ -> - Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) - begin function (e, info) -> match e with - | Failure _ | Invalid_argument _ -> prompt level - | e -> raise ~info e - end - end - -(* Prints the state and waits for an instruction *) -(* spiwack: the only reason why we need to take the continuation [f] - as an argument rather than returning the new level directly seems to - be that [f] is wrapped in with "explain_logic_error". I don't think - it serves any purpose in the current design, so we could just drop - that. *) -let debug_prompt lev tac f = - (* spiwack: avoid overriding by the open below *) - let runfalse = run false in - let open Proofview.NonLogical in - let (>=) = Proofview.tclBIND in - (* What to print and to do next *) - let newlevel = - Proofview.tclLIFT !skip >= fun initial_skip -> - if Int.equal initial_skip 0 then - Proofview.tclLIFT !breakpoint >= fun breakpoint -> - if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) - else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) - else Proofview.tclLIFT begin - (!skip >>= fun s -> skip:=s-1) >> - runfalse >> - !skip >>= fun new_skip -> - (if Int.equal new_skip 0 then skipped:=0 else return ()) >> - return (DebugOn (lev+1)) - end in - newlevel >= fun newlevel -> - (* What to execute *) - Proofview.tclOR - (f newlevel) - begin fun (reraise, info) -> - Proofview.tclTHEN - (Proofview.tclLIFT begin - (skip:=0) >> (skipped:=0) >> - if Logic.catchable_exception reraise then - msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ Pervasives.(!) explain_logic_error reraise) - else return () - end) - (Proofview.tclZERO ~info reraise) - end - -let is_debug db = - let open Proofview.NonLogical in - !breakpoint >>= fun breakpoint -> - match db, breakpoint with - | DebugOff, _ -> return false - | _, Some _ -> return false - | _ -> - !skip >>= fun skip -> - return (Int.equal skip 0) - -(* Prints a constr *) -let db_constr debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) - else return () - -(* Prints the pattern rule *) -let db_pattern_rule debug num r = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ Hook.get prmatchrl r) - end - else return () - -(* Prints the hypothesis pattern identifier if it exists *) -let hyp_bound = function - | Anonymous -> str " (unbound)" - | Name id -> str " (bound to " ++ pr_id id ++ str ")" - -(* Prints a matched hypothesis *) -let db_matched_hyp debug env (id,_,c) ido = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ - str " has been matched: " ++ print_constr_env env c) - else return () - -(* Prints the matched conclusion *) -let db_matched_concl debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) - else return () - -(* Prints a success message when the goal has been matched *) -let db_mc_pattern_success debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ - str "Let us execute the right-hand side part..." ++ fnl()) - else return () - -(* Prints a failure message for an hypothesis pattern *) -let db_hyp_pattern_failure debug env sigma (na,hyp) = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ - str " cannot match: " ++ - Hook.get prmatchpatt env sigma hyp) - else return () - -(* Prints a matching failure message for a rule *) -let db_matching_failure debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ - str "Let us try the next one...") - else return () - -(* Prints an evaluation failure message for a rule *) -let db_eval_failure debug s = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - let s = str "message \"" ++ s ++ str "\"" in - msg_tac_debug - (str "This rule has failed due to \"Fail\" tactic (" ++ - s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") - else return () - -(* Prints a logic failure message for a rule *) -let db_logic_failure debug err = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (Pervasives.(!) explain_logic_error err) >> - msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ - str "Let us try the next one...") - end - else return () - -let is_breakpoint brkname s = match brkname, s with - | Some s, MsgString s'::_ -> String.equal s s' - | _ -> false - -let db_breakpoint debug s = - let open Proofview.NonLogical in - !breakpoint >>= fun opt_breakpoint -> - match debug with - | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> - breakpoint:=None - | _ -> - return () diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli deleted file mode 100644 index 215c5b29b5..0000000000 --- a/proofs/tactic_debug.mli +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds) Hook.t -val match_pattern_printer : - (env -> evar_map -> constr_pattern match_pattern -> Pp.std_ppcmds) Hook.t -val match_rule_printer : - ((Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) Hook.t - -(** Debug information *) -type debug_info = - | DebugOn of int - | DebugOff - -(** Prints the state and waits *) -val debug_prompt : - int -> glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic - -(** Initializes debugger *) -val db_initialize : unit Proofview.NonLogical.t - -(** Prints a constr *) -val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints the pattern rule *) -val db_pattern_rule : - debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t - -(** Prints a matched hypothesis *) -val db_matched_hyp : - debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t - -(** Prints the matched conclusion *) -val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints a success message when the goal has been matched *) -val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t - -(** Prints a failure message for an hypothesis pattern *) -val db_hyp_pattern_failure : - debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t - -(** Prints a matching failure message for a rule *) -val db_matching_failure : debug_info -> unit Proofview.NonLogical.t - -(** Prints an evaluation failure message for a rule *) -val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t - -(** An exception handler *) -val explain_logic_error: (exn -> Pp.std_ppcmds) ref - -(** For use in the Ltac debugger: some exception that are usually - consider anomalies are acceptable because they are caught later in - the process that is being debugged. One should not require - from users that they report these anomalies. *) -val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref - -(** Prints a logic failure message for a rule *) -val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t - -(** Prints a logic failure message for a rule *) -val db_breakpoint : debug_info -> - Id.t Loc.located message_token list -> unit Proofview.NonLogical.t diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 82252610a8..36a23d5809 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -44,7 +44,7 @@ open Sigma.Notations open Proofview.Notations open Context.Named.Declaration -let ltac_trace_info = Tacsubst.ltac_trace_info +let ltac_trace_info = Tactic_debug.ltac_trace_info let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> let Val.Dyn (t, _) = v in @@ -2201,3 +2201,16 @@ let lift_constr_tac_to_ml_tac vars tac = tac args ist end } in tac + +let vernac_debug b = + set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) + +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Ltac";"Debug"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 17cb8ad19b..55941c1ca6 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -18,8 +18,6 @@ open Genredexpr open Patternops open Pretyping -let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () - (** Substitution of tactics at module closing time *) (** For generic arguments, we declare and store substitutions diff --git a/tactics/tacsubst.mli b/tactics/tacsubst.mli index 8b686c5cec..c1bf272579 100644 --- a/tactics/tacsubst.mli +++ b/tactics/tacsubst.mli @@ -11,10 +11,6 @@ open Mod_subst open Genarg open Misctypes -(** TODO: Move those definitions somewhere sensible *) - -val ltac_trace_info : ltac_trace Exninfo.t - (** Substitution of tactics at module closing time *) val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr diff --git a/tactics/tactic_debug.ml b/tactics/tactic_debug.ml new file mode 100644 index 0000000000..b278c371b3 --- /dev/null +++ b/tactics/tactic_debug.ml @@ -0,0 +1,324 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Printer.pr_constr_pattern p) rl + +(* This module intends to be a beginning of debugger for tactic expressions. + Currently, it is quite simple and we can hope to have, in the future, a more + complete panel of commands dedicated to a proof assistant framework *) + +(* Debug information *) +type debug_info = + | DebugOn of int + | DebugOff + +(* An exception handler *) +let explain_logic_error = ref (fun e -> mt()) + +let explain_logic_error_no_anomaly = ref (fun e -> mt()) + +let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) + +(* Prints the goal *) + +let db_pr_goal gl = + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let penv = print_named_context env in + let pc = print_constr_env env concl in + str" " ++ hv 0 (penv ++ fnl () ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () + +let db_pr_goal = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let pg = db_pr_goal gl in + Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) + end } + + +(* Prints the commands *) +let help () = + msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ + str " h/? = Help" ++ fnl() ++ + str " r = Run times" ++ fnl() ++ + str " r = Run up to next idtac " ++ fnl() ++ + str " s = Skip" ++ fnl() ++ + str " x = Exit") + +(* Prints the goal and the command to be executed *) +let goal_com tac = + Proofview.tclTHEN + db_pr_goal + (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) + +(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] + expressions. It avoids parametrizing everything over a + reference. *) +let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) + +let rec drop_spaces inst i = + if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) + else i + +let possibly_unquote s = + if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then + String.sub s 1 (String.length s - 2) + else + s + +(* (Re-)initialize debugger *) +let db_initialize = + let open Proofview.NonLogical in + (skip:=0) >> (skipped:=0) >> (breakpoint:=None) + +let int_of_string s = + try Proofview.NonLogical.return (int_of_string s) + with e -> Proofview.NonLogical.raise e + +let string_get s i = + try Proofview.NonLogical.return (String.get s i) + with e -> Proofview.NonLogical.raise e + +(* Gives the number of steps or next breakpoint of a run command *) +let run_com inst = + let open Proofview.NonLogical in + string_get inst 0 >>= fun first_char -> + if first_char ='r' then + let i = drop_spaces inst 1 in + if String.length inst > i then + let s = String.sub inst i (String.length inst - i) in + if inst.[0] >= '0' && inst.[0] <= '9' then + int_of_string s >>= fun num -> + (if num<0 then invalid_arg "run_com" else return ()) >> + (skip:=num) >> (skipped:=0) + else + breakpoint:=Some (possibly_unquote s) + else + invalid_arg "run_com" + else + invalid_arg "run_com" + +(* Prints the run counter *) +let run ini = + let open Proofview.NonLogical in + if not ini then + begin + Proofview.NonLogical.print_notice (str"\b\r\b\r") >> + !skipped >>= fun skipped -> + msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) + end >> + !skipped >>= fun x -> + skipped := x+1 + else + return () + +(* Prints the prompt *) +let rec prompt level = + (* spiwack: avoid overriding by the open below *) + let runtrue = run true in + begin + let open Proofview.NonLogical in + Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> + let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in + Proofview.NonLogical.catch Proofview.NonLogical.read_line + begin function (e, info) -> match e with + | End_of_file -> exit + | e -> raise ~info e + end + >>= fun inst -> + match inst with + | "" -> return (DebugOn (level+1)) + | "s" -> return (DebugOff) + | "x" -> Proofview.NonLogical.print_char '\b' >> exit + | "h"| "?" -> + begin + help () >> + prompt level + end + | _ -> + Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) + begin function (e, info) -> match e with + | Failure _ | Invalid_argument _ -> prompt level + | e -> raise ~info e + end + end + +(* Prints the state and waits for an instruction *) +(* spiwack: the only reason why we need to take the continuation [f] + as an argument rather than returning the new level directly seems to + be that [f] is wrapped in with "explain_logic_error". I don't think + it serves any purpose in the current design, so we could just drop + that. *) +let debug_prompt lev tac f = + (* spiwack: avoid overriding by the open below *) + let runfalse = run false in + let open Proofview.NonLogical in + let (>=) = Proofview.tclBIND in + (* What to print and to do next *) + let newlevel = + Proofview.tclLIFT !skip >= fun initial_skip -> + if Int.equal initial_skip 0 then + Proofview.tclLIFT !breakpoint >= fun breakpoint -> + if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) + else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) + else Proofview.tclLIFT begin + (!skip >>= fun s -> skip:=s-1) >> + runfalse >> + !skip >>= fun new_skip -> + (if Int.equal new_skip 0 then skipped:=0 else return ()) >> + return (DebugOn (lev+1)) + end in + newlevel >= fun newlevel -> + (* What to execute *) + Proofview.tclOR + (f newlevel) + begin fun (reraise, info) -> + Proofview.tclTHEN + (Proofview.tclLIFT begin + (skip:=0) >> (skipped:=0) >> + if Logic.catchable_exception reraise then + msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ Pervasives.(!) explain_logic_error reraise) + else return () + end) + (Proofview.tclZERO ~info reraise) + end + +let is_debug db = + let open Proofview.NonLogical in + !breakpoint >>= fun breakpoint -> + match db, breakpoint with + | DebugOff, _ -> return false + | _, Some _ -> return false + | _ -> + !skip >>= fun skip -> + return (Int.equal skip 0) + +(* Prints a constr *) +let db_constr debug env c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) + else return () + +(* Prints the pattern rule *) +let db_pattern_rule debug num r = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ + str "|" ++ spc () ++ prmatchrl r) + end + else return () + +(* Prints the hypothesis pattern identifier if it exists *) +let hyp_bound = function + | Anonymous -> str " (unbound)" + | Name id -> str " (bound to " ++ pr_id id ++ str ")" + +(* Prints a matched hypothesis *) +let db_matched_hyp debug env (id,_,c) ido = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ + str " has been matched: " ++ print_constr_env env c) + else return () + +(* Prints the matched conclusion *) +let db_matched_concl debug env c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) + else return () + +(* Prints a success message when the goal has been matched *) +let db_mc_pattern_success debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ + str "Let us execute the right-hand side part..." ++ fnl()) + else return () + +(* Prints a failure message for an hypothesis pattern *) +let db_hyp_pattern_failure debug env sigma (na,hyp) = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ + str " cannot match: " ++ + prmatchpatt env sigma hyp) + else return () + +(* Prints a matching failure message for a rule *) +let db_matching_failure debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ + str "Let us try the next one...") + else return () + +(* Prints an evaluation failure message for a rule *) +let db_eval_failure debug s = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + let s = str "message \"" ++ s ++ str "\"" in + msg_tac_debug + (str "This rule has failed due to \"Fail\" tactic (" ++ + s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") + else return () + +(* Prints a logic failure message for a rule *) +let db_logic_failure debug err = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (Pervasives.(!) explain_logic_error err) >> + msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ + str "Let us try the next one...") + end + else return () + +let is_breakpoint brkname s = match brkname, s with + | Some s, MsgString s'::_ -> String.equal s s' + | _ -> false + +let db_breakpoint debug s = + let open Proofview.NonLogical in + !breakpoint >>= fun opt_breakpoint -> + match debug with + | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> + breakpoint:=None + | _ -> + return () diff --git a/tactics/tactic_debug.mli b/tactics/tactic_debug.mli new file mode 100644 index 0000000000..fbb7ab66db --- /dev/null +++ b/tactics/tactic_debug.mli @@ -0,0 +1,77 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic + +(** Initializes debugger *) +val db_initialize : unit Proofview.NonLogical.t + +(** Prints a constr *) +val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t + +(** Prints the pattern rule *) +val db_pattern_rule : + debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + +(** Prints a matched hypothesis *) +val db_matched_hyp : + debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t + +(** Prints the matched conclusion *) +val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t + +(** Prints a success message when the goal has been matched *) +val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t + +(** Prints a failure message for an hypothesis pattern *) +val db_hyp_pattern_failure : + debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t + +(** Prints a matching failure message for a rule *) +val db_matching_failure : debug_info -> unit Proofview.NonLogical.t + +(** Prints an evaluation failure message for a rule *) +val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t + +(** An exception handler *) +val explain_logic_error: (exn -> Pp.std_ppcmds) ref + +(** For use in the Ltac debugger: some exception that are usually + consider anomalies are acceptable because they are caught later in + the process that is being debugged. One should not require + from users that they report these anomalies. *) +val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref + +(** Prints a logic failure message for a rule *) +val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t + +(** Prints a logic failure message for a rule *) +val db_breakpoint : debug_info -> + Id.t Loc.located message_token list -> unit Proofview.NonLogical.t diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 2c5edc20ed..6246363173 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,3 +1,4 @@ +Tactic_debug Ftactic Geninterp Dnet diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 91ef45393c..b734f075ab 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -120,7 +120,7 @@ let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, let err = Errors.make_anomaly msg in Util.iraise (err, info) in - let ltac_trace = Exninfo.get info Tacsubst.ltac_trace_info in + let ltac_trace = Exninfo.get info Tactic_debug.ltac_trace_info in let loc = Option.default Loc.ghost (Loc.get_loc info) in match ltac_trace with | None -> e diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 38832b422f..d769c60332 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1433,18 +1433,6 @@ let _ = optread = Flags.get_dump_bytecode; optwrite = Flags.set_dump_bytecode } -let vernac_debug b = - set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) - -let _ = - declare_bool_option - { optsync = false; - optdepr = false; - optname = "Ltac debug"; - optkey = ["Ltac";"Debug"]; - optread = (fun () -> get_debug () != Tactic_debug.DebugOff); - optwrite = vernac_debug } - let _ = declare_bool_option { optsync = true; -- cgit v1.2.3 From 6f49db55e525a57378ca5600476c870a98a59dae Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 19:38:14 +0100 Subject: Removing dependency of Himsg in tactic files. --- tactics/tacenv.ml | 2 ++ tactics/tactic_debug.ml | 78 ++++++++++++++++++++++++++++++++++++++++++++++++ tactics/tactic_debug.mli | 5 ++++ toplevel/cerrors.ml | 2 +- toplevel/himsg.ml | 74 --------------------------------------------- toplevel/himsg.mli | 3 -- 6 files changed, 86 insertions(+), 78 deletions(-) diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index d2d3f3117f..cc87e197d1 100644 --- a/tactics/tacenv.ml +++ b/tactics/tacenv.ml @@ -143,3 +143,5 @@ let register_ltac for_ml local id tac = let redefine_ltac local kn tac = Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) + +let () = Hook.set Tactic_debug.is_ltac_for_ml_tactic_hook is_ltac_for_ml_tactic diff --git a/tactics/tactic_debug.ml b/tactics/tactic_debug.ml index b278c371b3..fa40b74160 100644 --- a/tactics/tactic_debug.ml +++ b/tactics/tactic_debug.ml @@ -322,3 +322,81 @@ let db_breakpoint debug s = breakpoint:=None | _ -> return () + +(** Extrating traces *) + +let (is_for_ml_f, is_ltac_for_ml_tactic_hook) = Hook.make () + +let is_defined_ltac trace = + let rec aux = function + | (_, Tacexpr.LtacNameCall f) :: tail -> + not (Hook.get is_for_ml_f f) + | (_, Tacexpr.LtacAtomCall _) :: tail -> + false + | _ :: tail -> aux tail + | [] -> false in + aux (List.rev trace) + +let explain_ltac_call_trace last trace loc = + let calls = last :: List.rev_map snd trace in + let pr_call ck = match ck with + | Tacexpr.LtacNotationCall kn -> quote (KerName.print kn) + | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Tacexpr.LtacMLCall t -> + quote (Pptactic.pr_glob_tactic (Global.env()) t) + | Tacexpr.LtacVarCall (id,t) -> + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + | Tacexpr.LtacAtomCall te -> + quote (Pptactic.pr_glob_tactic (Global.env()) + (Tacexpr.TacAtom (Loc.ghost,te))) + | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> + quote (Printer.pr_glob_constr_env (Global.env()) c) ++ + (if not (Id.Map.is_empty vars) then + strbrk " (with " ++ + prlist_with_sep pr_comma + (fun (id,c) -> + pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + (List.rev (Id.Map.bindings vars)) ++ str ")" + else mt()) + in + match calls with + | [] -> mt () + | _ -> + let kind_of_last_call = match List.last calls with + | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." + | _ -> ", last call failed." + in + hov 0 (str "In nested Ltac calls to " ++ + pr_enum pr_call calls ++ strbrk kind_of_last_call) + +let skip_extensions trace = + let rec aux = function + | (_,Tacexpr.LtacNameCall f as tac) :: _ + when Hook.get is_for_ml_f f -> [tac] + | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) + :: _ -> [tac] + | t :: tail -> t :: aux tail + | [] -> [] in + List.rev (aux (List.rev trace)) + +let extract_ltac_trace trace eloc = + let trace = skip_extensions trace in + let (loc,c),tail = List.sep_last trace in + if is_defined_ltac trace then + (* We entered a user-defined tactic, + we display the trace with location of the call *) + let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in + Some msg, loc + else + (* We entered a primitive tactic, we don't display trace but + report on the finest location *) + let best_loc = + if not (Loc.is_ghost eloc) then eloc else + (* trace is with innermost call coming first *) + let rec aux = function + | (loc,_)::tail when not (Loc.is_ghost loc) -> loc + | _::tail -> aux tail + | [] -> Loc.ghost in + aux trace in + None, best_loc diff --git a/tactics/tactic_debug.mli b/tactics/tactic_debug.mli index fbb7ab66db..a3b519a712 100644 --- a/tactics/tactic_debug.mli +++ b/tactics/tactic_debug.mli @@ -75,3 +75,8 @@ val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> Id.t Loc.located message_token list -> unit Proofview.NonLogical.t + +val extract_ltac_trace : + Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t + +val is_ltac_for_ml_tactic_hook : (KerName.t -> bool) Hook.t diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index b734f075ab..0b8edd91c1 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -126,7 +126,7 @@ let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, | None -> e | Some trace -> let (e, info) = e in - match Himsg.extract_ltac_trace trace loc with + match Tactic_debug.extract_ltac_trace trace loc with | None, loc -> (e, Loc.add_loc info loc) | Some msg, loc -> (EvaluatedError (msg, Some e), Loc.add_loc info loc) diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 1af09dd845..4ee1537c20 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -1244,77 +1244,3 @@ let explain_reduction_tactic_error = function quote (pr_goal_concl_style_env env sigma c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' Evd.empty e - -let is_defined_ltac trace = - let rec aux = function - | (_, Tacexpr.LtacNameCall f) :: tail -> - not (Tacenv.is_ltac_for_ml_tactic f) - | (_, Tacexpr.LtacAtomCall _) :: tail -> - false - | _ :: tail -> aux tail - | [] -> false in - aux (List.rev trace) - -let explain_ltac_call_trace last trace loc = - let calls = last :: List.rev_map snd trace in - let pr_call ck = match ck with - | Tacexpr.LtacNotationCall kn -> quote (KerName.print kn) - | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) - | Tacexpr.LtacMLCall t -> - quote (Pptactic.pr_glob_tactic (Global.env()) t) - | Tacexpr.LtacVarCall (id,t) -> - quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ - Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" - | Tacexpr.LtacAtomCall te -> - quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.ghost,te))) - | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> - quote (pr_glob_constr_env (Global.env()) c) ++ - (if not (Id.Map.is_empty vars) then - strbrk " (with " ++ - prlist_with_sep pr_comma - (fun (id,c) -> - pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) - (List.rev (Id.Map.bindings vars)) ++ str ")" - else mt()) - in - match calls with - | [] -> mt () - | _ -> - let kind_of_last_call = match List.last calls with - | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." - | _ -> ", last call failed." - in - hov 0 (str "In nested Ltac calls to " ++ - pr_enum pr_call calls ++ strbrk kind_of_last_call) - -let skip_extensions trace = - let rec aux = function - | (_,Tacexpr.LtacNameCall f as tac) :: _ - when Tacenv.is_ltac_for_ml_tactic f -> [tac] - | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) - :: _ -> [tac] - | t :: tail -> t :: aux tail - | [] -> [] in - List.rev (aux (List.rev trace)) - -let extract_ltac_trace trace eloc = - let trace = skip_extensions trace in - let (loc,c),tail = List.sep_last trace in - if is_defined_ltac trace then - (* We entered a user-defined tactic, - we display the trace with location of the call *) - let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in - Some msg, loc - else - (* We entered a primitive tactic, we don't display trace but - report on the finest location *) - let best_loc = - if not (Loc.is_ghost eloc) then eloc else - (* trace is with innermost call coming first *) - let rec aux = function - | (loc,_)::tail when not (Loc.is_ghost loc) -> loc - | _::tail -> aux tail - | [] -> Loc.ghost in - aux trace in - None, best_loc diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index 50bbd15c6d..ced54fd279 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -36,9 +36,6 @@ val explain_pattern_matching_error : val explain_reduction_tactic_error : Tacred.reduction_tactic_error -> std_ppcmds -val extract_ltac_trace : - Tacexpr.ltac_trace -> Loc.t -> std_ppcmds option * Loc.t - val explain_module_error : Modops.module_typing_error -> std_ppcmds val explain_module_internalization_error : -- cgit v1.2.3 From cdc91f02f98b4d857bfebe61d95b920787a8d0e5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 21:25:20 +0100 Subject: Putting Tactic_debug just below Tacinterp. --- dev/printers.mllib | 2 +- tactics/ftactic.ml | 2 -- tactics/ftactic.mli | 5 ----- tactics/tacenv.ml | 2 -- tactics/tacinterp.ml | 2 +- tactics/tactic_debug.ml | 6 ++---- tactics/tactic_debug.mli | 2 -- tactics/tactics.mllib | 2 +- 8 files changed, 5 insertions(+), 18 deletions(-) diff --git a/dev/printers.mllib b/dev/printers.mllib index d8fb2b906c..7710033dba 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -193,12 +193,12 @@ Entry Pcoq Printer Pptactic -Tactic_debug Ppdecl_proof Egramml Egramcoq Tacsubst Tacenv +Tactic_debug Trie Dn Btermdn diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml index 55463afd01..588709873e 100644 --- a/tactics/ftactic.ml +++ b/tactics/ftactic.ml @@ -99,8 +99,6 @@ end module Ftac = Monad.Make(Self) module List = Ftac.List -let debug_prompt = Tactic_debug.debug_prompt - module Notations = struct let (>>=) = bind diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli index fd05a44698..19041f1698 100644 --- a/tactics/ftactic.mli +++ b/tactics/ftactic.mli @@ -70,11 +70,6 @@ val (<*>) : unit t -> 'a t -> 'a t module List : Monad.ListS with type 'a t := 'a t -(** {5 Debug} *) - -val debug_prompt : - int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t - (** {5 Notations} *) module Notations : diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index cc87e197d1..d2d3f3117f 100644 --- a/tactics/tacenv.ml +++ b/tactics/tacenv.ml @@ -143,5 +143,3 @@ let register_ltac for_ml local id tac = let redefine_ltac local kn tac = Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) - -let () = Hook.set Tactic_debug.is_ltac_for_ml_tactic_hook is_ltac_for_ml_tactic diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 36a23d5809..32f7c3c61c 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1202,7 +1202,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti let ist = { ist with extra = TacStore.set ist.extra f_debug v } in value_interp ist >>= fun v -> return (name_vfun appl v) in - Ftactic.debug_prompt lev tac eval + Tactic_debug.debug_prompt lev tac eval | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) diff --git a/tactics/tactic_debug.ml b/tactics/tactic_debug.ml index fa40b74160..e991eb86dc 100644 --- a/tactics/tactic_debug.ml +++ b/tactics/tactic_debug.ml @@ -325,12 +325,10 @@ let db_breakpoint debug s = (** Extrating traces *) -let (is_for_ml_f, is_ltac_for_ml_tactic_hook) = Hook.make () - let is_defined_ltac trace = let rec aux = function | (_, Tacexpr.LtacNameCall f) :: tail -> - not (Hook.get is_for_ml_f f) + not (Tacenv.is_ltac_for_ml_tactic f) | (_, Tacexpr.LtacAtomCall _) :: tail -> false | _ :: tail -> aux tail @@ -373,7 +371,7 @@ let explain_ltac_call_trace last trace loc = let skip_extensions trace = let rec aux = function | (_,Tacexpr.LtacNameCall f as tac) :: _ - when Hook.get is_for_ml_f f -> [tac] + when Tacenv.is_ltac_for_ml_tactic f -> [tac] | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) :: _ -> [tac] | t :: tail -> t :: aux tail diff --git a/tactics/tactic_debug.mli b/tactics/tactic_debug.mli index a3b519a712..523398e75a 100644 --- a/tactics/tactic_debug.mli +++ b/tactics/tactic_debug.mli @@ -78,5 +78,3 @@ val db_breakpoint : debug_info -> val extract_ltac_trace : Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t - -val is_ltac_for_ml_tactic_hook : (KerName.t -> bool) Hook.t diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 6246363173..eebac88fba 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,4 +1,3 @@ -Tactic_debug Ftactic Geninterp Dnet @@ -22,6 +21,7 @@ Hints Auto Tacintern Tactic_matching +Tactic_debug Tacinterp Evar_tactics Term_dnet -- cgit v1.2.3 From ffac73b8f3f3bf6877ce652eecac7849b7c2a182 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 23:00:58 +0100 Subject: Moving Autorewrite to Hightatctic. --- intf/vernacexpr.mli | 1 - parsing/g_vernac.ml4 | 1 - printing/ppvernac.ml | 2 -- tactics/g_rewrite.ml4 | 4 ++++ tactics/hightactics.mllib | 1 + tactics/tactics.mllib | 1 - toplevel/vernacentries.ml | 1 - 7 files changed, 5 insertions(+), 6 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 7273b92b9a..5501ca7c7f 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -69,7 +69,6 @@ type printable = | PrintHint of reference or_by_notation | PrintHintGoal | PrintHintDbName of string - | PrintRewriteHintDbName of string | PrintHintDb | PrintScopes | PrintScope of string diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index b5e9f9e067..49baeb5560 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -951,7 +951,6 @@ GEXTEND Gram | IDENT "Hint"; qid = smart_global -> PrintHint qid | IDENT "Hint"; "*" -> PrintHintDb | IDENT "HintDb"; s = IDENT -> PrintHintDbName s - | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s | IDENT "Scopes" -> PrintScopes | IDENT "Scope"; s = IDENT -> PrintScope s | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index ffec926a84..a101540aba 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -486,8 +486,6 @@ module Make keyword "Print Hint *" | PrintHintDbName s -> keyword "Print HintDb" ++ spc () ++ str s - | PrintRewriteHintDbName s -> - keyword "Print Rewrite HintDb" ++ spc() ++ str s | PrintUniverses (b, fopt) -> let cmd = if b then "Print Sorted Universes" diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 index 72cfb01a57..6b6dc7b21a 100644 --- a/tactics/g_rewrite.ml4 +++ b/tactics/g_rewrite.ml4 @@ -261,3 +261,7 @@ TACTIC EXTEND setoid_transitivity [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] | [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] END + +VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY + [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Pp.msg_notice (Autorewrite.print_rewrite_hintdb s) ] +END diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 0d73cc27aa..73f11d0be0 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,5 +1,6 @@ Extraargs Coretactics +Autorewrite Extratactics Eauto G_auto diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index eebac88fba..fd7fab0c58 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -25,5 +25,4 @@ Tactic_debug Tacinterp Evar_tactics Term_dnet -Autorewrite Tactic_option diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index d769c60332..c63dac3026 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1629,7 +1629,6 @@ let vernac_print = function | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s) - | PrintRewriteHintDbName s -> msg_notice (Autorewrite.print_rewrite_hintdb s) | PrintHintDb -> msg_notice (Hints.pr_searchtable ()) | PrintScopes -> msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) -- cgit v1.2.3 From a9f6f401e66c0bbf0c50801d597cd18097bf91a6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Mar 2016 23:15:43 +0100 Subject: Expurging grammar.mllib from uselessly linked modules. --- grammar/grammar.mllib | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index fc7cb392bf..296d32dc04 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -29,35 +29,22 @@ CStack Util Ppstyle Errors -Bigint Predicate Segmenttree Unicodetable Unicode Genarg -Evar Names -Libnames - -Redops -Miscops -Locusops - Stdarg Constrarg -Constrexpr_ops Tok Compat Lexer Entry Pcoq -G_prim -G_tactic -G_ltac -G_constr Q_util Egramml -- cgit v1.2.3 From 2f41c0280685615aae03efcdfd1d39941e7c1232 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 7 Mar 2016 09:29:29 +0100 Subject: Re-enable OCaml warnings disabled by mistake as part of e759333. --- Makefile.build | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.build b/Makefile.build index 48f448ce8a..0f85608f9a 100644 --- a/Makefile.build +++ b/Makefile.build @@ -69,7 +69,7 @@ TIMED= # non-empty will activate a default time command TIMECMD= # if you prefer a specific time command instead of $(STDTIME) # e.g. "'time -p'" -CAMLFLAGS:=${CAMLFLAGS} -w -3 + # NB: if you want to collect compilation timings of .v and import them # in a spreadsheet, I suggest something like: # make TIMED=1 2> timings.csv -- cgit v1.2.3 From d34a2ff176c75ea404f7eb638b6eea3ca07ab978 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Mar 2016 21:35:33 +0100 Subject: Adding backtraces to scheme error messages. --- toplevel/indschemes.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index c4ac0e4112..aa2362ae5f 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -150,12 +150,14 @@ let alarm what internal msg = | InternalTacticRequest -> (if debug then msg_warning - (hov 0 msg ++ fnl () ++ what ++ str " not defined.")) - | _ -> errorlabstrm "" msg + (hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None + | _ -> Some msg let try_declare_scheme what f internal names kn = try f internal names kn - with + with e -> + let e = Errors.push e in + let msg = match fst e with | ParameterWithoutEquality cst -> alarm what internal (str "Boolean equality not found for parameter " ++ pr_con cst ++ @@ -186,6 +188,11 @@ let try_declare_scheme what f internal names kn = | e when Errors.noncritical e -> alarm what internal (str "Unexpected error during scheme creation: " ++ Errors.print e) + | _ -> iraise e + in + match msg with + | None -> () + | Some msg -> iraise (UserError ("", msg), snd e) let beq_scheme_msg mind = let mib = Global.lookup_mind mind in -- cgit v1.2.3 From a5ae3b2856e6cc6683652a0abb5a84b9787527c0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 9 Mar 2016 15:15:38 +0100 Subject: Fix strategy of Keyed Unification Try first to find a keyed subterm without conversion/betaiota on open terms (that is the usual strategy of rewrite), if this fails, try with full conversion, incuding betaiota. This makes the test-suite pass again, retaining efficiency in the most common cases. --- pretyping/unification.ml | 30 +- tactics/equality.ml | 2 +- test-suite/bugs/closed/4544.v | 1007 +++++++++++++++++++++++++++++++++++++ test-suite/success/keyedrewrite.v | 3 +- 4 files changed, 1037 insertions(+), 5 deletions(-) create mode 100644 test-suite/bugs/closed/4544.v diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 55210d067e..31fd711bf9 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -356,6 +356,22 @@ let set_no_delta_flags flags = { resolve_evars = flags.resolve_evars } +(* For the first phase of keyed unification, restrict + to conversion (including beta-iota) only on closed terms *) +let set_no_delta_open_core_flags flags = { flags with + modulo_delta = empty_transparent_state; + modulo_betaiota = false; +} + +let set_no_delta_open_flags flags = { + core_unify_flags = set_no_delta_open_core_flags flags.core_unify_flags; + merge_unify_flags = set_no_delta_open_core_flags flags.merge_unify_flags; + subterm_unify_flags = set_no_delta_open_core_flags flags.subterm_unify_flags; + allow_K_in_toplevel_higher_order_unification = + flags.allow_K_in_toplevel_higher_order_unification; + resolve_evars = flags.resolve_evars +} + (* Default flag for the "simple apply" version of unification of a *) (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extended *) @@ -1790,17 +1806,25 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = let allow_K = flags.allow_K_in_toplevel_higher_order_unification in let flags = if occur_meta_or_existential op || !keyed_unification then + (* This is up to delta for subterms w/o metas ... *) flags else (* up to Nov 2014, unification was bypassed on evar/meta-free terms; now it is called in a minimalistic way, at least to possibly unify pre-existing non frozen evars of the goal or of the pattern *) - set_no_delta_flags flags in + set_no_delta_flags flags in + let t' = (strip_outer_cast op,t) in let (evd',cl) = try - (* This is up to delta for subterms w/o metas ... *) - w_unify_to_subterm env evd ~flags (strip_outer_cast op,t) + if is_keyed_unification () then + try (* First try finding a subterm w/o conversion on open terms *) + let flags = set_no_delta_open_flags flags in + w_unify_to_subterm env evd ~flags t' + with e -> + (* If this fails, try with full conversion *) + w_unify_to_subterm env evd ~flags t' + else w_unify_to_subterm env evd ~flags t' with PretypeError (env,_,NoOccurrenceFound _) when allow_K || (* w_unify_to_subterm does not go through evars, so diff --git a/tactics/equality.ml b/tactics/equality.ml index 80f6038cb7..f72a72f46d 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -228,7 +228,7 @@ let rewrite_keyed_core_unif_flags = { (* This is set dynamically *) restrict_conv_on_strict_subterms = false; - modulo_betaiota = false; + modulo_betaiota = true; modulo_eta = true; } diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v new file mode 100644 index 0000000000..d14cc86fc7 --- /dev/null +++ b/test-suite/bugs/closed/4544.v @@ -0,0 +1,1007 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_oog_looping_rewrite_01") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 + coqtop version 8.5 (January 2016) *) +Inductive False := . +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Coq.Init.Datatypes. + +Import Coq.Init.Notations. + +Global Set Universe Polymorphism. + +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Global Set Primitive Projections. + +Inductive sum (A B : Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. +Notation nat := Coq.Init.Datatypes.nat. +Notation S := Coq.Init.Datatypes.S. +Notation "x + y" := (sum x y) : type_scope. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. + +Notation "x * y" := (prod x y) : type_scope. +Module Export Specif. + +Set Implicit Arguments. + +Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }. +Arguments proj1_sig {A P} _ / . + +Notation sigT := sig (only parsing). +Notation existT := exist (only parsing). + +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + +Notation projT1 := proj1_sig (only parsing). +Notation projT2 := proj2_sig (only parsing). + +End Specif. +Module Export HoTT_DOT_Basics_DOT_Overture. +Module Export HoTT. +Module Export Basics. +Module Export Overture. + +Global Set Keyed Unification. + +Global Unset Strict Universe Declaration. + +Notation Type0 := Set. + +Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. + +Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in Type@{i}. + +Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in + let ge := ((fun x => x) : Type1@{j} -> Type@{i}) in Type@{i}. + +Notation idmap := (fun x => x). +Delimit Scope function_scope with function. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Delimit Scope trunc_scope with trunc. + +Open Scope trunc_scope. +Open Scope path_scope. +Open Scope fibration_scope. +Open Scope nat_scope. +Open Scope function_scope. + +Notation "( x ; y )" := (existT _ x y) : fibration_scope. + +Notation pr1 := projT1. +Notation pr2 := projT2. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + +Notation compose := (fun g f x => g (f x)). + +Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope. + +Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B}%type_scope f%function_scope {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun : A -> B ; + equiv_isequiv : IsEquiv equiv_fun +}. + +Coercion equiv_fun : Equiv >-> Funclass. + +Global Existing Instance equiv_isequiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Arguments center A {_}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : trunc_scope. +Notation "0" := (-1.+1) : trunc_scope. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Global Instance istrunc_paths (A : Type) n `{H : IsTrunc n.+1 A} (x y : A) +: IsTrunc n (x = y) + := H x y. + +Notation Contr := (IsTrunc -2). +Notation IsHProp := (IsTrunc -1). + +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +Inductive Unit : Type1 := + tt : Unit. + +Class IsPointed (A : Type) := point : A. + +Arguments point A {_}. + +Record pType := + { pointed_type : Type ; + ispointed_type : IsPointed pointed_type }. + +Coercion pointed_type : pType >-> Sortclass. + +Global Existing Instance ispointed_type. + +Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. + +Ltac revert_opaque x := + revert x; + match goal with + | [ |- forall _, _ ] => idtac + | _ => fail 1 "Reverted constant is not an opaque variable" + end. + +End Overture. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Overture. +Module Export HoTT_DOT_Basics_DOT_PathGroupoids. +Module Export HoTT. +Module Export Basics. +Module Export PathGroupoids. + +Local Open Scope path_scope. + +Definition concat_p1 {A : Type} {x y : A} (p : x = y) : + p @ 1 = p + := + match p with idpath => 1 end. + +Definition concat_1p {A : Type} {x y : A} (p : x = y) : + 1 @ p = p + := + match p with idpath => 1 end. + +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + (p @ q) @ r = p @ (q @ r) := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pV {A : Type} {x y : A} (p : x = y) : + p @ p^ = 1 + := + match p with idpath => 1 end. + +Definition moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : + p = r @ q -> r^ @ p = q. +admit. +Defined. + +Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : + r @ q = p -> q = r^ @ p. +admit. +Defined. + +Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) : + 1 = p^ @ q -> p = q. +admit. +Defined. + +Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) : + ap f (p @ q) = (ap f p) @ (ap f q) + := + match q with + idpath => + match p with idpath => 1 end + end. + +Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) : + ap f (p^) = (ap f p)^ + := + match p with idpath => 1 end. + +Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : + ap (g o f) p = ap g (ap f p) + := + match p with idpath => 1 end. + +Definition concat_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) : + (p x) @ (ap f q) = q @ (p y) + := + match q as i in (_ = y) return (p x @ ap f i = i @ p y) with + | idpath => concat_p1 _ @ (concat_1p _)^ + end. + +End PathGroupoids. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_PathGroupoids. +Module Export HoTT_DOT_Basics_DOT_Equivalences. +Module Export HoTT. +Module Export Basics. +Module Export Equivalences. + +Definition isequiv_commsq {A B C D} + (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D) + (p : k o f == g o h) + `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k} +: IsEquiv g. +admit. +Defined. + +Section Adjointify. + + Context {A B : Type} (f : A -> B) (g : B -> A). + Context (isretr : Sect g f) (issect : Sect f g). + + Let issect' := fun x => + ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x. + + Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a). + Proof. + unfold issect'. + apply moveR_M1. + repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose. + rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)). + repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1. + rewrite concat_p_pp, <- ap_compose. + rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))). + rewrite concat_pV, concat_1p; reflexivity. + Qed. + + Definition isequiv_adjointify : IsEquiv f + := BuildIsEquiv A B f g isretr issect' is_adjoint'. + +End Adjointify. + +End Equivalences. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Equivalences. +Module Export HoTT_DOT_Basics_DOT_Trunc. +Module Export HoTT. +Module Export Basics. +Module Export Trunc. +Generalizable Variables A B m n f. + +Definition trunc_equiv A {B} (f : A -> B) + `{IsTrunc n A} `{IsEquiv A B f} + : IsTrunc n B. +admit. +Defined. + +Record TruncType (n : trunc_index) := BuildTruncType { + trunctype_type : Type ; + istrunc_trunctype_type : IsTrunc n trunctype_type +}. + +Arguments BuildTruncType _ _ {_}. + +Coercion trunctype_type : TruncType >-> Sortclass. + +Notation "n -Type" := (TruncType n) (at level 1) : type_scope. +Notation hProp := (-1)-Type. + +Notation BuildhProp := (BuildTruncType -1). + +End Trunc. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Trunc. +Module Export HoTT_DOT_Types_DOT_Unit. +Module Export HoTT. +Module Export Types. +Module Export Unit. + +Notation unit_name x := (fun (_ : Unit) => x). + +End Unit. + +End Types. + +End HoTT. + +End HoTT_DOT_Types_DOT_Unit. +Module Export HoTT_DOT_Types_DOT_Sigma. +Module Export HoTT. +Module Export Types. +Module Export Sigma. +Local Open Scope path_scope. + +Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : {p : u.1 = v.1 & p # u.2 = v.2}) +: u = v + := match pq.2 in (_ = v2) return u = (v.1; v2) with + | 1 => match pq.1 as p in (_ = v1) return u = (v1; p # u.2) with + | 1 => 1 + end + end. + +Definition path_sigma {A : Type} (P : A -> Type) (u v : sigT P) + (p : u.1 = v.1) (q : p # u.2 = v.2) +: u = v + := path_sigma_uncurried P u v (p;q). + +Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'} + (p : x = x') (q : p # y = y') +: (x;y) = (x';y') + := path_sigma P (x;y) (x';y') p q. + +Global Instance isequiv_pr1_contr {A} {P : A -> Type} + `{forall a, Contr (P a)} +: IsEquiv (@pr1 A P) | 100. +Proof. + refine (isequiv_adjointify (@pr1 A P) + (fun a => (a ; center (P a))) _ _). + - + intros a; reflexivity. + - + intros [a p]. + refine (path_sigma' P 1 (contr _)). +Defined. + +Definition path_sigma_hprop {A : Type} {P : A -> Type} + `{forall x, IsHProp (P x)} + (u v : sigT P) +: u.1 = v.1 -> u = v + := path_sigma_uncurried P u v o pr1^-1. + +End Sigma. + +End Types. + +End HoTT. + +End HoTT_DOT_Types_DOT_Sigma. +Module Export HoTT_DOT_Extensions. +Module Export HoTT. +Module Export Extensions. + +Section Extensions. + + Definition ExtensionAlong {A B : Type} (f : A -> B) + (P : B -> Type) (d : forall x:A, P (f x)) + := { s : forall y:B, P y & forall x:A, s (f x) = d x }. + + Fixpoint ExtendableAlong@{i j k l} + (n : nat) {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := match n with + | 0 => Unit@{l} + | S n => (forall (g : forall a, C (f a)), + ExtensionAlong@{i j k l l} f C g) * + forall (h k : forall b, C b), + ExtendableAlong n f (fun b => h b = k b) + end. + + Definition ooExtendableAlong@{i j k l} + {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := forall n, ExtendableAlong@{i j k l} n f C. + +End Extensions. + +End Extensions. + +End HoTT. + +End HoTT_DOT_Extensions. +Module Export HoTT. +Module Export Modalities. +Module Export ReflectiveSubuniverse. + +Module Type ReflectiveSubuniverses. + + Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + + let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In@{u a j} O U. + + Parameter hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). + + Parameter extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). + +End ReflectiveSubuniverses. + +Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses). +Export Os. + +Module Export Coercions. + + Coercion O_reflector : ReflectiveSubuniverse >-> Funclass. + +End Coercions. + +End ReflectiveSubuniverses_Theory. + +Module Type ReflectiveSubuniverses_Restriction_Data (Os : ReflectiveSubuniverses). + + Parameter New_ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter ReflectiveSubuniverses_restriction@{u a} + : New_ReflectiveSubuniverse@{u a} -> Os.ReflectiveSubuniverse@{u a}. + +End ReflectiveSubuniverses_Restriction_Data. + +Module ReflectiveSubuniverses_Restriction + (Os : ReflectiveSubuniverses) + (Res : ReflectiveSubuniverses_Restriction_Data Os) +<: ReflectiveSubuniverses. + + Definition ReflectiveSubuniverse := Res.New_ReflectiveSubuniverse. + + Definition O_reflector@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.O_reflector@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition In@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.In@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition O_inO@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.O_inO@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition to@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.to@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition inO_equiv_inO@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + := Os.inO_equiv_inO@{u a i j k} (Res.ReflectiveSubuniverses_restriction O). + Definition hprop_inO@{u a i} (H : Funext) (O : ReflectiveSubuniverse@{u a}) + := Os.hprop_inO@{u a i} H (Res.ReflectiveSubuniverses_restriction O). + Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + := @Os.extendable_to_O@{u a i j k} (Res.ReflectiveSubuniverses_restriction@{u a} O). + +End ReflectiveSubuniverses_Restriction. + +Module ReflectiveSubuniverses_FamUnion + (Os1 Os2 : ReflectiveSubuniverses) +<: ReflectiveSubuniverses. + + Definition ReflectiveSubuniverse@{u a} : Type2@{u a} + := Os1.ReflectiveSubuniverse@{u a} + Os2.ReflectiveSubuniverse@{u a}. + + Definition O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. +admit. +Defined. + + Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + Proof. + intros [O|O]; [ exact (Os1.In@{u a i} O) + | exact (Os2.In@{u a i} O) ]. + Defined. + + Definition O_inO@{u a i} + : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). +admit. +Defined. + + Definition to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. +admit. +Defined. + + Definition inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + In@{u a j} O U. + Proof. + intros [O|O]; [ exact (Os1.inO_equiv_inO@{u a i j k} O) + | exact (Os2.inO_equiv_inO@{u a i j k} O) ]. + Defined. + + Definition hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). +admit. +Defined. + + Definition extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). +admit. +Defined. + +End ReflectiveSubuniverses_FamUnion. + +End ReflectiveSubuniverse. + +End Modalities. + +End HoTT. + +Module Type Modalities. + + Parameter Modality@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter inO_equiv_inO@{u a i j k} : + forall (O : Modality@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + + let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In@{u a j} O U. + + Parameter hprop_inO@{u a i} + : Funext -> forall (O : Modality@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). + +End Modalities. + +Module Modalities_to_ReflectiveSubuniverses + (Os : Modalities) <: ReflectiveSubuniverses. + + Import Os. + + Fixpoint O_extendable@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector O A -> Type@{j}) + (B_inO : forall a, In@{u a j} O (B a)) (n : nat) + : ExtendableAlong@{i i j k} n (to O A) B. +admit. +Defined. + + Definition ReflectiveSubuniverse := Modality. + + Definition O_reflector := O_reflector. + + Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a} + := In@{u a i}. + Definition O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T) + := O_inO@{u a i}. + Definition to := to. + Definition inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + In@{u a j} O U + := inO_equiv_inO@{u a i j k}. + Definition hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T) + := hprop_inO@{u a i}. + + Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q} + : ooExtendableAlong@{i i j k} (to O P) (fun _ => Q) + := fun n => O_extendable O P (fun _ => Q) (fun _ => Q_inO) n. + +End Modalities_to_ReflectiveSubuniverses. + +Module Type EasyModalities. + + Parameter Modality@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter minO_pathsO@{u a i} + : forall (O : Modality@{u a}) (A : Type@{i}) + (z z' : O_reflector@{u a i} O A), + IsEquiv (to@{u a i} O (z = z')). + +End EasyModalities. + +Module EasyModalities_to_Modalities (Os : EasyModalities) +<: Modalities. + + Import Os. + + Definition Modality := Modality. + + Definition O_reflector@{u a i} := O_reflector@{u a i}. + Definition to@{u a i} := to@{u a i}. + + Definition In@{u a i} + : forall (O : Modality@{u a}), Type@{i} -> Type@{i} + := fun O A => IsEquiv@{i i} (to O A). + + Definition hprop_inO@{u a i} `{Funext} (O : Modality@{u a}) + (T : Type@{i}) + : IsHProp (In@{u a i} O T). +admit. +Defined. + + Definition O_ind_internal@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j}) + (B_inO : forall oa, In@{u a j} O (B oa)) + : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + (forall a, B (to O A a)) -> forall oa, B oa. +admit. +Defined. + + Definition O_ind_beta_internal@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j}) + (B_inO : forall oa, In@{u a j} O (B oa)) + (f : forall a : A, B (to O A a)) (a:A) + : O_ind_internal@{u a i j k} O A B B_inO f (to O A a) = f a. +admit. +Defined. + + Definition O_inO@{u a i} (O : Modality@{u a}) (A : Type@{i}) + : In@{u a i} O (O_reflector@{u a i} O A). +admit. +Defined. + + Definition inO_equiv_inO@{u a i j k} (O : Modality@{u a}) (A : Type@{i}) (B : Type@{j}) + (A_inO : In@{u a i} O A) (f : A -> B) (feq : IsEquiv f) + : In@{u a j} O B. + Proof. + simple refine (isequiv_commsq (to O A) (to O B) f + (O_ind_internal O A (fun _ => O_reflector O B) _ (fun a => to O B (f a))) _). + - + intros; apply O_inO. + - + intros a; refine (O_ind_beta_internal@{u a i j k} O A (fun _ => O_reflector O B) _ _ a). + - + apply A_inO. + - + simple refine (isequiv_adjointify _ + (O_ind_internal O B (fun _ => O_reflector O A) _ (fun b => to O A (f^-1 b))) _ _); + intros x. + + + apply O_inO. + + + pattern x; refine (O_ind_internal O B _ _ _ x); intros. + * + apply minO_pathsO. + * + simpl; admit. + + + pattern x; refine (O_ind_internal O A _ _ _ x); intros. + * + apply minO_pathsO. + * + simpl; admit. + Defined. + +End EasyModalities_to_Modalities. + +Module Modalities_Theory (Os : Modalities). + +Export Os. +Module Export Os_ReflectiveSubuniverses + := Modalities_to_ReflectiveSubuniverses Os. +Module Export RSU + := ReflectiveSubuniverses_Theory Os_ReflectiveSubuniverses. + +Module Export Coercions. + Coercion modality_to_reflective_subuniverse + := idmap : Modality -> ReflectiveSubuniverse. +End Coercions. + +Class IsConnected (O : Modality@{u a}) (A : Type@{i}) + + := isconnected_contr_O : IsTrunc@{i} -2 (O A). + +Class IsConnMap (O : Modality@{u a}) + {A : Type@{i}} {B : Type@{j}} (f : A -> B) + := isconnected_hfiber_conn_map + + : forall b:B, IsConnected@{u a k} O (hfiber@{i j} f b). + +End Modalities_Theory. + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + +Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i}) +: IsTrunc@{j} n (Trunc@{i} n A). +Admitted. + +Definition Trunc_ind {n A} + (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)} + : (forall a, P (tr a)) -> (forall aa, P aa) +:= (fun f aa => match aa with tr a => fun _ => f a end Pt). + +Definition Truncation_Modality := trunc_index. + +Module Truncation_Modalities <: Modalities. + + Definition Modality : Type2@{u a} := Truncation_Modality. + + Definition O_reflector (n : Modality@{u u'}) A := Trunc n A. + + Definition In (n : Modality@{u u'}) A := IsTrunc n A. + + Definition O_inO (n : Modality@{u u'}) A : In n (O_reflector n A). +admit. +Defined. + + Definition to (n : Modality@{u u'}) A := @tr n A. + + Definition inO_equiv_inO (n : Modality@{u u'}) + (A : Type@{i}) (B : Type@{j}) Atr f feq + : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In n B + := @trunc_equiv A B f n Atr feq. + + Definition hprop_inO `{Funext} (n : Modality@{u u'}) A + : IsHProp (In n A). +admit. +Defined. + +End Truncation_Modalities. + +Module Import TrM := Modalities_Theory Truncation_Modalities. + +Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A). + +Notation IsSurjection := (IsConnMap -1). + +Definition BuildIsSurjection {A B} (f : A -> B) : + (forall b, merely (hfiber f b)) -> IsSurjection f. +admit. +Defined. + +Ltac strip_truncations := + + progress repeat match goal with + | [ T : _ |- _ ] + => revert_opaque T; + refine (@Trunc_ind _ _ _ _ _); + + []; + intro T + end. +Local Open Scope trunc_scope. + +Global Instance conn_pointed_type {n : trunc_index} {A : Type} (a0:A) + `{IsConnMap n _ _ (unit_name a0)} : IsConnected n.+1 A | 1000. +admit. +Defined. + +Definition loops (A : pType) : pType := + Build_pType (point A = point A) idpath. + +Record pMap (A B : pType) := + { pointed_fun : A -> B ; + point_eq : pointed_fun (point A) = point B }. + +Arguments point_eq {A B} f : rename. +Coercion pointed_fun : pMap >-> Funclass. + +Infix "->*" := pMap (at level 99) : pointed_scope. +Local Open Scope pointed_scope. + +Definition pmap_compose {A B C : pType} + (g : B ->* C) (f : A ->* B) +: A ->* C + := Build_pMap A C (g o f) + (ap g (point_eq f) @ point_eq g). + +Record pHomotopy {A B : pType} (f g : pMap A B) := + { pointed_htpy : f == g ; + point_htpy : pointed_htpy (point A) @ point_eq g = point_eq f }. +Arguments pointed_htpy {A B f g} p x. + +Infix "==*" := pHomotopy (at level 70, no associativity) : pointed_scope. + +Definition loops_functor {A B : pType} (f : A ->* B) +: (loops A) ->* (loops B). +Proof. + refine (Build_pMap (loops A) (loops B) + (fun p => (point_eq f)^ @ (ap f p @ point_eq f)) _). + apply moveR_Vp; simpl. + refine (concat_1p _ @ (concat_p1 _)^). +Defined. + +Definition loops_functor_compose {A B C : pType} + (g : B ->* C) (f : A ->* B) +: (loops_functor (pmap_compose g f)) + ==* (pmap_compose (loops_functor g) (loops_functor f)). +admit. +Defined. + +Local Open Scope path_scope. + +Record ooGroup := + { classifying_space : pType@{i} ; + isconn_classifying_space : IsConnected@{u a i} 0 classifying_space + }. + +Local Notation B := classifying_space. + +Definition group_type (G : ooGroup) : Type + := point (B G) = point (B G). + +Coercion group_type : ooGroup >-> Sortclass. + +Definition group_loops (X : pType) +: ooGroup. +Proof. + + pose (x0 := point X); + pose (BG := (Build_pType + { x:X & merely (x = point X) } + (existT (fun x:X => merely (x = point X)) x0 (tr 1)))). + + cut (IsConnected 0 BG). + { + exact (Build_ooGroup BG). +} + cut (IsSurjection (unit_name (point BG))). + { + intros; refine (conn_pointed_type (point _)). +} + apply BuildIsSurjection; simpl; intros [x p]. + strip_truncations; apply tr; exists tt. + apply path_sigma_hprop; simpl. + exact (p^). +Defined. + +Definition loops_group (X : pType) +: loops X <~> group_loops X. +admit. +Defined. + +Definition ooGroupHom (G H : ooGroup) + := pMap (B G) (B H). + +Definition grouphom_fun {G H} (phi : ooGroupHom G H) : G -> H + := loops_functor phi. + +Coercion grouphom_fun : ooGroupHom >-> Funclass. + +Definition group_loops_functor + {X Y : pType} (f : pMap X Y) +: ooGroupHom (group_loops X) (group_loops Y). +Proof. + simple refine (Build_pMap _ _ _ _); simpl. + - + intros [x p]. + exists (f x). + strip_truncations; apply tr. + exact (ap f p @ point_eq f). + - + apply path_sigma_hprop; simpl. + apply point_eq. +Defined. + +Definition loops_functor_group + {X Y : pType} (f : pMap X Y) +: loops_functor (group_loops_functor f) o loops_group X + == loops_group Y o loops_functor f. +admit. +Defined. + +Definition grouphom_compose {G H K : ooGroup} + (psi : ooGroupHom H K) (phi : ooGroupHom G H) +: ooGroupHom G K + := pmap_compose psi phi. + +Definition group_loops_functor_compose + {X Y Z : pType} + (psi : pMap Y Z) (phi : pMap X Y) +: grouphom_compose (group_loops_functor psi) (group_loops_functor phi) + == group_loops_functor (pmap_compose psi phi). +Proof. + intros g. + unfold grouphom_fun, grouphom_compose. + refine (pointed_htpy (loops_functor_compose _ _) g @ _). + pose (p := eisretr (loops_group X) g). + change (loops_functor (group_loops_functor psi) + (loops_functor (group_loops_functor phi) g) + = loops_functor (group_loops_functor + (pmap_compose psi phi)) g). + rewrite <- p. + Fail Timeout 1 Time rewrite !loops_functor_group. + (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *) + Timeout 1 do 3 rewrite loops_functor_group. +Abort. \ No newline at end of file diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index 5b0502cf1a..b88c142be1 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -58,4 +58,5 @@ Qed. Lemma test b : b && true = b. Fail rewrite andb_true_l. - Admitted. \ No newline at end of file + Admitted. + \ No newline at end of file -- cgit v1.2.3 From cebc677e01c64c4a3f7081f85e37f3b61a112b68 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 9 Mar 2016 16:23:33 +0100 Subject: Win: kill unreliable hence do not waitpid after kill -9 (Close #4369) This commit also completes 74bd95d10b9f4cccb4bd5b855786c444492b201b --- lib/spawn.ml | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/lib/spawn.ml b/lib/spawn.ml index 4d35ded90f..fda4b4239a 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -220,10 +220,13 @@ let stats { oob_req; oob_resp; alive } = input_value oob_resp let rec wait p = - try snd (Unix.waitpid [] p.pid) - with - | Unix.Unix_error (Unix.EINTR, _, _) -> wait p - | Unix.Unix_error _ -> Unix.WEXITED 0o400 + (* On windows kill is not reliable, so wait may never return. *) + if Sys.os_type = "Unix" then + try snd (Unix.waitpid [] p.pid) + with + | Unix.Unix_error (Unix.EINTR, _, _) -> wait p + | Unix.Unix_error _ -> Unix.WEXITED 0o400 + else Unix.WEXITED 0o400 end @@ -267,8 +270,13 @@ let stats { oob_req; oob_resp; alive } = flush oob_req; let RespStats g = input_value oob_resp in g -let wait { pid = unixpid } = - try snd (Unix.waitpid [] unixpid) - with Unix.Unix_error _ -> Unix.WEXITED 0o400 +let rec wait p = + (* On windows kill is not reliable, so wait may never return. *) + if Sys.os_type = "Unix" then + try snd (Unix.waitpid [] p.pid) + with + | Unix.Unix_error (Unix.EINTR, _, _) -> wait p + | Unix.Unix_error _ -> Unix.WEXITED 0o400 + else Unix.WEXITED 0o400 end -- cgit v1.2.3 From b1e6542af576dc92221c4b4eb3e4c547b5901950 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 9 Mar 2016 16:34:35 +0100 Subject: Fixed bug #4533 with previous Keyed Unification commit Add test-suite file to ensure non-regression. --- test-suite/bugs/closed/4533.v | 224 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 224 insertions(+) create mode 100644 test-suite/bugs/closed/4533.v diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v new file mode 100644 index 0000000000..217ea8a4c7 --- /dev/null +++ b/test-suite/bugs/closed/4533.v @@ -0,0 +1,224 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." +"Top" "-top" "bug_lex_wrong_rewrite_02") -*- *) +(* File reduced by coq-bug-finder from original input, then from 1125 lines to +346 lines, then from 360 lines to 346 lines, then from 822 lines to 271 lines, +then from 285 lines to 271 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml +4.01.0 + coqtop version 8.5 (January 2016) *) +Inductive False := . +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Coq.Init.Datatypes. +Import Coq.Init.Notations. +Global Set Universe Polymorphism. +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Module Export Datatypes. + Set Implicit Arguments. + Notation nat := Coq.Init.Datatypes.nat. + Notation S := Coq.Init.Datatypes.S. + Record prod (A B : Type) := pair { fst : A ; snd : B }. + Notation "x * y" := (prod x y) : type_scope. + Delimit Scope nat_scope with nat. + Open Scope nat_scope. +End Datatypes. +Module Export Specif. + Set Implicit Arguments. + Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P +proj1_sig }. + Notation sigT := sig (only parsing). + Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + Notation projT1 := proj1_sig (only parsing). + Notation projT2 := proj2_sig (only parsing). +End Specif. +Global Set Keyed Unification. +Global Unset Strict Universe Declaration. +Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. +Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in +Type@{i}. +Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in + let ge := ((fun x => x) : Type1@{j} -> +Type@{i}) in Type@{i}. +Notation idmap := (fun x => x). +Delimit Scope function_scope with function. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Open Scope fibration_scope. +Open Scope function_scope. +Notation pr1 := projT1. +Notation pr2 := projT2. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. +Notation compose := (fun g f x => g (f x)). +Notation "g 'o' f" := (compose g%function f%function) (at level 40, left +associativity) : function_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. +Notation "1" := idpath : path_scope. +Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope. +Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : +type_scope. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr +(f x) = ap f (eissect x) + }. +Arguments eissect {A B}%type_scope f%function_scope {_} _. +Inductive Unit : Type1 := tt : Unit. +Local Open Scope path_scope. +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z += t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. +Section Adjointify. + Context {A B : Type} (f : A -> B) (g : B -> A). + Context (isretr : Sect g f) (issect : Sect f g). + Let issect' := fun x => + ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x. + + Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a). + admit. + Defined. + + Definition isequiv_adjointify : IsEquiv f + := BuildIsEquiv A B f g isretr issect' is_adjoint'. +End Adjointify. +Definition ExtensionAlong {A B : Type} (f : A -> B) + (P : B -> Type) (d : forall x:A, P (f x)) + := { s : forall y:B, P y & forall x:A, s (f x) = d x }. +Fixpoint ExtendableAlong@{i j k l} + (n : nat) {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := match n with + | 0 => Unit@{l} + | S n => (forall (g : forall a, C (f a)), + ExtensionAlong@{i j k l l} f C g) * + forall (h k : forall b, C b), + ExtendableAlong n f (fun b => h b = k b) + end. + +Definition ooExtendableAlong@{i j k l} + {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := forall n, ExtendableAlong@{i j k l} n f C. + +Module Type ReflectiveSubuniverses. + + Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : +Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : +Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : +Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). + +End ReflectiveSubuniverses. + +Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses). + Export Os. + Existing Class In. + Module Export Coercions. + Coercion O_reflector : ReflectiveSubuniverse >-> Funclass. + End Coercions. + Global Existing Instance O_inO. + + Section ORecursion. + Context {O : ReflectiveSubuniverse}. + + Definition O_rec {P Q : Type} {Q_inO : In O Q} + (f : P -> Q) + : O P -> Q + := (fst (extendable_to_O O 1%nat) f).1. + + Definition O_rec_beta {P Q : Type} {Q_inO : In O Q} + (f : P -> Q) (x : P) + : O_rec f (to O P x) = f x + := (fst (extendable_to_O O 1%nat) f).2 x. + + Definition O_indpaths {P Q : Type} {Q_inO : In O Q} + (g h : O P -> Q) (p : g o to O P == h o to O P) + : g == h + := (fst (snd (extendable_to_O O 2) g h) p).1. + + End ORecursion. + + + Section Reflective_Subuniverse. + Context (O : ReflectiveSubuniverse@{Ou Oa}). + + Definition isequiv_to_O_inO@{u a i} (T : Type@{i}) `{In@{u a i} O T} : +IsEquiv@{i i} (to O T). + Proof. + + pose (g := O_rec@{u a i i i i i} idmap). + refine (isequiv_adjointify (to O T) g _ _). + - + refine (O_indpaths@{u a i i i i i} (to O T o g) idmap _). + intros x. + apply ap. + apply O_rec_beta. + - + intros x. + apply O_rec_beta. + Defined. + Global Existing Instance isequiv_to_O_inO. + + End Reflective_Subuniverse. + +End ReflectiveSubuniverses_Theory. + +Module Type Preserves_Fibers (Os : ReflectiveSubuniverses). + Module Export Os_Theory := ReflectiveSubuniverses_Theory Os. +End Preserves_Fibers. + +Module Lex_Reflective_Subuniverses + (Os : ReflectiveSubuniverses) (Opf : Preserves_Fibers Os). + Import Opf. + Goal forall (O : ReflectiveSubuniverse) (A : Type) (B : A -> Type) (A_inO : +In O A), + + forall g, + forall (x : O {x : A & B x}) v v' v'' (p2 : v'' = v') (p0 : v' = v) (p1 : +v = _) r, + (p2 + @ (p0 + @ p1)) + @ eissect (to O A) (g x) = r. + intros. + cbv zeta. + rewrite concat_p_pp. + match goal with + | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" + | [ |- ?G ] => fail 1 "bad" G + end. \ No newline at end of file -- cgit v1.2.3 From c633bb322acf0bb626eafe6158287d1ddc11af26 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 9 Mar 2016 16:43:49 +0100 Subject: Redo fix init_setoid -> init_relation_classes It got lost during a merge with the 8.5 branch. --- tactics/rewrite.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 1be78c2add..67d21886b2 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -2086,7 +2086,7 @@ let setoid_proof ty fn fallback = let open Context.Rel.Declaration in let (sigma, t) = Typing.type_of env sigma rel in let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in - (try init_setoid () with _ -> raise Not_found); + (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e end -- cgit v1.2.3 From 2788c86e6a3c089aa7450a7768f8444470e35901 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 9 Mar 2016 17:11:46 +0100 Subject: Fix test-suite file coq-prog-args They were not parsed correctly with a newline in the middle. --- test-suite/bugs/closed/4533.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v index 217ea8a4c7..ae17fb145d 100644 --- a/test-suite/bugs/closed/4533.v +++ b/test-suite/bugs/closed/4533.v @@ -1,5 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." -"Top" "-top" "bug_lex_wrong_rewrite_02") -*- *) +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_lex_wrong_rewrite_02") -*- *) (* File reduced by coq-bug-finder from original input, then from 1125 lines to 346 lines, then from 360 lines to 346 lines, then from 822 lines to 271 lines, then from 285 lines to 271 lines *) @@ -12,6 +11,7 @@ Tactic Notation "admit" := case proof_admitted. Require Coq.Init.Datatypes. Import Coq.Init.Notations. Global Set Universe Polymorphism. +Global Set Primitive Projections. Notation "A -> B" := (forall (_ : A), B) : type_scope. Module Export Datatypes. Set Implicit Arguments. @@ -202,6 +202,7 @@ Module Type Preserves_Fibers (Os : ReflectiveSubuniverses). Module Export Os_Theory := ReflectiveSubuniverses_Theory Os. End Preserves_Fibers. +Opaque eissect. Module Lex_Reflective_Subuniverses (Os : ReflectiveSubuniverses) (Opf : Preserves_Fibers Os). Import Opf. @@ -221,4 +222,5 @@ v = _) r, match goal with | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" | [ |- ?G ] => fail 1 "bad" G - end. \ No newline at end of file + end. + Fail rewrite concat_p_pp. \ No newline at end of file -- cgit v1.2.3 From f1a8b27ffe0df4f207b0cfaac067c8201d07ae16 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 13 Nov 2015 14:41:14 +0100 Subject: Hashconsing modules. Modules inserted into the environment were not hashconsed, leading to an important redundancy, especially in module signatures that are always fully expanded. This patch divides by two the size and memory consumption of module-heavy files by hashconsing modules before putting them in the environment. Note that this is not a real hashconsing, in the sense that we only hashcons the inner terms contained in the modules, that are only mapped over. Compilation time should globally decrease, even though some files definining a lot of modules may see their compilation time increase. Some remaining overhead may persist, as for instance module inclusion is not hashconsed. --- kernel/declareops.ml | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++ kernel/declareops.mli | 1 + kernel/names.mli | 2 ++ kernel/safe_typing.ml | 2 ++ 4 files changed, 90 insertions(+) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index d9bd5c445e..f8b5981fa0 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -308,3 +308,88 @@ let string_of_side_effect { Entries.eff } = match eff with | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.string_of_con c ^ ")" | Entries.SEscheme (cl,_) -> "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) ^ ")" + +(** Hashconsing of modules *) + +let hcons_functorize hty he hself f = match f with +| NoFunctor e -> + let e' = he e in + if e == e' then f else NoFunctor e' +| MoreFunctor (mid, ty, nf) -> + (** FIXME *) + let mid' = mid in + let ty' = hty ty in + let nf' = hself nf in + if mid == mid' && ty == ty' && nf == nf' then f + else MoreFunctor (mid, ty', nf') + +let hcons_module_alg_expr me = me + +let rec hcons_structure_field_body sb = match sb with +| SFBconst cb -> + let cb' = hcons_const_body cb in + if cb == cb' then sb else SFBconst cb' +| SFBmind mib -> + let mib' = hcons_mind mib in + if mib == mib' then sb else SFBmind mib' +| SFBmodule mb -> + let mb' = hcons_module_body mb in + if mb == mb' then sb else SFBmodule mb' +| SFBmodtype mb -> + let mb' = hcons_module_body mb in + if mb == mb' then sb else SFBmodtype mb' + +and hcons_structure_body sb = + (** FIXME *) + let map (l, sfb as fb) = + let l' = Names.Label.hcons l in + let sfb' = hcons_structure_field_body sfb in + if l == l' && sfb == sfb' then fb else (l', sfb') + in + List.smartmap map sb + +and hcons_module_signature ms = + hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms + +and hcons_module_expression me = + hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me + +and hcons_module_implementation mip = match mip with +| Abstract -> Abstract +| Algebraic me -> + let me' = hcons_module_expression me in + if me == me' then mip else Algebraic me' +| Struct ms -> + let ms' = hcons_module_signature ms in + if ms == ms' then mip else Struct ms +| FullStruct -> FullStruct + +and hcons_module_body mb = + let mp' = mb.mod_mp in + let expr' = hcons_module_implementation mb.mod_expr in + let type' = hcons_module_signature mb.mod_type in + let type_alg' = mb.mod_type_alg in + let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in + let delta' = mb.mod_delta in + let retroknowledge' = mb.mod_retroknowledge in + + if + mb.mod_mp == mp' && + mb.mod_expr == expr' && + mb.mod_type == type' && + mb.mod_type_alg == type_alg' && + mb.mod_constraints == constraints' && + mb.mod_delta == delta' && + mb.mod_retroknowledge == retroknowledge' + then mb + else { + mod_mp = mp'; + mod_expr = expr'; + mod_type = type'; + mod_type_alg = type_alg'; + mod_constraints = constraints'; + mod_delta = delta'; + mod_retroknowledge = retroknowledge'; + } + +and hcons_module_type_body mtb = hcons_module_body mtb diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 86ba29b8b7..ad2b5d0a6c 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -77,3 +77,4 @@ val inductive_context : mutual_inductive_body -> universe_context val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body +val hcons_module_body : module_body -> module_body diff --git a/kernel/names.mli b/kernel/names.mli index 72dff03be7..1e79f4dde4 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -160,6 +160,8 @@ sig module Set : Set.S with type elt = t module Map : Map.ExtS with type key = t and module Set := Set + val hcons : t -> t + end (** {6 Unique names for bound modules} *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 0926d35f6d..62753962c8 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -561,6 +561,7 @@ let add_mind dir l mie senv = let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in + let mtb = Declareops.hcons_module_body mtb in let senv' = add_field (l,SFBmodtype mtb) MT senv in mp, senv' @@ -581,6 +582,7 @@ let full_add_module_type mp mt senv = let add_module l me inl senv = let mp = MPdot(senv.modpath, l) in let mb = Mod_typing.translate_module senv.env mp inl me in + let mb = Declareops.hcons_module_body mb in let senv' = add_field (l,SFBmodule mb) M senv in let senv'' = if Modops.is_functor mb.mod_type then senv' -- cgit v1.2.3 From 10e3c8e59664ed5137cd650ba6e0704943c511e8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Mar 2016 14:17:48 +0100 Subject: Removing OCaml deprecated function names from the Lazy module. --- checker/inductive.ml | 10 +++++----- kernel/inductive.ml | 4 ++-- lib/iStream.ml | 6 +++--- lib/pp.ml | 18 +++++++++--------- plugins/btauto/refl_btauto.ml | 2 +- toplevel/command.ml | 2 +- toplevel/vernacentries.ml | 2 +- 7 files changed, 22 insertions(+), 22 deletions(-) diff --git a/checker/inductive.ml b/checker/inductive.ml index 5e2e14f7fb..43a32ea24d 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -527,7 +527,7 @@ type guard_env = let make_renv env recarg tree = { env = env; rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *) - genv = [Lazy.lazy_from_val(Subterm(Large,tree))] } + genv = [Lazy.from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = { env = push_rel (LocalAssum (x,ty)) renv.env; @@ -538,7 +538,7 @@ let assign_var_spec renv (i,spec) = { renv with genv = List.assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = - push_var renv (x,ty,Lazy.lazy_from_val Not_subterm) + push_var renv (x,ty,Lazy.from_val Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = @@ -549,13 +549,13 @@ let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv } (* Definition and manipulation of the stack *) @@ -862,7 +862,7 @@ and stack_element_specif = function |SArg x -> x and extract_stack renv a = function - | [] -> Lazy.lazy_from_val Not_subterm , [] + | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 551632962b..499cbf0dfd 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -480,7 +480,7 @@ type guard_env = let make_renv env recarg tree = { env = env; rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *) - genv = [Lazy.lazy_from_val(Subterm(Large,tree))] } + genv = [Lazy.from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = { env = push_rel (LocalAssum (x,ty)) renv.env; @@ -817,7 +817,7 @@ and stack_element_specif = function |SArg x -> x and extract_stack renv a = function - | [] -> Lazy.lazy_from_val Not_subterm , [] + | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t (* Check term c can be applied to one of the mutual fixpoints. *) diff --git a/lib/iStream.ml b/lib/iStream.ml index c9f4d4a111..26a666e176 100644 --- a/lib/iStream.ml +++ b/lib/iStream.ml @@ -14,11 +14,11 @@ type 'a node = ('a,'a t) u and 'a t = 'a node Lazy.t -let empty = Lazy.lazy_from_val Nil +let empty = Lazy.from_val Nil -let cons x s = Lazy.lazy_from_val (Cons (x, s)) +let cons x s = Lazy.from_val (Cons (x, s)) -let thunk = Lazy.lazy_from_fun +let thunk = Lazy.from_fun let rec make_node f s = match f s with | Nil -> Nil diff --git a/lib/pp.ml b/lib/pp.ml index 0260f98fa2..9a833ae225 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -261,7 +261,7 @@ let rec pr_com ft s = let n = String.index s '\n' in String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1)) with Not_found -> s,None in - com_if ft (Lazy.lazy_from_val()); + com_if ft (Lazy.from_val()); (* let s1 = if String.length s1 <> 0 && s1.[0] = ' ' then (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1)) @@ -290,29 +290,29 @@ let pp_dirs ?pp_tag ft = begin match tok with | Str_def s -> let n = utf8_length s in - com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s + com_if ft (Lazy.from_val()); Format.pp_print_as ft n s | Str_len (s, n) -> - com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s + com_if ft (Lazy.from_val()); Format.pp_print_as ft n s end | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - com_if ft (Lazy.lazy_from_val()); + com_if ft (Lazy.from_val()); pp_open_box bty ; if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_open_box bty -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty + | Ppcmd_open_box bty -> com_if ft (Lazy.from_val()); pp_open_box bty | Ppcmd_close_box -> Format.pp_close_box ft () | Ppcmd_close_tbox -> Format.pp_close_tbox ft () | Ppcmd_white_space n -> - com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0)) + com_if ft (Lazy.from_fun (fun()->Format.pp_print_break ft n 0)) | Ppcmd_print_break(m,n) -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n)) + com_if ft (Lazy.from_fun(fun()->Format.pp_print_break ft m n)) | Ppcmd_set_tab -> Format.pp_set_tab ft () | Ppcmd_print_tbreak(m,n) -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n)) + com_if ft (Lazy.from_fun(fun()->Format.pp_print_tbreak ft m n)) | Ppcmd_force_newline -> com_brk ft; Format.pp_force_newline ft () | Ppcmd_print_if_broken -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ())) + com_if ft (Lazy.from_fun(fun()->Format.pp_print_if_newline ft ())) | Ppcmd_comment i -> let coms = split_com [] [] i !comments in (* Format.pp_open_hvbox ft 0;*) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 57eb80f5fb..aee0bd8564 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -12,7 +12,7 @@ let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s) let get_inductive dir s = let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in - Lazy.lazy_from_fun (fun () -> Globnames.destIndRef (glob_ref ())) + Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) let decomp_term (c : Term.constr) = Term.kind_of_term (Term.strip_outer_cast c) diff --git a/toplevel/command.ml b/toplevel/command.ml index 284bcd75ec..38bc0e568e 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -877,7 +877,7 @@ let well_founded = init_constant ["Init"; "Wf"] "well_founded" let mkSubset name typ prop = mkApp (Universes.constr_of_global (delayed_force build_sigma).typ, [| typ; mkLambda (name, typ, prop) |]) -let sigT = Lazy.lazy_from_fun build_sigma_type +let sigT = Lazy.from_fun build_sigma_type let make_qref s = Qualid (Loc.ghost, qualid_of_string s) let lt_ref = make_qref "Init.Peano.lt" diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index c63dac3026..02f8c17175 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -334,7 +334,7 @@ let dump_universes_gen g s = | Univ.Eq -> Printf.fprintf output " \"%s\" -> \"%s\" [style=dashed];\n" left right end, begin fun () -> - if Lazy.lazy_is_val init then Printf.fprintf output "}\n"; + if Lazy.is_val init then Printf.fprintf output "}\n"; close_out output end end else begin -- cgit v1.2.3 From 4341f37cf3c51ed82c23f05846c8e6e8823d3cd6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 10 Mar 2016 19:02:16 +0100 Subject: Primitive projections: protect kernel from erroneous definitions. E.g., Inductive foo := mkFoo { bla : foo } allowed to define recursive records with eta for which conversion is incomplete. - Eta-conversion only applies to BiFinite inductives - Finiteness information is now checked by the kernel (the constructor types must be strictly non recursive for BiFinite declarations). --- kernel/closure.ml | 2 +- kernel/indtypes.ml | 19 ++++++++++++------- pretyping/evarconv.ml | 2 +- printing/prettyp.ml | 4 ++-- test-suite/success/primitiveproj.v | 16 +--------------- 5 files changed, 17 insertions(+), 26 deletions(-) diff --git a/kernel/closure.ml b/kernel/closure.ml index 2ba80d8362..93e63d0fb5 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -784,7 +784,7 @@ let eta_expand_ind_stack env ind m s (f, s') = let mib = lookup_mind (fst ind) env in match mib.Declarations.mind_record with | Some (Some (_,projs,pbs)) when - mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> + mib.Declarations.mind_finite == Decl_kinds.BiFinite -> (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) let pars = mib.Declarations.mind_nparams in diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 49e8583158..acf5ab17d3 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -452,7 +452,7 @@ let array_min nmr a = if Int.equal nmr 0 then 0 else (* The recursive function that checks positivity and builds the list of recursive arguments *) -let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = +let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = let lparams = rel_context_length hyps in let nmr = rel_context_nhyps hyps in (* Checking the (strict) positivity of a constructor argument type [c] *) @@ -538,6 +538,8 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname | Prod (na,b,d) -> let () = assert (List.is_empty largs) in + if not recursive && not (noccur_between n ntypes b) then + raise (InductiveError BadEntry); let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d @@ -570,9 +572,11 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname and nmr' = array_min nmr irecargs_nmr in (nmr', mk_paths (Mrec ind) irecargs) -let check_positivity kn env_ar params inds = +let check_positivity kn env_ar params finite inds = let ntypes = Array.length inds in - let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in + let recursive = finite != Decl_kinds.BiFinite in + let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) + (Rtree.mk_rec_calls ntypes) in let lra_ind = Array.rev_to_list rc in let lparams = rel_context_length params in let nmr = rel_context_nhyps params in @@ -581,7 +585,7 @@ let check_positivity kn env_ar params inds = List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in let nargs = rel_context_nhyps sign - nmr in - check_positivity_one ienv params (kn,i) nargs lcnames lc + check_positivity_one recursive ienv params (kn,i) nargs lcnames lc in let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr @@ -807,10 +811,11 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re mind_reloc_tbl = rtbl; } in let packets = Array.map2 build_one_packet inds recargs in - let pkt = packets.(0) in + let pkt = packets.(0) in let isrecord = match isrecord with - | Some (Some rid) when pkt.mind_kelim == all_sorts && Array.length pkt.mind_consnames == 1 + | Some (Some rid) when pkt.mind_kelim == all_sorts + && Array.length pkt.mind_consnames == 1 && pkt.mind_consnrealargs.(0) > 0 -> (** The elimination criterion ensures that all projections can be defined. *) let u = @@ -851,7 +856,7 @@ let check_inductive env kn mie = (* First type-check the inductive definition *) let (env_ar, env_ar_par, params, inds) = typecheck_inductive env mie in (* Then check positivity conditions *) - let (nmr,recargs) = check_positivity kn env_ar_par params inds in + let (nmr,recargs) = check_positivity kn env_ar_par params mie.mind_entry_finite inds in (* Build the inductive packets *) build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private mie.mind_entry_universes diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 637a9e50e0..690b974be5 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -854,7 +854,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = let mib = lookup_mind (fst ind) env in match mib.Declarations.mind_record with - | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> + | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite -> let pars = mib.Declarations.mind_nparams in (try let l1' = Stack.tail pars sk1 in diff --git a/printing/prettyp.ml b/printing/prettyp.ml index fd51fd6b0f..4d9d40ae08 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -215,8 +215,8 @@ let print_polymorphism ref = let print_primitive_record recflag mipv = function | Some (Some (_, ps,_)) -> let eta = match recflag with - | Decl_kinds.CoFinite -> mt () - | Decl_kinds.Finite | Decl_kinds.BiFinite -> str " and has eta conversion" + | Decl_kinds.CoFinite | Decl_kinds.Finite -> mt () + | Decl_kinds.BiFinite -> str " and has eta conversion" in [pr_id mipv.(0).mind_typename ++ str" is primitive" ++ eta ++ str"."] | _ -> [] diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 281d707cb3..b5e6ccd618 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -35,10 +35,6 @@ Set Implicit Arguments. Check nat. -(* Inductive X (U:Type) := Foo (k : nat) (x : X U). *) -(* Parameter x : X nat. *) -(* Check x.(k). *) - Inductive X (U:Type) := { k : nat; a: k = k -> X U; b : let x := a eq_refl in X U }. Parameter x:X nat. @@ -49,18 +45,8 @@ Inductive Y := { next : option Y }. Check _.(next) : option Y. Lemma eta_ind (y : Y) : y = Build_Y y.(next). -Proof. reflexivity. Defined. - -Variable t : Y. - -Fixpoint yn (n : nat) (y : Y) : Y := - match n with - | 0 => t - | S n => {| next := Some (yn n y) |} - end. +Proof. Fail reflexivity. Abort. -Lemma eta_ind' (y: Y) : Some (yn 100 y) = Some {| next := (yn 100 y).(next) |}. -Proof. reflexivity. Defined. (* -- cgit v1.2.3 From e9bf68016ce9e04feb63222ff4bbafd27531f564 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 11 Mar 2016 10:32:14 +0100 Subject: According to Bruno, my fix for #4588 seems to be enough. So adding a test-suite file and closing the bug. --- test-suite/bugs/closed/4588.v | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 test-suite/bugs/closed/4588.v diff --git a/test-suite/bugs/closed/4588.v b/test-suite/bugs/closed/4588.v new file mode 100644 index 0000000000..ff66277e03 --- /dev/null +++ b/test-suite/bugs/closed/4588.v @@ -0,0 +1,10 @@ +Set Primitive Projections. + +(* This proof was accepted in Coq 8.5 because the subterm specs were not +projected correctly *) +Inductive foo : Prop := mkfoo { proj1 : False -> foo; proj2 : (forall P : Prop, P -> P) }. + +Fail Fixpoint loop (x : foo) : False := + loop (proj2 x _ x). + +Fail Definition bad : False := loop (mkfoo (fun x => match x with end) (fun _ x => x)). -- cgit v1.2.3 From a6d048a2de62bba97948fee2937dc5ea2fad0c83 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 12 Mar 2016 07:33:19 +0100 Subject: Removing an empty file detected by Luc Grateau. --- dev/tools/Makefile.common | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 dev/tools/Makefile.common diff --git a/dev/tools/Makefile.common b/dev/tools/Makefile.common deleted file mode 100644 index e69de29bb2..0000000000 -- cgit v1.2.3 From 7478ad7cc600753ba2609254657c87cacc27e8fc Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 12 Mar 2016 08:03:05 +0100 Subject: A more explicit name to the asymmetric boolean flag. --- interp/constrextern.ml | 6 +++--- interp/constrintern.ml | 4 ++-- interp/topconstr.ml | 6 +++--- interp/topconstr.mli | 2 +- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 3675441353..2da8e0f6f2 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -327,7 +327,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = with Not_found | No_match | Exit -> let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in - if !Topconstr.oldfashion_patterns then + if !Topconstr.asymmetric_patterns then if pattern_printable_in_both_syntax cstrsp then CPatCstr (loc, c, [], args) else CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) @@ -358,7 +358,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.oldfashion_patterns || not (List.is_empty ll) then l2 + let l2' = if !Topconstr.asymmetric_patterns || not (List.is_empty ll) then l2 else match drop_implicits_in_patt gr nb_to_drop l2 with |Some true_args -> true_args @@ -374,7 +374,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) subst in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.oldfashion_patterns then l2 + let l2' = if !Topconstr.asymmetric_patterns then l2 else match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with |Some true_args -> true_args diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 36f88fc3cc..f46217dec6 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1133,7 +1133,7 @@ let drop_notations_pattern looked_for = | None -> RCPatAtom (loc, None) | Some (n, head, pl) -> let pl = - if !oldfashion_patterns then pl else + if !asymmetric_patterns then pl else let pars = List.make n (CPatAtom (loc, None)) in List.rev_append pars pl in match drop_syndef top env head pl with @@ -1238,7 +1238,7 @@ let rec intern_pat genv aliases pat = let aliases' = merge_aliases aliases id in intern_pat genv aliases' p | RCPatCstr (loc, head, expl_pl, pl) -> - if !oldfashion_patterns then + if !asymmetric_patterns then let len = if List.is_empty expl_pl then Some (List.length pl) else None in let c,idslpl1 = find_constructor loc len head in let with_letin = diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 8293f7f88d..cde72fd93d 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -19,14 +19,14 @@ open Constrexpr_ops (*i*) -let oldfashion_patterns = ref (false) +let asymmetric_patterns = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "Constructors in patterns require all their arguments but no parameters instead of explicit parameters and arguments"; Goptions.optkey = ["Asymmetric";"Patterns"]; - Goptions.optread = (fun () -> !oldfashion_patterns); - Goptions.optwrite = (fun a -> oldfashion_patterns:=a); + Goptions.optread = (fun () -> !asymmetric_patterns); + Goptions.optwrite = (fun a -> asymmetric_patterns:=a); } (**********************************************************************) diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 1e867c19c6..0f30135f89 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -12,7 +12,7 @@ open Constrexpr (** Topconstr *) -val oldfashion_patterns : bool ref +val asymmetric_patterns : bool ref (** Utilities on constr_expr *) -- cgit v1.2.3 From d868820ad1f00b896c5f44f18678fac2f8e0f720 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 13 Mar 2016 13:18:10 +0100 Subject: Supporting "(@foo) args" in patterns, where "@foo" has no arguments. --- interp/constrexpr_ops.ml | 2 +- interp/constrextern.ml | 18 +++++++++--------- interp/constrintern.ml | 13 ++++++------- interp/topconstr.ml | 2 +- intf/constrexpr.mli | 6 +++--- parsing/g_constr.ml4 | 6 +++--- plugins/decl_mode/decl_interp.ml | 2 +- printing/ppconstr.ml | 8 ++++---- stm/texmacspp.ml | 8 +++++++- 9 files changed, 35 insertions(+), 30 deletions(-) diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 9c577034e8..c5730e6261 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -66,7 +66,7 @@ let rec cases_pattern_expr_eq p1 p2 = Id.equal i1 i2 && cases_pattern_expr_eq a1 a2 | CPatCstr(_,c1,a1,b1), CPatCstr(_,c2,a2,b2) -> eq_reference c1 c2 && - List.equal cases_pattern_expr_eq a1 a2 && + Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && List.equal cases_pattern_expr_eq b1 b2 | CPatAtom(_,r1), CPatAtom(_,r2) -> Option.equal eq_reference r1 r2 diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 2da8e0f6f2..49892bec49 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -266,7 +266,7 @@ let make_pat_notation loc ntn (terms,termlists as subst) args = let mkPat loc qid l = (* Normally irrelevant test with v8 syntax, but let's do it anyway *) - if List.is_empty l then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,[],l) + if List.is_empty l then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,None,l) let pattern_printable_in_both_syntax (ind,_ as c) = let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in @@ -286,7 +286,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = when !Flags.in_debugger||Inductiveops.constructor_has_local_defs cstrsp -> let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in - CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) + CPatCstr (loc, c, Some (add_patt_for_params (fst cstrsp) args), []) | _ -> try if !Flags.raw_print || !print_no_symbol then raise No_match; @@ -329,13 +329,13 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in if !Topconstr.asymmetric_patterns then if pattern_printable_in_both_syntax cstrsp - then CPatCstr (loc, c, [], args) - else CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) + then CPatCstr (loc, c, None, args) + else CPatCstr (loc, c, Some (add_patt_for_params (fst cstrsp) args), []) else let full_args = add_patt_for_params (fst cstrsp) args in match drop_implicits_in_patt (ConstructRef cstrsp) 0 full_args with - |Some true_args -> CPatCstr (loc, c, [], true_args) - |None -> CPatCstr (loc, c, full_args, []) + |Some true_args -> CPatCstr (loc, c, None, true_args) + |None -> CPatCstr (loc, c, Some full_args, []) in insert_pat_alias loc p na and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) (tmp_scope, scopes as allscopes) vars = @@ -413,7 +413,7 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then let c = extern_reference Loc.ghost vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in - CPatCstr (Loc.ghost, c, add_patt_for_params ind args, []) + CPatCstr (Loc.ghost, c, Some (add_patt_for_params ind args), []) else try if !Flags.raw_print || !print_no_symbol then raise No_match; @@ -431,8 +431,8 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = let c = extern_reference Loc.ghost vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in match drop_implicits_in_patt (IndRef ind) 0 args with - |Some true_args -> CPatCstr (Loc.ghost, c, [], true_args) - |None -> CPatCstr (Loc.ghost, c, args, []) + |Some true_args -> CPatCstr (Loc.ghost, c, None, true_args) + |None -> CPatCstr (Loc.ghost, c, Some args, []) let extern_cases_pattern vars p = extern_cases_pattern_in_scope (None,[]) vars p diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f46217dec6..b62df8dfff 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1095,7 +1095,7 @@ let drop_notations_pattern looked_for = let (loc,qid) = qualid_of_reference re in try match locate_extended qid with - |SynDef sp -> + | SynDef sp -> let (vars,a) = Syntax_def.search_syntactic_definition sp in (match a with | NRef g -> @@ -1118,7 +1118,7 @@ let drop_notations_pattern looked_for = let (_,argscs) = find_remaining_scopes pats1 pats2 g in Some (g, idspl1, List.map2 (in_pat_sc env) argscs pats2) | _ -> raise Not_found) - |TrueGlobal g -> + | TrueGlobal g -> test_kind top g; Dumpglob.add_glob loc g; let (_,argscs) = find_remaining_scopes [] pats g in @@ -1140,16 +1140,15 @@ let drop_notations_pattern looked_for = |Some (a,b,c) -> RCPatCstr(loc, a, b, c) |None -> raise (InternalizationError (loc,NotAConstructor head)) end - | CPatCstr (loc, head, [], pl) -> + | CPatCstr (loc, head, None, pl) -> begin match drop_syndef top env head pl with | Some (a,b,c) -> RCPatCstr(loc, a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end - | CPatCstr (loc, r, expl_pl, pl) -> - let g = try - (locate (snd (qualid_of_reference r))) - with Not_found -> + | CPatCstr (loc, r, Some expl_pl, pl) -> + let g = try locate (snd (qualid_of_reference r)) + with Not_found -> raise (InternalizationError (loc,NotAConstructor r)) in let (argscs1,argscs2) = find_remaining_scopes expl_pl pl g in RCPatCstr (loc, g, List.map2 (in_pat_sc env) argscs1 expl_pl, List.map2 (in_pat_sc env) argscs2 pl) diff --git a/interp/topconstr.ml b/interp/topconstr.ml index cde72fd93d..e569f543b5 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -52,7 +52,7 @@ let rec cases_pattern_fold_names f a = function List.fold_left (cases_pattern_fold_names f) a patl | CPatCstr (_,_,patl1,patl2) -> List.fold_left (cases_pattern_fold_names f) - (List.fold_left (cases_pattern_fold_names f) a patl1) patl2 + (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 | CPatNotation (_,_,(patl,patll),patl') -> List.fold_left (cases_pattern_fold_names f) (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 40812a3d87..f5855a971e 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -40,15 +40,15 @@ type raw_cases_pattern_expr = | RCPatAlias of Loc.t * raw_cases_pattern_expr * Id.t | RCPatCstr of Loc.t * Globnames.global_reference * raw_cases_pattern_expr list * raw_cases_pattern_expr list - (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *) + (** [CPatCstr (_, c, l1, l2)] represents (@c l1) l2 *) | RCPatAtom of Loc.t * Id.t option | RCPatOr of Loc.t * raw_cases_pattern_expr list type cases_pattern_expr = | CPatAlias of Loc.t * cases_pattern_expr * Id.t | CPatCstr of Loc.t * reference - * cases_pattern_expr list * cases_pattern_expr list - (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *) + * cases_pattern_expr list option * cases_pattern_expr list + (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *) | CPatAtom of Loc.t * reference option | CPatOr of Loc.t * cases_pattern_expr list | CPatNotation of Loc.t * notation * cases_pattern_notation_substitution diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 6eeae925a3..b11204cbc5 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -379,14 +379,14 @@ GEXTEND Gram | "10" RIGHTA [ p = pattern; lp = LIST1 NEXT -> (match p with - | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, [], lp) + | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) | _ -> Errors.user_err_loc (cases_pattern_expr_loc p, "compound_pattern", Pp.str "Such pattern cannot have arguments.")) - |"@"; r = Prim.reference; lp = LIST1 NEXT -> - CPatCstr (!@loc, r, lp, []) ] + |"@"; r = Prim.reference; lp = LIST0 NEXT -> + CPatCstr (!@loc, r, Some lp, []) ] | "1" LEFTA [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] | "0" diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 4874552d6a..34307a358f 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -96,7 +96,7 @@ let rec add_vars_of_simple_pattern globs = function add_vars_of_simple_pattern globs p | CPatCstr (_,_,pl1,pl2) -> List.fold_left add_vars_of_simple_pattern - (List.fold_left add_vars_of_simple_pattern globs pl1) pl2 + (Option.fold_left (List.fold_left add_vars_of_simple_pattern) globs pl1) pl2 | CPatNotation(_,_,(pl,pll),pl') -> List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 8a0df18ca5..1866ca5042 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -244,16 +244,16 @@ end) = struct | CPatAlias (_, p, id) -> pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las - | CPatCstr (_,c, [], []) -> + | CPatCstr (_,c, None, []) -> pr_reference c, latom - | CPatCstr (_, c, [], args) -> + | CPatCstr (_, c, None, args) -> pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatCstr (_, c, args, []) -> + | CPatCstr (_, c, Some args, []) -> str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatCstr (_, c, expl_args, extra_args) -> + | CPatCstr (_, c, Some expl_args, extra_args) -> surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) expl_args) ++ prlist (pr_patt spc (lapp,L)) extra_args, lapp diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index 5bd1569ce5..3c4b8cb71e 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -304,7 +304,13 @@ and pp_cases_pattern_expr cpe = xmlApply loc (xmlOperator "alias" ~attr:["name", string_of_id id] loc :: [pp_cases_pattern_expr cpe]) - | CPatCstr (loc, ref, cpel1, cpel2) -> + | CPatCstr (loc, ref, None, cpel2) -> + xmlApply loc + (xmlOperator "reference" + ~attr:["name", Libnames.string_of_reference ref] loc :: + [Element ("impargs", [], []); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatCstr (loc, ref, Some cpel1, cpel2) -> xmlApply loc (xmlOperator "reference" ~attr:["name", Libnames.string_of_reference ref] loc :: -- cgit v1.2.3 From 04b7394eaae170685a09ccd85ef47991466e6681 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 12 Mar 2016 13:40:16 +0100 Subject: Adding a file summarizing the inconsistencies in interpreting implicit arguments and scopes with abbreviations and notations. Comments are welcome on the proposed solutions for uniformization. --- test-suite/success/Notations2.v | 90 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 test-suite/success/Notations2.v diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v new file mode 100644 index 0000000000..ac41819f56 --- /dev/null +++ b/test-suite/success/Notations2.v @@ -0,0 +1,90 @@ +(* This file is giving some examples about how implicit arguments and + scopes are (inconsistently) treated when using abbreviations or + notations, in terms or patterns, or when using @ and parentheses in + terms and patterns *) + +(* One compromise would be that: + - Neither abbreviations nor notations break implicit arguments and + scopes unless the head constant is with @ and surrounded with parentheses. + + This would change 3. terms and patterns to behave like 4. terms, + with former behavior possible by using instead (@pair' _ x%nat) + or (pair' x%nat). + + This would change 4. patterns to behave like 4. terms, introducing the + possibibility to have the deactivation in patterns, as it is in terms, + by using (@pair'). + + This would change 5. terms to behave like 5. patterns, introducing the + possibibility to have the activation behavior in terms, as it with + abbreviations, using either (@(pair') _ x%nat) or (pair' _ x). + + This would change 6. patterns to behave like 6. terms, introducing the + possibibility to have the deactivation behavior in patterns, as it with + abbreviations in terms, using either (@(pair') _ x%nat) or (pair' _ x). + - "(foo args)" directly in terms would still deactivation implicit + arguments and scopes for further arguments, as of today. + - "(@foo args)" directly in terms would deactivate implicit arguments and scopes + in args as of today, but not for further arguments, on the contrary of today + - "((@foo) args)" directly in terms would deactivate implicit + arguments and scopes in args and for further arguments, as it is today + + Then, in both terms and patterns: + - "(@foo args)" in an abbreviation or notation would behave the same as + "(@foo args)" when expanded, i.e. with deactivation of implicit arguments + and scopes only for args, but not for further arguments. + - "((@foo) args)" in an abbreviation or notation would behave the same as + "((@foo) args)" when expanded, i.e. with deactivation of implicit arguments and scopes. + - "(foo args)" in an abbreviation or notation would behave the same as + "foo args" when expanded, i.e. with no change on implicit arguments and scopes. +*) + +Inductive prod' A : Type -> Type := +| pair' (a:A) B (b:B) (c:bool) : prod' A B. +Arguments pair' [A] a%bool_scope [B] b%bool_scope c%bool_scope. +Notation "0" := true : bool_scope. + +(* 1. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c1 x := (pair' x). +Check pair' 0 0 0 : prod' bool bool. +Check (pair' 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c1 0 0 0 : prod' bool bool. +Check fun x : prod' bool bool => match x with c1 0 y 0 => 2 | _ => 1 end. +Check fun x : prod' bool bool => match x with (pair' 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) + +(* 2. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c2 x := (@pair' _ x). +Check (@pair' _ 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c2 0 0 0 : prod' bool bool. +Check fun A (x : prod' bool A) => match x with c2 0 y 0 => 2 | _ => 1 end. +Check fun A (x : prod' bool A) => match x with (@pair' _ 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) + +(* 3. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c3 x := ((@pair') _ x). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking implicit and scopes *) +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *) +Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *) +Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end. +(* Check fun A (x :prod' nat A) => match x with ((@pair') _ 0) y 0 => 2 | _ => 1 end.*) + +(* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +(* unless an atomic @ is given, in terms but not in patterns *) +Notation c4 := (@pair'). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check c4 _ 0 _ 0 0%bool : prod' nat nat. (* all 0 are in nat_scope: would there be incompatibilities to change that? *) +Check fun A (x :prod' bool A) => match x with c4 _ 0 _ y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) +Check fun A (x :prod' nat A) => match x with (@pair') _ 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: the implicit arguments and scopes are not deactivated *) + +(* 5. Notations stop further implicit arguments to be inserted and scopes to be used *) +(* in terms but not in patterns *) +Notation "% x" := (pair' x) (at level 0, x at level 0). +Check pair' 0 0 0 : prod' bool bool. +Check % 0 _ 0 0%bool : prod' bool nat. (* last two 0 are in nat_scope *) +Check fun A (x :prod' bool A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) +Check fun A (x :prod' bool A) => match x with pair' 0 y 0 => 2 | _ => 1 end. + +(* 6. Notations stop further implicit arguments to be inserted and scopes to be used *) +(* in terms but not in patterns *) +Notation "% x" := ((@pair') _ x%nat) (at level 0, x at level 0). +Check (@pair') _ 0 _ 0%bool 0%bool : prod' nat bool. +Check ((@pair') _ 0) _ 0%bool 0%bool : prod' nat bool. +Check % 0 _ 0 0%bool : prod' nat nat. (* last two 0 are in nat_scope *) +Check fun A (x :prod' nat A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: last 0 is in bool_scope, and implicit is not given *) +Check fun A (x :prod' bool A) => match x with (@pair') 0 y 0 => 2 | _ => 1 end. (* inconsistent with terms: the implicit arguments and scopes are not deactivated *) +Check fun A (x :prod' nat A) => match x with ((@pair') _) 0 y 0 => 2 | _ => 1 end. -- cgit v1.2.3 From 0dfd0fb7d7c04eedfb3b161b9b5cfab103c17916 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 13 Mar 2016 17:48:28 +0100 Subject: Adding a few functions on type union. --- lib/util.ml | 33 ++++++++++++++++++++++++++++++--- lib/util.mli | 8 ++++++++ 2 files changed, 38 insertions(+), 3 deletions(-) diff --git a/lib/util.ml b/lib/util.ml index 0f79c10df1..cae996e332 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -132,9 +132,36 @@ type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq -let map_union f g = function - | Inl a -> Inl (f a) - | Inr b -> Inr (g b) +module Union = +struct + let map f g = function + | Inl a -> Inl (f a) + | Inr b -> Inr (g b) + + (** Lifting equality onto union types. *) + let equal f g x y = match x, y with + | Inl x, Inl y -> f x y + | Inr x, Inr y -> g x y + | _, _ -> false + + let fold_left f g a = function + | Inl y -> f a y + | Inr y -> g a y + | _ -> a +end + +let map_union = Union.map + +(** Lifting equality onto union types. *) +let equal_union f g x y = match x, y with + | Inl x, Inl y -> f x y + | Inr x, Inr y -> g x y + | _, _ -> false + +let fold_left_union f g a = function + | Inl y -> f a y + | Inr y -> g a y + | _ -> a type iexn = Exninfo.iexn diff --git a/lib/util.mli b/lib/util.mli index 559874bb83..6bed7e3552 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -114,7 +114,15 @@ val iraise : iexn -> 'a type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b (** Union type *) +module Union : +sig + val map : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union + val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) union -> ('a, 'b) union -> bool + val fold_left : ('c -> 'a -> 'c) -> ('c -> 'b -> 'c) -> 'c -> ('a, 'b) union -> 'c +end + val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union +(** Alias for [Union.map] *) type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a (** Used for browsable-until structures. *) -- cgit v1.2.3 From 3366f05ab09aa90dcc96d7432bff09617162c3e4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 13 Mar 2016 17:49:25 +0100 Subject: Adopting the same rules for interpreting @, abbreviations and notations in patterns than in terms, wrt implicit arguments and scopes. See file Notations2.v for the conventions in use in terms. Somehow this could be put in 8.5 since it puts in agreement the interpretation of abbreviations and notations in "symmetric patterns" to what is done in terms (even though the interpretation rules for terms are a bit ad hoc). There is one exception: in terms, "(foo args) args'" deactivates the implicit arguments and scopes in args'. This is a bit complicated to implement in patterns so the syntax is not supported (and anyway, this convention is a bit questionable). --- interp/constrintern.ml | 33 +++++++----- intf/constrexpr.mli | 2 +- parsing/g_constr.ml4 | 3 ++ test-suite/success/Notations2.v | 110 ++++++++++++++++++++-------------------- 4 files changed, 80 insertions(+), 68 deletions(-) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index b62df8dfff..fa38695705 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -918,7 +918,7 @@ let chop_params_pattern loc ind args with_letin = args let find_constructor loc add_params ref = - let cstr = match ref with + let (ind,_ as cstr) = match ref with | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in @@ -927,15 +927,15 @@ let find_constructor loc add_params ref = let error = str "This reference is not a constructor." in user_err_loc (loc, "find_constructor", error) in - cstr, (function (ind,_ as c) -> match add_params with - |Some nb_args -> + cstr, match add_params with + | Some nb_args -> let nb = - if Int.equal nb_args (Inductiveops.constructor_nrealdecls c) + if Int.equal nb_args (Inductiveops.constructor_nrealdecls cstr) then Inductiveops.inductive_nparamdecls ind else Inductiveops.inductive_nparams ind in List.make nb ([], [(Id.Map.empty, PatVar(Loc.ghost,Anonymous))]) - |None -> []) cstr + | None -> [] let find_pattern_variable = function | Ident (loc,id) -> id @@ -1099,16 +1099,17 @@ let drop_notations_pattern looked_for = let (vars,a) = Syntax_def.search_syntactic_definition sp in (match a with | NRef g -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; let () = assert (List.is_empty vars) in let (_,argscs) = find_remaining_scopes [] pats g in Some (g, [], List.map2 (in_pat_sc env) argscs pats) - | NApp (NRef g,[]) -> (* special case : Syndef for @Cstr *) + | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr, this deactivates *) test_kind top g; let () = assert (List.is_empty vars) in - let (argscs,_) = find_remaining_scopes pats [] g in - Some (g, List.map2 (in_pat_sc env) argscs pats, []) + Some (g, List.map (in_pat false env) pats, []) | NApp (NRef g,args) -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; let nvars = List.length vars in if List.length pats < nvars then error_not_enough_arguments loc; @@ -1146,12 +1147,18 @@ let drop_notations_pattern looked_for = | Some (a,b,c) -> RCPatCstr(loc, a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end - | CPatCstr (loc, r, Some expl_pl, pl) -> + | CPatCstr (loc, r, Some expl_pl, pl) -> let g = try locate (snd (qualid_of_reference r)) with Not_found -> raise (InternalizationError (loc,NotAConstructor r)) in - let (argscs1,argscs2) = find_remaining_scopes expl_pl pl g in - RCPatCstr (loc, g, List.map2 (in_pat_sc env) argscs1 expl_pl, List.map2 (in_pat_sc env) argscs2 pl) + if expl_pl == [] then + (* Convention: (@r) deactivates all further implicit arguments and scopes *) + RCPatCstr (loc, g, List.map (in_pat false env) pl, []) + else + (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) + (* but not scopes in expl_pl *) + let (argscs1,_) = find_remaining_scopes expl_pl pl g in + RCPatCstr (loc, g, List.map2 (in_pat_sc env) argscs1 expl_pl @ List.map (in_pat false env) pl, []) | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[]),[]) when Bigint.is_strictly_pos p -> fst (Notation.interp_prim_token_cases_pattern_expr loc (ensure_kind false loc) (Numeral (Bigint.neg p)) @@ -1203,8 +1210,8 @@ let drop_notations_pattern looked_for = ensure_kind top loc g; let (argscs1,argscs2) = find_remaining_scopes pl args g in RCPatCstr (loc, g, - List.map2 (fun x -> in_not false loc {env with tmp_scope = x} fullsubst []) argscs1 pl, - List.map2 (in_pat_sc env) argscs2 args) + List.map2 (fun x -> in_not false loc {env with tmp_scope = x} fullsubst []) argscs1 pl @ + List.map (in_pat false env) args, []) | NList (x,_,iter,terminator,lassoc) -> if not (List.is_empty args) then user_err_loc (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns."); diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index f5855a971e..efd5129b66 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -40,7 +40,7 @@ type raw_cases_pattern_expr = | RCPatAlias of Loc.t * raw_cases_pattern_expr * Id.t | RCPatCstr of Loc.t * Globnames.global_reference * raw_cases_pattern_expr list * raw_cases_pattern_expr list - (** [CPatCstr (_, c, l1, l2)] represents (@c l1) l2 *) + (** [CPatCstr (_, c, l1, l2)] represents ((@c l1) l2) *) | RCPatAtom of Loc.t * Id.t option | RCPatOr of Loc.t * raw_cases_pattern_expr list diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index b11204cbc5..7e470e8445 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -380,6 +380,9 @@ GEXTEND Gram [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) + | CPatCstr (_, r, None, l2) -> Errors.user_err_loc + (cases_pattern_expr_loc p, "compound_pattern", + Pp.str "Nested applications not supported.") | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) | _ -> Errors.user_err_loc diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index ac41819f56..9505a56e3f 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -1,40 +1,33 @@ (* This file is giving some examples about how implicit arguments and - scopes are (inconsistently) treated when using abbreviations or - notations, in terms or patterns, or when using @ and parentheses in - terms and patterns *) - -(* One compromise would be that: - - Neither abbreviations nor notations break implicit arguments and - scopes unless the head constant is with @ and surrounded with parentheses. - + This would change 3. terms and patterns to behave like 4. terms, - with former behavior possible by using instead (@pair' _ x%nat) - or (pair' x%nat). - + This would change 4. patterns to behave like 4. terms, introducing the - possibibility to have the deactivation in patterns, as it is in terms, - by using (@pair'). - + This would change 5. terms to behave like 5. patterns, introducing the - possibibility to have the activation behavior in terms, as it with - abbreviations, using either (@(pair') _ x%nat) or (pair' _ x). - + This would change 6. patterns to behave like 6. terms, introducing the - possibibility to have the deactivation behavior in patterns, as it with - abbreviations in terms, using either (@(pair') _ x%nat) or (pair' _ x). - - "(foo args)" directly in terms would still deactivation implicit - arguments and scopes for further arguments, as of today. - - "(@foo args)" directly in terms would deactivate implicit arguments and scopes - in args as of today, but not for further arguments, on the contrary of today - - "((@foo) args)" directly in terms would deactivate implicit - arguments and scopes in args and for further arguments, as it is today - - Then, in both terms and patterns: - - "(@foo args)" in an abbreviation or notation would behave the same as - "(@foo args)" when expanded, i.e. with deactivation of implicit arguments - and scopes only for args, but not for further arguments. - - "((@foo) args)" in an abbreviation or notation would behave the same as - "((@foo) args)" when expanded, i.e. with deactivation of implicit arguments and scopes. - - "(foo args)" in an abbreviation or notation would behave the same as - "foo args" when expanded, i.e. with no change on implicit arguments and scopes. + scopes are treated when using abbreviations or notations, in terms + or patterns, or when using @ and parentheses in terms and patterns. + +The convention is: + +Constant foo with implicit arguments and scopes used in a term or a pattern: + + foo do not deactivate further arguments and scopes + @foo deactivates further arguments and scopes + (foo x) deactivates further arguments and scopes + (@foo x) deactivates further arguments and scopes + +Notations binding to foo: + +# := foo do not deactivate further arguments and scopes +# := @foo deactivates further arguments and scopes +# x := foo x deactivates further arguments and scopes +# x := @foo x deactivates further arguments and scopes + +Abbreviations binding to foo: + +f := foo do not deactivate further arguments and scopes +f := @foo deactivates further arguments and scopes +f x := foo x do not deactivate further arguments and scopes +f x := @foo x do not deactivate further arguments and scopes *) +(* One checks that abbreviations and notations in patterns now behave like in terms *) + Inductive prod' A : Type -> Type := | pair' (a:A) B (b:B) (c:bool) : prod' A B. Arguments pair' [A] a%bool_scope [B] b%bool_scope c%bool_scope. @@ -46,14 +39,13 @@ Check pair' 0 0 0 : prod' bool bool. Check (pair' 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) Check c1 0 0 0 : prod' bool bool. Check fun x : prod' bool bool => match x with c1 0 y 0 => 2 | _ => 1 end. -Check fun x : prod' bool bool => match x with (pair' 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) (* 2. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) Notation c2 x := (@pair' _ x). Check (@pair' _ 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) Check c2 0 0 0 : prod' bool bool. Check fun A (x : prod' bool A) => match x with c2 0 y 0 => 2 | _ => 1 end. -Check fun A (x : prod' bool A) => match x with (@pair' _ 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) +Check fun A (x : prod' bool A) => match x with (@pair' _ 0) _ y 0%bool => 2 | _ => 1 end. (* 3. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) Notation c3 x := ((@pair') _ x). @@ -61,30 +53,40 @@ Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking impl Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *) Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *) Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end. -(* Check fun A (x :prod' nat A) => match x with ((@pair') _ 0) y 0 => 2 | _ => 1 end.*) (* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) -(* unless an atomic @ is given, in terms but not in patterns *) +(* unless an atomic @ is given *) Notation c4 := (@pair'). Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. -Check c4 _ 0 _ 0 0%bool : prod' nat nat. (* all 0 are in nat_scope: would there be incompatibilities to change that? *) -Check fun A (x :prod' bool A) => match x with c4 _ 0 _ y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) -Check fun A (x :prod' nat A) => match x with (@pair') _ 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: the implicit arguments and scopes are not deactivated *) +Check c4 _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with c4 _ 0%bool _ y 0%bool => 2 | _ => 1 end. +Check fun A (x :prod' bool A) => match x with (@pair') _ 0%bool _ y 0%bool => 2 | _ => 1 end. (* 5. Notations stop further implicit arguments to be inserted and scopes to be used *) -(* in terms but not in patterns *) -Notation "% x" := (pair' x) (at level 0, x at level 0). +Notation "# x" := (pair' x) (at level 0, x at level 1). Check pair' 0 0 0 : prod' bool bool. -Check % 0 _ 0 0%bool : prod' bool nat. (* last two 0 are in nat_scope *) -Check fun A (x :prod' bool A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) -Check fun A (x :prod' bool A) => match x with pair' 0 y 0 => 2 | _ => 1 end. +Check # 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with # 0 _ y 0%bool => 2 | _ => 1 end. (* 6. Notations stop further implicit arguments to be inserted and scopes to be used *) -(* in terms but not in patterns *) -Notation "% x" := ((@pair') _ x%nat) (at level 0, x at level 0). -Check (@pair') _ 0 _ 0%bool 0%bool : prod' nat bool. -Check ((@pair') _ 0) _ 0%bool 0%bool : prod' nat bool. -Check % 0 _ 0 0%bool : prod' nat nat. (* last two 0 are in nat_scope *) -Check fun A (x :prod' nat A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: last 0 is in bool_scope, and implicit is not given *) -Check fun A (x :prod' bool A) => match x with (@pair') 0 y 0 => 2 | _ => 1 end. (* inconsistent with terms: the implicit arguments and scopes are not deactivated *) -Check fun A (x :prod' nat A) => match x with ((@pair') _) 0 y 0 => 2 | _ => 1 end. +Notation "## x" := ((@pair') _ x) (at level 0, x at level 1). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. +Check ## 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ## 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 7. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "###" := (@pair') (at level 0). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ### _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ### _ 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 8. Notations w/o @ preserves implicit arguments and scopes *) +Notation "####" := pair' (at level 0). +Check #### 0 0 0 : prod' bool bool. +Check fun A (x :prod' bool A) => match x with #### 0 y 0 => 2 | _ => 1 end. + +(* 9. Notations w/o @ but arguments do not preserve further implicit arguments and scopes *) +Notation "##### x" := (pair' x) (at level 0, x at level 1). +Check ##### 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ##### 0 _ y 0%bool => 2 | _ => 1 end. -- cgit v1.2.3 From fc7264feee8ee62aeda8af4d756deb009f29fc2b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Mar 2016 11:13:21 +0100 Subject: Try eta-expansion of records only on non-recursive ones --- pretyping/unification.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 03a700e176..15e8022af0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -629,7 +629,7 @@ let is_eta_constructor_app env ts f l1 term = | Construct (((_, i as ind), j), u) when i == 0 && j == 1 -> let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with - | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite && + | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite && Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (** Check that the other term is neutral *) is_neutral env ts term -- cgit v1.2.3 From 1b984a697076aae9bbdb96efbecbbbec274cbf2a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Mar 2016 11:14:44 +0100 Subject: Typeclasses: respect Declare Instance priority --- toplevel/classes.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 898ef0d9e1..0a83c49c8d 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -198,7 +198,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in Universes.register_universe_binders (ConstRef cst) pl; - instance_hook k None global imps ?hook (ConstRef cst); id + instance_hook k pri global imps ?hook (ConstRef cst); id end else ( let props = -- cgit v1.2.3 From 6caf8b877e44862b21104236423c23972166cdd7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Mar 2016 11:14:03 +0100 Subject: Fix the comment of Refine.refine --- proofs/proofview.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index dc97e44b6f..7f95a053a8 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -505,9 +505,9 @@ module Refine : sig (** In [refine ?unsafe t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the - new holes created by [t] become the new subgoals. Exception + new holes created by [t] become the new subgoals. Exceptions raised during the interpretation of [t] are caught and result in - tactic failures. If [unsafe] is [true] (default) [t] is + tactic failures. If [unsafe] is [false] (default is [true]) [t] is type-checked beforehand. *) (** {7 Helper functions} *) -- cgit v1.2.3 From e171456870f9893d582d53114d4f87e634c007e5 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Mar 2016 14:24:33 +0100 Subject: Trying to circumvent hdiutil error 5341 by padding. When generating the OS X Coq + CoqIDE bundle, hdiutil often produces error 5341. This seems to be a known bug on Apple's side, occurring for some sizes of dmg files. We try to change the current (problematic) size by adding a file full of random bits. --- dev/make-macos-dmg.sh | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/dev/make-macos-dmg.sh b/dev/make-macos-dmg.sh index 20b7b5b531..b43ada9076 100755 --- a/dev/make-macos-dmg.sh +++ b/dev/make-macos-dmg.sh @@ -28,4 +28,8 @@ codesign -f -s - $APP mkdir -p $DMGDIR ln -sf /Applications $DMGDIR/Applications cp -r $APP $DMGDIR + +# Temporary countermeasure to hdiutil error 5341 +head -c9703424 /dev/urandom > $DMGDIR/.padding + hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg -- cgit v1.2.3 From 779fd5d9a4982b19fd257b61f444ae8e6155dcbe Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Mar 2016 19:50:29 +0100 Subject: Fix bug when a sort is ascribed to a Record Forcefully equating it to the inferred level is not always desirable or possible. --- test-suite/success/univers.v | 17 +++++++++++++++++ toplevel/record.ml | 13 +++++++------ 2 files changed, 24 insertions(+), 6 deletions(-) diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index e00701fb68..269359ae62 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -60,3 +60,20 @@ Qed. (* Submitted by Danko Ilik (bug report #1507); related to LetIn *) Record U : Type := { A:=Type; a:A }. + +(** Check assignement of sorts to inductives and records. *) + +Variable sh : list nat. + +Definition is_box_in_shape (b :nat * nat) := True. +Definition myType := Type. + +Module Ind. +Inductive box_in : myType := + myBox (coord : nat * nat) (_ : is_box_in_shape coord) : box_in. +End Ind. + +Module Rec. +Record box_in : myType := + BoxIn { coord :> nat * nat; _ : is_box_in_shape coord }. +End Rec. \ No newline at end of file diff --git a/toplevel/record.ml b/toplevel/record.ml index 04da628c33..200d1a9387 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -140,12 +140,13 @@ let typecheck_params_and_fields def id pl t ps nots fs = arity, evars else let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in - if Univ.is_small_univ univ then - (* We can assume that the level aritysort is not constrained - and clear it. *) - mkArity (ctx, Sorts.sort_of_univ univ), - Evd.set_eq_sort env_ar evars (Prop Pos) aritysort - else arity, evars + if Univ.is_small_univ univ && + Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars aritysort) then + (* We can assume that the level in aritysort is not constrained + and clear it, if it is flexible *) + mkArity (ctx, Sorts.sort_of_univ univ), + Evd.set_eq_sort env_ar evars (Prop Pos) aritysort + else arity, evars in let evars, nf = Evarutil.nf_evars_and_universes evars in let newps = map_rel_context nf newps in -- cgit v1.2.3 From 8f5ca2a6100eb243d2a9842a13e02b793ee0aea1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Mar 2016 11:13:21 +0100 Subject: Try eta-expansion of records only on non-recursive ones --- pretyping/unification.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 31fd711bf9..9b6e856b80 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -609,7 +609,7 @@ let is_eta_constructor_app env ts f l1 term = | Construct (((_, i as ind), j), u) when i == 0 && j == 1 -> let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with - | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite && + | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite && Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (** Check that the other term is neutral *) is_neutral env ts term -- cgit v1.2.3 From 45e43916a7ce756b617b7ba3f8062f7956872fb3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Mar 2016 17:10:16 +0100 Subject: Tentative fix for bug #4614: "Fully check the document" is uninterruptable. The SIGINT sent to the master coqtop process was lost in a watchdog thread, so that the STM resulted in an inconsistent state. This patch catches gracefully the exception and kills the task as if it were normally cancelled. Note that it probably won't work on non-POSIX architectures, but it does not really matter because interrupt was already badly handled anyway. --- stm/asyncTaskQueue.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 5f018ec39d..8649a14c54 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -184,6 +184,13 @@ module Make(T : Task) = struct let () = Unix.sleep 1 in kill_if () in + let kill_if () = + try kill_if () + with Sys.Break -> + let () = stop_waiting := true in + let () = TQueue.broadcast queue in + Worker.kill proc + in let _ = Thread.create kill_if () in try while true do -- cgit v1.2.3 From e5b40d615d0ed9819f6ac8345ed924d8a501172e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Mar 2016 19:47:49 +0100 Subject: CoqIDE is more resilient to initialization errors. We force the STM to finish after the initialization request so as to raise exceptions that may have been generated by the initialization process. Likewise, we simply die when the initialization request fails in CoqIDE instead of just printing an error message. This is the fix for the underlying issue of bug #4591, but it does not solve the bug yet. --- ide/coqOps.ml | 5 ++++- ide/ide_slave.ml | 1 + 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 58f5eda62e..850b41e596 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -864,7 +864,10 @@ object(self) method initialize = let get_initial_state = let next = function - | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return () + | Fail (_, _, message) -> + let message = "Couldn't initialize coqtop\n\n" ^ message in + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in + ignore (popup#run ()); exit 1 | Good id -> initial_state <- id; Coq.return () in Coq.bind (Coq.init (get_filename ())) next in Coq.seq get_initial_state Coq.PrintOpt.enforce diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index bd98fe16e3..2e6a361c66 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -361,6 +361,7 @@ let init = 0 (Printf.sprintf "Add LoadPath \"%s\". " dir) else Stm.get_current_state (), `NewTip in Stm.set_compilation_hints file; + Stm.finish (); initial_id end -- cgit v1.2.3 From 34c467a4e41e20a9bf1318d47fbc09da94c5ad97 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Mar 2016 19:56:52 +0100 Subject: Fix #4591: Uncaught exception in directory browsing. We protect Sys.readdir calls againts any nasty exception. --- lib/system.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/system.ml b/lib/system.ml index 0ad43a7423..36fdf26089 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -26,6 +26,8 @@ let ok_dirname f = not (String.List.mem f !skipped_dirnames) && (match Unicode.ident_refutation f with None -> true | _ -> false) +let readdir dir = try Sys.readdir dir with any -> [||] + let all_subdirs ~unix_path:root = let l = ref [] in let add f rel = l := (f, rel) :: !l in @@ -38,7 +40,7 @@ let all_subdirs ~unix_path:root = add file newrel; traverse file newrel end) - (Sys.readdir dir) + (readdir dir) in if exists_dir root then traverse root []; List.rev !l @@ -58,7 +60,7 @@ let dirmap = ref StrMap.empty let make_dir_table dir = let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) + Array.fold_left filter_dotfiles StrSet.empty (readdir dir) let exists_in_dir_respecting_case dir bf = let contents, cached = -- cgit v1.2.3 From bfce815bd1fa2c603141661b209a864c67ae1dbf Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 16 Mar 2016 18:00:25 +0100 Subject: Fix incorrect behavior of CS resolution Due to a change in pretyping, using cast annotations as typing constraints, the canonical structure problems given to the unification could contain non-evar-normalized terms, hence we force evar normalization where necessary to ensure the same CS solutions can be found. Here the dependency test is fooled by an erasable dependency, and the following resolution needs a independent codomain for pop b to be well-scoped. --- pretyping/evarconv.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 690b974be5..b8d92b9be7 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -138,6 +138,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = try match kind_of_term t2 with Prod (_,a,b) -> (* assert (l2=[]); *) + let _, a, b = destProd (Evarutil.nf_evar sigma t2) in if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs), (Stack.append_app [|a;pop b|] Stack.empty) -- cgit v1.2.3 From 4849c8eb1b7a386d2abcbc80c40de34b0a69b8ea Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 16 Mar 2016 18:18:54 +0100 Subject: Test file for #4624, fixed by Matthieu's bfce815bd1. --- test-suite/bugs/4624.v | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test-suite/bugs/4624.v diff --git a/test-suite/bugs/4624.v b/test-suite/bugs/4624.v new file mode 100644 index 0000000000..a737afcdab --- /dev/null +++ b/test-suite/bugs/4624.v @@ -0,0 +1,7 @@ +Record foo := mkfoo { type : Type }. + +Canonical Structure fooA (T : Type) := mkfoo (T -> T). + +Definition id (t : foo) (x : type t) := x. + +Definition bar := id _ ((fun x : nat => x) : _). \ No newline at end of file -- cgit v1.2.3 From 29f26d380177495a224c3b94d3309a3d23693d8f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 11:01:32 +0100 Subject: Reducing the number of modules linked in grammar.cma. --- grammar/argextend.ml4 | 15 ++++++--------- grammar/grammar.mllib | 5 ----- grammar/q_util.ml4 | 4 ++-- grammar/q_util.mli | 4 ++-- grammar/tacextend.ml4 | 7 ++----- grammar/vernacextend.ml4 | 7 +++---- lib/ppstyle.ml | 2 +- 7 files changed, 16 insertions(+), 28 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 65dc237bb7..be4097f137 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -82,21 +82,19 @@ let statically_known_possibly_empty s (prods,_) = prods let possibly_empty_subentries loc (prods,act) = - let bind_name id v e = - let s = Names.Id.to_string id in + let bind_name s v e = <:expr< let $lid:s$ = $v$ in $e$ >> in let rec aux = function | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >> - | ExtNonTerminal(_, e, id) :: tl when is_possibly_empty e -> - bind_name id (get_empty_entry e) (aux tl) - | ExtNonTerminal(t, _, id) :: tl -> + | ExtNonTerminal(_, e, s) :: tl when is_possibly_empty e -> + bind_name s (get_empty_entry e) (aux tl) + | ExtNonTerminal(t, _, s) :: tl -> let t = match t with | ExtraArgType _ as t -> t | _ -> assert false in (* We check at runtime if extraarg s parses "epsilon" *) - let s = Names.Id.to_string id in <:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with [ None -> raise Exit | Some v -> v ] in $aux tl$ >> @@ -130,7 +128,6 @@ let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> | ExtNonTerminal (t, _, p) :: tl -> - let p = Names.Id.to_string p in <:expr< (fun $lid:p$ -> let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) @@ -312,10 +309,10 @@ EXTEND genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in - ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) + ExtNonTerminal (type_of_user_symbol e, e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in - ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) + ExtNonTerminal (type_of_user_symbol e, e, s) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Lexer.add_keyword s; diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 296d32dc04..6a265bf4a8 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -2,7 +2,6 @@ Coq_config Hook Terminal -Canary Hashset Hashcons CSet @@ -29,14 +28,11 @@ CStack Util Ppstyle Errors -Predicate Segmenttree Unicodetable Unicode Genarg -Names - Stdarg Constrarg @@ -47,7 +43,6 @@ Entry Pcoq Q_util -Egramml Argextend Tacextend Vernacextend diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index c6e2e99668..f013e323ec 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -13,7 +13,7 @@ open Compat type extend_token = | ExtTerminal of string -| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * Names.Id.t +| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * string let mlexpr_of_list f l = List.fold_right @@ -55,7 +55,7 @@ let mlexpr_of_option f = function | Some e -> <:expr< Some $f e$ >> let mlexpr_of_ident id = - <:expr< Names.Id.of_string $str:Names.Id.to_string id$ >> + <:expr< Names.Id.of_string $str:id$ >> let mlexpr_of_token = function | Tok.KEYWORD s -> <:expr< Tok.KEYWORD $mlexpr_of_string s$ >> diff --git a/grammar/q_util.mli b/grammar/q_util.mli index d0e0dab22e..90fe1645fe 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -10,7 +10,7 @@ open Compat (* necessary for camlp4 *) type extend_token = | ExtTerminal of string -| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * Names.Id.t +| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * string val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr @@ -34,7 +34,7 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr -val mlexpr_of_ident : Names.Id.t -> MLast.expr +val mlexpr_of_ident : string -> MLast.expr val mlexpr_of_prod_entry_key : Extend.user_symbol -> MLast.expr diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 10afcdd21a..c35fa00d2e 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -27,7 +27,6 @@ let plugin_name = <:expr< __coq_plugin_name >> let rec make_patt = function | [] -> <:patt< [] >> | ExtNonTerminal (_, _, p) :: l -> - let p = Names.Id.to_string p in <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l @@ -43,7 +42,6 @@ let rec mlexpr_of_argtype loc = function let rec make_when loc = function | [] -> <:expr< True >> | ExtNonTerminal (t, _, p) :: l -> - let p = Names.Id.to_string p in let l = make_when loc l in let t = mlexpr_of_argtype loc t in <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >> @@ -52,7 +50,6 @@ let rec make_when loc = function let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> | ExtNonTerminal (t, _, p) :: l -> - let p = Names.Id.to_string p in let loc = MLast.loc_of_expr e in let e = make_let raw e l in let v = @@ -198,10 +195,10 @@ EXTEND tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in - ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) + ExtNonTerminal (type_of_user_symbol e, e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in - ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) + ExtNonTerminal (type_of_user_symbol e, e, s) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); ExtTerminal s diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 57079fccda..3bb1e09076 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -35,7 +35,6 @@ type rule = { let rec make_let e = function | [] -> e | ExtNonTerminal (t, _, p) :: l -> - let p = Names.Id.to_string p in let loc = MLast.loc_of_expr e in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> @@ -49,7 +48,7 @@ let make_clause { r_patt = pt; r_branch = e; } = (* To avoid warnings *) let mk_ignore c pt = let names = CList.map_filter (function - | ExtNonTerminal (_, _, p) -> Some (Names.Id.to_string p) + | ExtNonTerminal (_, _, p) -> Some p | _ -> None) pt in let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in let names = List.fold_left fold <:expr< () >> names in @@ -181,10 +180,10 @@ EXTEND args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in - ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) + ExtNonTerminal (type_of_user_symbol e, e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in - ExtNonTerminal (type_of_user_symbol e, e, Names.Id.of_string s) + ExtNonTerminal (type_of_user_symbol e, e, s) | s = STRING -> ExtTerminal s ] ] diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml index bb73fbdf56..3ecaac0391 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util +module String = CString type t = string (** We use the concatenated string, with dots separating each string. We -- cgit v1.2.3 From 22c1e7c3f1d86902b1abf2d887e0e9bf93ddb60d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 11:56:51 +0100 Subject: Removing dead code in Q_util. --- grammar/q_util.ml4 | 22 ---------------------- grammar/q_util.mli | 8 -------- 2 files changed, 30 deletions(-) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index f013e323ec..1848bf85f1 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -28,16 +28,6 @@ let mlexpr_of_pair m1 m2 (a1,a2) = let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in <:expr< ($e1$, $e2$) >> -let mlexpr_of_triple m1 m2 m3 (a1,a2,a3)= - let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 in - let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e3) in - <:expr< ($e1$, $e2$, $e3$) >> - -let mlexpr_of_quadruple m1 m2 m3 m4 (a1,a2,a3,a4)= - let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 and e4 = m4 a4 in - let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e4) in - <:expr< ($e1$, $e2$, $e3$, $e4$) >> - (* We don't give location for tactic quotation! *) let loc = CompatLoc.ghost @@ -57,18 +47,6 @@ let mlexpr_of_option f = function let mlexpr_of_ident id = <:expr< Names.Id.of_string $str:id$ >> -let mlexpr_of_token = function -| Tok.KEYWORD s -> <:expr< Tok.KEYWORD $mlexpr_of_string s$ >> -| Tok.PATTERNIDENT s -> <:expr< Tok.PATTERNIDENT $mlexpr_of_string s$ >> -| Tok.IDENT s -> <:expr< Tok.IDENT $mlexpr_of_string s$ >> -| Tok.FIELD s -> <:expr< Tok.FIELD $mlexpr_of_string s$ >> -| Tok.INT s -> <:expr< Tok.INT $mlexpr_of_string s$ >> -| Tok.INDEX s -> <:expr< Tok.INDEX $mlexpr_of_string s$ >> -| Tok.STRING s -> <:expr< Tok.STRING $mlexpr_of_string s$ >> -| Tok.LEFTQMARK -> <:expr< Tok.LEFTQMARK >> -| Tok.BULLET s -> <:expr< Tok.BULLET $mlexpr_of_string s$ >> -| Tok.EOI -> <:expr< Tok.EOI >> - let repr_entry e = let entry u = let _ = Pcoq.get_entry u e in diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 90fe1645fe..837ec6fb02 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -18,14 +18,6 @@ val mlexpr_of_pair : ('a -> MLast.expr) -> ('b -> MLast.expr) -> 'a * 'b -> MLast.expr -val mlexpr_of_triple : - ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr) - -> 'a * 'b * 'c -> MLast.expr - -val mlexpr_of_quadruple : - ('a -> MLast.expr) -> ('b -> MLast.expr) -> - ('c -> MLast.expr) -> ('d -> MLast.expr) -> 'a * 'b * 'c * 'd -> MLast.expr - val mlexpr_of_bool : bool -> MLast.expr val mlexpr_of_int : int -> MLast.expr -- cgit v1.2.3 From 92a6a72ec4680d0f241e8b1ddd7b87f7ad11f65e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 14:01:37 +0100 Subject: Relying on parsing rules rather than genarg to check if an argument is empty. --- parsing/pcoq.ml | 7 +++++++ parsing/pcoq.mli | 2 ++ toplevel/metasyntax.ml | 38 +++++++------------------------------- 3 files changed, 16 insertions(+), 31 deletions(-) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index cf65262c4a..52437e3867 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -853,3 +853,10 @@ let list_entry_names () = let ans = Hashtbl.fold add_entry (get_utable uprim) [] in let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in Hashtbl.fold add_entry (get_utable utactic) ans + +let epsilon_value f e = + let r = Rule (Next (Stop, e), fun x _ -> f x) in + let ext = of_coq_extend_statement (None, [None, None, [r]]) in + let entry = G.entry_create "epsilon" in + let () = maybe_uncurry (Gram.extend entry) ext in + try Some (parse_string entry "") with _ -> None diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index b26c3044bd..7e0c89fd12 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -272,6 +272,8 @@ val symbol_of_constr_prod_entry_key : gram_assoc option -> val name_of_entry : 'a Gram.entry -> 'a Entry.t +val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option + (** Binding general entry keys to symbols *) type 's entry_name = EntryName : diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 98d1a23770..82bd5dac4c 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -158,36 +158,10 @@ type ml_tactic_grammar_obj = { exception NonEmptyArgument -let default_empty_value wit = match Genarg.default_empty_value wit with -| None -> raise NonEmptyArgument -| Some v -> v - -let rec empty_value : type a b c s. (a, b, c) Genarg.genarg_type -> (s, a) entry_key -> a = -fun wit key -> match key with -| Alist1 key -> - begin match wit with - | Genarg.ListArg wit -> [empty_value wit key] - | Genarg.ExtraArg _ -> default_empty_value wit - end -| Alist1sep (key, _) -> - begin match wit with - | Genarg.ListArg wit -> [empty_value wit key] - | Genarg.ExtraArg _ -> default_empty_value wit - end -| Alist0 _ -> [] -| Alist0sep (_, _) -> [] -| Amodifiers _ -> [] -| Aopt _ -> None -| Aentry _ -> default_empty_value wit -| Aentryl (_, _) -> default_empty_value wit - -| Atoken _ -> raise NonEmptyArgument -| Aself -> raise NonEmptyArgument -| Anext -> raise NonEmptyArgument - (** ML tactic notations whose use can be restricted to an identifier are added as true Ltac entries. *) let extend_atomic_tactic name entries = + let open Tacexpr in let map_prod prods = let (hd, rem) = match prods with | GramTerminal s :: rem -> (s, rem) @@ -197,8 +171,11 @@ let extend_atomic_tactic name entries = | GramTerminal s -> raise NonEmptyArgument | GramNonTerminal (_, typ, e) -> let Genarg.Rawwit wit = typ in - let def = Genarg.in_gen typ (empty_value wit e) in - Tacintern.intern_genarg Tacintern.fully_empty_glob_sign def + let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in + let default = epsilon_value inj e in + match default with + | None -> raise NonEmptyArgument + | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def in try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None in @@ -206,8 +183,7 @@ let extend_atomic_tactic name entries = let add_atomic i args = match args with | None -> () | Some (id, args) -> - let open Tacexpr in - let args = List.map (fun a -> TacGeneric a) args in + let args = List.map (fun a -> Tacexp a) args in let entry = { mltac_name = name; mltac_index = i } in let body = TacML (Loc.ghost, entry, args) in Tacenv.register_ltac false false (Names.Id.of_string id) body -- cgit v1.2.3 From 2537e84ba9fa92db6cfd3d7f5e400b1716c31246 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 14:42:51 +0100 Subject: Removing the registering of default values for generic arguments. --- grammar/argextend.ml4 | 81 +-------------------------------------- interp/constrarg.ml | 34 ++++++++-------- interp/stdarg.ml | 10 ++--- lib/genarg.ml | 16 +------- lib/genarg.mli | 6 +-- plugins/decl_mode/g_decl_mode.ml4 | 2 +- plugins/funind/g_indfun.ml4 | 2 +- tactics/extratactics.ml4 | 4 +- tactics/g_rewrite.ml4 | 2 +- tactics/taccoerce.ml | 4 +- tactics/tacinterp.ml | 2 +- tactics/tauto.ml | 2 +- toplevel/g_obligations.ml4 | 2 +- 13 files changed, 38 insertions(+), 129 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index be4097f137..46c68ecc3a 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -48,82 +48,6 @@ let has_extraarg l = in List.exists check l -let rec is_possibly_empty = function -| Uopt _ -> true -| Ulist0 _ -> true -| Ulist0sep _ -> true -| Umodifiers _ -> true -| Ulist1 t -> is_possibly_empty t -| Ulist1sep (t, _) -> is_possibly_empty t -| _ -> false - -let rec get_empty_entry = function -| Uopt _ -> <:expr< None >> -| Ulist0 _ -> <:expr< [] >> -| Ulist0sep _ -> <:expr< [] >> -| Umodifiers _ -> <:expr< [] >> -| Ulist1 t -> <:expr< [$get_empty_entry t$] >> -| Ulist1sep (t, _) -> <:expr< [$get_empty_entry t$] >> -| _ -> assert false - -let statically_known_possibly_empty s (prods,_) = - List.for_all (function - | ExtNonTerminal(t, e, _) -> - begin match t with - | ExtraArgType s' -> - (* For ExtraArg we don't know (we'll have to test dynamically) *) - (* unless it is a recursive call *) - s <> s' - | _ -> - is_possibly_empty e - end - | ExtTerminal _ -> - (* This consumes a token for sure *) false) - prods - -let possibly_empty_subentries loc (prods,act) = - let bind_name s v e = - <:expr< let $lid:s$ = $v$ in $e$ >> - in - let rec aux = function - | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >> - | ExtNonTerminal(_, e, s) :: tl when is_possibly_empty e -> - bind_name s (get_empty_entry e) (aux tl) - | ExtNonTerminal(t, _, s) :: tl -> - let t = match t with - | ExtraArgType _ as t -> t - | _ -> assert false - in - (* We check at runtime if extraarg s parses "epsilon" *) - <:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with - [ None -> raise Exit - | Some v -> v ] in $aux tl$ >> - | _ -> assert false (* already filtered out *) in - if has_extraarg prods then - (* Needs a dynamic check; catch all exceptions if ever some rhs raises *) - (* an exception rather than returning a value; *) - (* declares loc because some code can refer to it; *) - (* ensures loc is used to avoid "unused variable" warning *) - (true, <:expr< try Some $aux prods$ - with [ Exit -> None ] >>) - else - (* Static optimisation *) - (false, aux prods) - -let make_possibly_empty_subentries loc s cl = - let cl = List.filter (statically_known_possibly_empty s) cl in - if cl = [] then - <:expr< None >> - else - let rec aux = function - | (true, e) :: l -> - <:expr< match $e$ with [ Some v -> Some v | None -> $aux l$ ] >> - | (false, e) :: _ -> - <:expr< Some $e$ >> - | [] -> - <:expr< None >> in - aux (List.map (possibly_empty_subentries loc) cl) - let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> @@ -214,12 +138,11 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let wit = <:expr< $lid:"wit_"^s$ >> in let rawwit = <:expr< Genarg.rawwit $wit$ >> in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in - let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$) = let dyn = $dyn$ in - Genarg.make0 ?dyn $default_value$ $se$ >>; + Genarg.make0 ?dyn $se$ >>; <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; @@ -245,7 +168,7 @@ let declare_vernac_argument loc s pr cl = declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) = - Genarg.create_arg None $se$ >>; + Genarg.create_arg $se$ >>; <:str_item< value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; <:str_item< do { diff --git a/interp/constrarg.ml b/interp/constrarg.ml index a48d683754..ead4e39692 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -20,48 +20,48 @@ let loc_of_or_by_notation f = function | ByNotation (loc,s,_) -> loc let wit_int_or_var = - Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) None "int_or_var" + Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) "int_or_var" let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = - Genarg.make0 None "intropattern" + Genarg.make0 "intropattern" let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = - Genarg.make0 None "tactic" + Genarg.make0 "tactic" let wit_ident = - Genarg.make0 None "ident" + Genarg.make0 "ident" let wit_var = - Genarg.make0 ~dyn:(val_tag (topwit wit_ident)) None "var" + Genarg.make0 ~dyn:(val_tag (topwit wit_ident)) "var" -let wit_ref = Genarg.make0 None "ref" +let wit_ref = Genarg.make0 "ref" -let wit_quant_hyp = Genarg.make0 None "quant_hyp" +let wit_quant_hyp = Genarg.make0 "quant_hyp" let wit_sort : (glob_sort, glob_sort, sorts) genarg_type = - Genarg.make0 None "sort" + Genarg.make0 "sort" let wit_constr = - Genarg.make0 None "constr" + Genarg.make0 "constr" let wit_constr_may_eval = - Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) None "constr_may_eval" + Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) "constr_may_eval" -let wit_uconstr = Genarg.make0 None "uconstr" +let wit_uconstr = Genarg.make0 "uconstr" -let wit_open_constr = Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) None "open_constr" +let wit_open_constr = Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" -let wit_constr_with_bindings = Genarg.make0 None "constr_with_bindings" +let wit_constr_with_bindings = Genarg.make0 "constr_with_bindings" -let wit_bindings = Genarg.make0 None "bindings" +let wit_bindings = Genarg.make0 "bindings" let wit_hyp_location_flag : 'a Genarg.uniform_genarg_type = - Genarg.make0 None "hyp_location_flag" + Genarg.make0 "hyp_location_flag" -let wit_red_expr = Genarg.make0 None "redexpr" +let wit_red_expr = Genarg.make0 "redexpr" let wit_clause_dft_concl = - Genarg.make0 None "clause_dft_concl" + Genarg.make0 "clause_dft_concl" (** Register location *) diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 9c3ed94130..56b995e537 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -9,19 +9,19 @@ open Genarg let wit_unit : unit uniform_genarg_type = - make0 None "unit" + make0 "unit" let wit_bool : bool uniform_genarg_type = - make0 None "bool" + make0 "bool" let wit_int : int uniform_genarg_type = - make0 None "int" + make0 "int" let wit_string : string uniform_genarg_type = - make0 None "string" + make0 "string" let wit_pre_ident : string uniform_genarg_type = - make0 None "preident" + make0 "preident" let () = register_name0 wit_unit "Stdarg.wit_unit" let () = register_name0 wit_bool "Stdarg.wit_bool" diff --git a/lib/genarg.ml b/lib/genarg.ml index c7273ac93e..7aada461f5 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -246,7 +246,6 @@ struct end type ('raw, 'glb, 'top) load = { - nil : 'raw option; dyn : 'top Val.tag; } @@ -254,30 +253,19 @@ module LoadMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) load end) let arg0_map = ref LoadMap.empty -let create_arg opt ?dyn name = +let create_arg ?dyn name = match ArgT.name name with | Some _ -> Errors.anomaly (str "generic argument already declared: " ++ str name) | None -> let dyn = match dyn with None -> Val.Base (ValT.create name) | Some dyn -> dyn in - let obj = LoadMap.Pack { nil = opt; dyn; } in + let obj = LoadMap.Pack { dyn; } in let name = ArgT.create name in let () = arg0_map := LoadMap.add name obj !arg0_map in ExtraArg name let make0 = create_arg -let rec default_empty_value : type a b c. (a, b, c) genarg_type -> a option = function -| ListArg _ -> Some [] -| OptArg _ -> Some None -| PairArg (t1, t2) -> - begin match default_empty_value t1, default_empty_value t2 with - | Some v1, Some v2 -> Some (v1, v2) - | _ -> None - end -| ExtraArg s -> - match LoadMap.find s !arg0_map with LoadMap.Pack obj -> obj.nil - let rec val_tag : type a b c. (a, b, c) genarg_type -> c Val.tag = function | ListArg t -> Val.List (val_tag t) | OptArg t -> Val.Opt (val_tag t) diff --git a/lib/genarg.mli b/lib/genarg.mli index ce0536cf49..d509649f22 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -110,11 +110,11 @@ end type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision when the three types agree. *) -val make0 : 'raw option -> ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type +val make0 : ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Create a new generic type of argument: force to associate unique ML types at each of the three levels. *) -val create_arg : 'raw option -> ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type +val create_arg : ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Alias for [make0]. *) (** {5 Specialized types} *) @@ -250,8 +250,6 @@ val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> (** {5 Magic used by the parser} *) -val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option - val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit (** Used by the extension to give a name to types. The string should be the absolute path of the argument witness, e.g. diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index b62cfd6add..2d096a1081 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -87,7 +87,7 @@ let vernac_proof_instr instr = (* Only declared at raw level, because only used in vernac commands. *) let wit_proof_instr : (raw_proof_instr, glob_proof_instr, proof_instr) Genarg.genarg_type = - Genarg.make0 None "proof_instr" + Genarg.make0 "proof_instr" (* We create a new parser entry [proof_mode]. The Declarative proof mode will replace the normal parser entry for tactics with this one. *) diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 97b9e95e10..61ada5cc8c 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -146,7 +146,7 @@ module Tactic = Pcoq.Tactic type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) = - Genarg.create_arg None "function_rec_definition_loc" + Genarg.create_arg "function_rec_definition_loc" let function_rec_definition_loc = Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 85b9d6a08f..ae8b83b95e 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -931,9 +931,9 @@ type cmp = type 'i test = | Test of cmp * 'i * 'i -let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 None "cmp" +let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 "cmp" let wit_test : (int or_var test,int or_var test,int test) Genarg.genarg_type = - Genarg.make0 None "tactest" + Genarg.make0 "tactest" let pr_cmp = function | Eq -> Pp.str"=" diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 index 6b6dc7b21a..8b012aa88e 100644 --- a/tactics/g_rewrite.ml4 +++ b/tactics/g_rewrite.ml4 @@ -184,7 +184,7 @@ END type binders_argtype = local_binder list let wit_binders = - (Genarg.create_arg None "binders" : binders_argtype Genarg.uniform_genarg_type) + (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) let binders = Pcoq.create_generic_entry "binders" (Genarg.rawwit wit_binders) diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 0cd3e09446..358f6d6468 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -18,11 +18,11 @@ open Constrarg exception CannotCoerceTo of string let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) = - Genarg.create_arg None "constr_context" + Genarg.create_arg "constr_context" (* includes idents known to be bound and references *) let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = - Genarg.create_arg None "constr_under_binders" + Genarg.create_arg "constr_under_binders" let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> let Val.Dyn (t, _) = v in diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 32f7c3c61c..36faba1137 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -109,7 +109,7 @@ type tacvalue = | VRec of value Id.Map.t ref * glob_tactic_expr let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = - Genarg.create_arg None "tacvalue" + Genarg.create_arg "tacvalue" let of_tacvalue v = in_gen (topwit wit_tacvalue) v let to_tacvalue v = out_gen (topwit wit_tacvalue) v diff --git a/tactics/tauto.ml b/tactics/tauto.ml index d3e0b1f449..a86fdb98a9 100644 --- a/tactics/tauto.ml +++ b/tactics/tauto.ml @@ -55,7 +55,7 @@ type tauto_flags = { } let wit_tauto_flags : tauto_flags uniform_genarg_type = - Genarg.create_arg None "tauto_flags" + Genarg.create_arg "tauto_flags" let assoc_flags ist = let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in diff --git a/toplevel/g_obligations.ml4 b/toplevel/g_obligations.ml4 index d620febbc1..32ccf21d2b 100644 --- a/toplevel/g_obligations.ml4 +++ b/toplevel/g_obligations.ml4 @@ -32,7 +32,7 @@ let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Spec type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = - Genarg.create_arg None "withtac" + Genarg.create_arg "withtac" let withtac = Pcoq.create_generic_entry "withtac" (Genarg.rawwit wit_withtac) -- cgit v1.2.3 From d66fe71c93bc06f6006c64118deb1d5b01bf7487 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 16:01:23 +0100 Subject: Adding a universe argument to Pcoq.create_generic_entry. --- grammar/argextend.ml4 | 4 ++-- parsing/pcoq.ml | 2 +- parsing/pcoq.mli | 4 ++-- plugins/decl_mode/g_decl_mode.ml4 | 2 +- plugins/funind/g_indfun.ml4 | 2 +- tactics/g_rewrite.ml4 | 2 +- toplevel/g_obligations.ml4 | 2 +- 7 files changed, 9 insertions(+), 9 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 46c68ecc3a..57ae357dec 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -147,7 +147,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; <:str_item< - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; + value $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ $rawwit$ >>; <:str_item< do { Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule @@ -170,7 +170,7 @@ let declare_vernac_argument loc s pr cl = value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) = Genarg.create_arg $se$ >>; <:str_item< - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; + value $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ $rawwit$ >>; <:str_item< do { Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule $wit$ diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 52437e3867..e150578196 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -251,7 +251,7 @@ let create_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.ent let create_constr_entry s = create_entry uconstr s (rawwit wit_constr) -let create_generic_entry s wit = create_entry utactic s wit +let create_generic_entry = create_entry (* [make_gen_entry] builds entries extensible by giving its name (a string) *) (* For entries extensible only via the ML name, Gram.entry_create is enough *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 7e0c89fd12..625f0370e6 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -162,8 +162,8 @@ val uvernac : gram_universe val get_entry : gram_universe -> string -> typed_entry -val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> - 'a Gram.entry +val create_generic_entry : gram_universe -> string -> + ('a, rlevel) abstract_argument_type -> 'a Gram.entry module Prim : sig diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 2d096a1081..2afbaca2c8 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -95,7 +95,7 @@ let proof_mode : vernac_expr Gram.entry = Gram.entry_create "vernac:proof_command" (* Auxiliary grammar entry. *) let proof_instr : raw_proof_instr Gram.entry = - Pcoq.create_generic_entry "proof_instr" (Genarg.rawwit wit_proof_instr) + Pcoq.create_generic_entry Pcoq.utactic "proof_instr" (Genarg.rawwit wit_proof_instr) let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 61ada5cc8c..dbcdeb83ad 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -149,7 +149,7 @@ let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genar Genarg.create_arg "function_rec_definition_loc" let function_rec_definition_loc = - Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) + Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) GEXTEND Gram GLOBAL: function_rec_definition_loc ; diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 index 8b012aa88e..0ce886373f 100644 --- a/tactics/g_rewrite.ml4 +++ b/tactics/g_rewrite.ml4 @@ -186,7 +186,7 @@ type binders_argtype = local_binder list let wit_binders = (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) -let binders = Pcoq.create_generic_entry "binders" (Genarg.rawwit wit_binders) +let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) open Pcoq diff --git a/toplevel/g_obligations.ml4 b/toplevel/g_obligations.ml4 index 32ccf21d2b..2a5676525a 100644 --- a/toplevel/g_obligations.ml4 +++ b/toplevel/g_obligations.ml4 @@ -34,7 +34,7 @@ type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_a let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = Genarg.create_arg "withtac" -let withtac = Pcoq.create_generic_entry "withtac" (Genarg.rawwit wit_withtac) +let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) GEXTEND Gram GLOBAL: withtac; -- cgit v1.2.3 From 4d13842869647790c9bd3084dce672fee7b648a1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 16:23:59 +0100 Subject: Code factorization in Pcoq. --- parsing/pcoq.ml | 37 +++++++++---------------------------- 1 file changed, 9 insertions(+), 28 deletions(-) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index e150578196..1b1ecaf910 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -200,8 +200,6 @@ let parse_string f x = type gram_universe = Entry.universe -let trace = ref false - let uprim = Entry.uprim let uconstr = Entry.uconstr let utactic = Entry.utactic @@ -231,38 +229,21 @@ let get_typed_entry e = let new_entry etyp u s = let utab = get_utable u in let uname = Entry.univ_name u in - if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr); let _ = Entry.create u s in let ename = uname ^ ":" ^ s in let e = Gram.entry_create ename in Hashtbl.add utab s (TypedEntry (etyp, e)); e -let create_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = +let make_gen_entry u rawwit s = new_entry rawwit u s + +let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in - try - let TypedEntry (typ, e) = Hashtbl.find utab s in - match abstract_argument_type_eq typ etyp with - | None -> - let u = Entry.univ_name u in - failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - | Some Refl -> e - with Not_found -> + if Hashtbl.mem utab s then + let u = Entry.univ_name u in + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); + else new_entry etyp u s -let create_constr_entry s = create_entry uconstr s (rawwit wit_constr) - -let create_generic_entry = create_entry - -(* [make_gen_entry] builds entries extensible by giving its name (a string) *) -(* For entries extensible only via the ML name, Gram.entry_create is enough *) - -let make_gen_entry u rawwit s = - let univ = get_utable u in - let uname = Entry.univ_name u in - let e = Gram.entry_create (uname ^ ":" ^ s) in - let _ = Entry.create u s in - Hashtbl.add univ s (TypedEntry (rawwit, e)); e - (* Initial grammar entries *) module Prim = @@ -312,7 +293,7 @@ module Constr = let operconstr = gec_constr "operconstr" let constr_eoi = eoi_entry constr let lconstr = gec_constr "lconstr" - let binder_constr = create_constr_entry "binder_constr" + let binder_constr = gec_constr "binder_constr" let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" let global = make_gen_entry uconstr (rawwit wit_ref) "global" let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" @@ -612,7 +593,7 @@ let compute_entry allow_create adjust forpat = function try get_entry u n with Not_found when allow_create -> let wit = rawwit wit_constr in - TypedEntry (wit, create_entry u n wit) + TypedEntry (wit, create_generic_entry u n wit) in object_of_typed_entry e, None, true -- cgit v1.2.3 From 82b371aceb1ef6b1e15bdace2cf142e65724a3c6 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 17 Mar 2016 17:53:25 +0100 Subject: Fix #4623: set tactic too weak with universes (regression) The regression was introduced by efa1c32a4d178, which replaced unification by conversion when looking for more occurrences of a subterm. The conversion function called was not the right one, as it was not inferring constraints. --- pretyping/unification.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 9b6e856b80..cd0bbfa300 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1532,8 +1532,9 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = | e when Errors.noncritical e -> raise (NotUnifiable None) in let merge_fun c1 c2 = match c1, c2 with - | Some (evd,c1,_) as x, Some (_,c2,_) -> - if is_conv env sigma c1 c2 then x else raise (NotUnifiable None) + | Some (evd,c1,x), Some (_,c2,_) -> + let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in + if b then Some (evd, c1, x) else raise (NotUnifiable None) | Some _, None -> c1 | None, Some _ -> c2 | None, None -> None in -- cgit v1.2.3 From bcee0b4d6ca113d225fa7df1cbcfa33812b0bd46 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 17 Mar 2016 18:06:50 +0100 Subject: Test file for #4623. --- test-suite/bugs/4623.v | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 test-suite/bugs/4623.v diff --git a/test-suite/bugs/4623.v b/test-suite/bugs/4623.v new file mode 100644 index 0000000000..405d09809c --- /dev/null +++ b/test-suite/bugs/4623.v @@ -0,0 +1,5 @@ +Goal Type -> Type. +set (T := Type). +clearbody T. +refine (@id _). +Qed. \ No newline at end of file -- cgit v1.2.3 From c8dcfc691a649ff6dfb3416809c6ec7b1e629b1f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 17 Mar 2016 20:23:00 +0100 Subject: Fix bug #4627: records with no declared arity can be template polymorphic. As if we were adding : Type. Consistent with inductives with no declared arity. --- test-suite/bugs/closed/4627.v | 49 +++++++++++++++++++++++++++++++++++++++++++ toplevel/record.ml | 6 +++--- 2 files changed, 52 insertions(+), 3 deletions(-) create mode 100644 test-suite/bugs/closed/4627.v diff --git a/test-suite/bugs/closed/4627.v b/test-suite/bugs/closed/4627.v new file mode 100644 index 0000000000..e1206bb37a --- /dev/null +++ b/test-suite/bugs/closed/4627.v @@ -0,0 +1,49 @@ +Class sa (A:Type) := { }. + +Record predicate A (sa:sa A) := + { pred_fun: A->Prop }. +Record ABC : Type := + { abc: Type }. +Record T := + { T_abc: ABC }. + + +(* +sa: forall _ : Type@{Top.179}, Prop +predicate: forall (A : Type@{Top.205}) (_ : sa A), Type@{max(Set+1, Top.205)} +T: Type@{Top.208+1} +ABC: Type@{Top.208+1} +abc: forall _ : ABC, Type@{Top.208} + +Top.205 <= Top.179 predicate <= sa.A +Set < Top.208 Set < abc +Set < Top.205 Set < predicate +*) + +Definition foo : predicate T (Build_sa T) := + {| pred_fun:= fun w => True |}. +(* *) +(* Top.208 < Top.205 <--- added by foo *) +(* *) + +Check predicate nat (Build_sa nat). +(* + +The issue is that the template polymorphic universe of [predicate], Top.205, does not get replaced with the universe of [nat] in the above line. + -Jason Gross + +8.5 -- predicate nat (Build_sa nat): Type@{max(Set+1, Top.205)} +8.5 EXPECTED -- predicate nat (Build_sa nat): Type@{Set+1} +8.4pl4 -- predicate nat {| |}: Type (* max(Set, (Set)+1) *) +*) + +(* This works in 8.4pl4 and SHOULD work in 8.5 *) +Definition bar : ABC := + {| abc:= predicate nat (Build_sa nat) |}. +(* +The term "predicate nat (Build_sa nat)" has type + "Type@{max(Set+1, Top.205)}" +while it is expected to have type "Type@{Top.208}" +(universe inconsistency: Cannot enforce Top.205 <= +Top.208 because Top.208 < Top.205). +*) \ No newline at end of file diff --git a/toplevel/record.ml b/toplevel/record.ml index 200d1a9387..c5ae7e8913 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -114,13 +114,13 @@ let typecheck_params_and_fields def id pl t ps nots fs = (match kind_of_term sred with | Sort s' -> (match Evd.is_sort_variable !evars s' with - | Some l -> evars := Evd.make_flexible_variable !evars true (* (not def) *) l; + | Some l -> evars := Evd.make_flexible_variable !evars true l; sred, true | None -> s, false) | _ -> user_err_loc (constr_loc t,"", str"Sort expected.")) | None -> - let uvarkind = if (* not def *) true then Evd.univ_flexible_alg else Evd.univ_flexible in - mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), false + let uvarkind = Evd.univ_flexible_alg in + mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true in let fullarity = it_mkProd_or_LetIn t' newps in let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in -- cgit v1.2.3 From 4b2cdf733df6dc23247b078679e71da98e54f5cc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 16:57:05 +0100 Subject: Removing the special status of generic entries defined by Coq itself. The ARGUMENT EXTEND macro was discriminating between parsing entries known statically, i.e. defined in Pcoq and unknown entires. Although simplifying a bit the life of the plugin writer, it made actual interpretation difficult to predict and complicated the code of the ARGUMENT EXTEND macro. After this patch, all parsing entries and generic arguments used in an ARGUMENT EXTEND macro must be reachable by the ML code. This requires adding a few more "open Pcoq.X" and "open Constrarg" here and there. --- grammar/argextend.ml4 | 7 +------ grammar/q_util.ml4 | 15 +-------------- interp/constrarg.ml | 10 ++++++++++ interp/constrarg.mli | 12 ++++++++++++ interp/stdarg.ml | 5 +++++ interp/stdarg.mli | 5 +++++ plugins/cc/g_congruence.ml4 | 4 ++++ plugins/derive/g_derive.ml4 | 4 ++++ plugins/extraction/g_extraction.ml4 | 4 ++++ plugins/firstorder/g_ground.ml4 | 4 ++++ plugins/funind/g_indfun.ml4 | 4 ++++ plugins/micromega/g_micromega.ml4 | 4 ++++ plugins/omega/g_omega.ml4 | 2 ++ plugins/quote/g_quote.ml4 | 4 ++++ plugins/romega/g_romega.ml4 | 2 ++ plugins/setoid_ring/g_newring.ml4 | 5 +++++ tactics/coretactics.ml4 | 7 ++++++- tactics/extraargs.ml4 | 4 ++++ tactics/extraargs.mli | 1 - tactics/extratactics.ml4 | 7 +++++++ tactics/g_auto.ml4 | 7 ++++++- tactics/g_class.ml4 | 5 +++++ tactics/g_rewrite.ml4 | 5 +++++ toplevel/g_obligations.ml4 | 6 ++++++ 24 files changed, 110 insertions(+), 23 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 57ae357dec..41e94914ee 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -23,12 +23,7 @@ let qualified_name loc s = let (name, path) = CList.sep_last path in qualified_name loc path name -let mk_extraarg loc s = - try - let name = Genarg.get_name0 s in - qualified_name loc name - with Not_found -> - <:expr< $lid:"wit_"^s$ >> +let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 1848bf85f1..3946d5d2b9 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -47,15 +47,6 @@ let mlexpr_of_option f = function let mlexpr_of_ident id = <:expr< Names.Id.of_string $str:id$ >> -let repr_entry e = - let entry u = - let _ = Pcoq.get_entry u e in - Some (Entry.univ_name u, e) - in - try entry Pcoq.uprim with Not_found -> - try entry Pcoq.uconstr with Not_found -> - try entry Pcoq.utactic with Not_found -> None - let rec mlexpr_of_prod_entry_key = function | Extend.Ulist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> | Extend.Ulist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> @@ -63,11 +54,7 @@ let rec mlexpr_of_prod_entry_key = function | Extend.Ulist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> | Extend.Uopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >> | Extend.Umodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> - | Extend.Uentry e -> - begin match repr_entry e with - | None -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:e$) >> - | Some (u, s) -> <:expr< Pcoq.Aentry (Entry.unsafe_of_name ($str:u$, $str:s$)) >> - end + | Extend.Uentry e -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:e$) >> | Extend.Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (CString.equal e "tactic"); diff --git a/interp/constrarg.ml b/interp/constrarg.ml index ead4e39692..20ee7aa4fb 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -82,3 +82,13 @@ let () = register_name0 wit_quant_hyp "Constrarg.wit_quant_hyp"; register_name0 wit_bindings "Constrarg.wit_bindings"; register_name0 wit_constr_with_bindings "Constrarg.wit_constr_with_bindings"; + () + +(** Aliases *) + +let wit_reference = wit_ref +let wit_global = wit_ref +let wit_clause = wit_clause_dft_concl +let wit_quantified_hypothesis = wit_quant_hyp +let wit_intropattern = wit_intro_pattern +let wit_redexpr = wit_red_expr diff --git a/interp/constrarg.mli b/interp/constrarg.mli index 5c26af3c2a..1197b85a25 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -72,3 +72,15 @@ val wit_red_expr : val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type + +(** Aliases for compatibility *) + +val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type +val wit_global : (reference, global_reference located or_var, global_reference) genarg_type +val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type +val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type +val wit_redexpr : + ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, + (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 56b995e537..e497c996f7 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -28,3 +28,8 @@ let () = register_name0 wit_bool "Stdarg.wit_bool" let () = register_name0 wit_int "Stdarg.wit_int" let () = register_name0 wit_string "Stdarg.wit_string" let () = register_name0 wit_pre_ident "Stdarg.wit_pre_ident" + +(** Aliases for compatibility *) + +let wit_integer = wit_int +let wit_preident = wit_pre_ident diff --git a/interp/stdarg.mli b/interp/stdarg.mli index d8904dab87..e1f648d7fc 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -19,3 +19,8 @@ val wit_int : int uniform_genarg_type val wit_string : string uniform_genarg_type val wit_pre_ident : string uniform_genarg_type + +(** Aliases for compatibility *) + +val wit_integer : int uniform_genarg_type +val wit_preident : string uniform_genarg_type diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 5dbc340caa..9a53e2e16a 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -9,6 +9,10 @@ (*i camlp4deps: "grammar/grammar.cma" i*) open Cctac +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr DECLARE PLUGIN "cc_plugin" diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 index 18570a6846..35a5a7616c 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.ml4 @@ -6,6 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Constrarg +open Pcoq.Prim +open Pcoq.Constr + (*i camlp4deps: "grammar/grammar.cma" i*) let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index aec9586895..7bd07f6255 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -11,6 +11,10 @@ (* ML names *) open Genarg +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr open Pp open Names open Nameops diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 3e8be36993..587d10d1cc 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -15,6 +15,10 @@ open Goptions open Tacticals open Tacinterp open Libnames +open Constrarg +open Stdarg +open Pcoq.Prim +open Pcoq.Tactic DECLARE PLUGIN "ground_plugin" diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index dbcdeb83ad..4bd69b9fe7 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -16,8 +16,12 @@ open Constrexpr open Indfun_common open Indfun open Genarg +open Constrarg open Tacticals open Misctypes +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "recdef_plugin" diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index bfc9c727d5..bca1c2febd 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -18,6 +18,10 @@ open Errors open Misctypes +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Tactic DECLARE PLUGIN "micromega_plugin" diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 04c62eb487..b314e0d85f 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -19,6 +19,8 @@ DECLARE PLUGIN "omega_plugin" open Names open Coq_omega +open Constrarg +open Pcoq.Prim let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index 7a3d7936a6..a15b0eb05a 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -13,6 +13,10 @@ open Misctypes open Tacexpr open Geninterp open Quote +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "quote_plugin" diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 6b2b2bbfaf..61efa9f545 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -12,6 +12,8 @@ DECLARE PLUGIN "romega_plugin" open Names open Refl_omega +open Constrarg +open Pcoq.Prim let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 856ec0db5f..cd1d704dde 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -14,6 +14,11 @@ open Libnames open Printer open Newring_ast open Newring +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "newring_plugin" diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 7da6df717e..73b7bde9d7 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -13,6 +13,11 @@ open Names open Locus open Misctypes open Genredexpr +open Stdarg +open Constrarg +open Pcoq.Constr +open Pcoq.Prim +open Pcoq.Tactic open Proofview.Notations open Sigma.Notations @@ -143,7 +148,7 @@ END TACTIC EXTEND symmetry [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] -| [ "symmetry" clause(cl) ] -> [ Tactics.intros_symmetry cl ] +| [ "symmetry" clause_dft_concl(cl) ] -> [ Tactics.intros_symmetry cl ] END (** Split *) diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 98868e8f91..8215e785ab 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -10,6 +10,10 @@ open Pp open Genarg +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr open Names open Tacexpr open Taccoerce diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 7df845e4bd..f7b379e69e 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -53,7 +53,6 @@ val pr_by_arg_tac : (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> raw_tactic_expr option -> Pp.std_ppcmds - (** Spiwack: Primitive for retroknowledge registration *) val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index ae8b83b95e..52419497d1 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -10,7 +10,12 @@ open Pp open Genarg +open Stdarg +open Constrarg open Extraargs +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic open Mod_subst open Names open Tacexpr @@ -49,6 +54,8 @@ let replace_in_clause_maybe_by ist c1 c2 cl tac = let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) +let clause = Pcoq.Tactic.clause_dft_concl + TACTIC EXTEND replace ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] -> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] diff --git a/tactics/g_auto.ml4 b/tactics/g_auto.ml4 index f4fae763fd..788443944f 100644 --- a/tactics/g_auto.ml4 +++ b/tactics/g_auto.ml4 @@ -10,6 +10,11 @@ open Pp open Genarg +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic open Tacexpr DECLARE PLUGIN "g_auto" @@ -128,7 +133,7 @@ TACTIC EXTEND dfs_eauto END TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause(cl) ] -> [ Eauto.autounfold_tac db cl ] +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] END TACTIC EXTEND autounfold_one diff --git a/tactics/g_class.ml4 b/tactics/g_class.ml4 index 766593543c..9ef1545416 100644 --- a/tactics/g_class.ml4 +++ b/tactics/g_class.ml4 @@ -10,6 +10,11 @@ open Misctypes open Class_tactics +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic +open Stdarg +open Constrarg DECLARE PLUGIN "g_class" diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 index 0ce886373f..c4ef1f297e 100644 --- a/tactics/g_rewrite.ml4 +++ b/tactics/g_rewrite.ml4 @@ -20,6 +20,11 @@ open Extraargs open Tacmach open Tacticals open Rewrite +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "g_rewrite" diff --git a/toplevel/g_obligations.ml4 b/toplevel/g_obligations.ml4 index 2a5676525a..dd11efebd8 100644 --- a/toplevel/g_obligations.ml4 +++ b/toplevel/g_obligations.ml4 @@ -16,6 +16,12 @@ open Libnames open Constrexpr open Constrexpr_ops +open Stdarg +open Constrarg +open Extraargs +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic (* We define new entries for programs, with the use of this module * Subtac. These entries are named Subtac. -- cgit v1.2.3 From 36e865119e5bb5fbaed14428fc89ecd4e96fb7be Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 18:27:39 +0100 Subject: Removing the special status of generic arguments defined by Coq itself. This makes the TACTIC EXTEND macro insensitive to Coq-defined arguments. They now have to be reachable in the ML code. Note that this has some consequences, as the previous macro was potentially mixing grammar entries and arguments as long as their name was the same. Now, each genarg comes with its grammar instead, so there is no way to abuse the macro. --- grammar/argextend.ml4 | 11 ++-- grammar/q_util.ml4 | 26 +++----- grammar/q_util.mli | 2 +- grammar/tacextend.ml4 | 3 +- grammar/vernacextend.ml4 | 8 +-- parsing/highparsing.mllib | 1 - parsing/pcoq.ml | 51 ++++++++++++++-- parsing/pcoq.mli | 2 + plugins/funind/g_indfun.ml4 | 2 +- tactics/coretactics.ml4 | 1 + tactics/extraargs.ml4 | 18 ++++++ tactics/extraargs.mli | 7 +++ tactics/extratactics.ml4 | 12 ++-- tactics/g_obligations.ml4 | 141 ++++++++++++++++++++++++++++++++++++++++++++ tactics/hightactics.mllib | 1 + toplevel/g_obligations.ml4 | 141 -------------------------------------------- 16 files changed, 244 insertions(+), 183 deletions(-) create mode 100644 tactics/g_obligations.ml4 delete mode 100644 toplevel/g_obligations.ml4 diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 41e94914ee..82bc09519b 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -46,18 +46,16 @@ let has_extraarg l = let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> - | ExtNonTerminal (t, _, p) :: tl -> - <:expr< - (fun $lid:p$ -> - let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) - >> + | ExtNonTerminal (t, _, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> | ExtTerminal _ :: tl -> <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function | ExtTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> - | ExtNonTerminal (_, g, _) -> mlexpr_of_prod_entry_key g + | ExtNonTerminal (_, g, _) -> + let base s = <:expr< Pcoq.name_of_entry $lid:s$ >> in + mlexpr_of_prod_entry_key base g let rec make_prod = function | [] -> <:expr< Extend.Stop >> @@ -174,7 +172,6 @@ let declare_vernac_argument loc s pr cl = (fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not wit printer")) } >> ] -open Pcoq open Pcaml open PcamlSig (* necessary for camlp4 *) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 3946d5d2b9..c43ce15be2 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -47,31 +47,23 @@ let mlexpr_of_option f = function let mlexpr_of_ident id = <:expr< Names.Id.of_string $str:id$ >> -let rec mlexpr_of_prod_entry_key = function - | Extend.Ulist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> - | Extend.Ulist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Extend.Ulist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> - | Extend.Ulist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Extend.Uopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >> - | Extend.Umodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> - | Extend.Uentry e -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:e$) >> +let rec mlexpr_of_prod_entry_key f = function + | Extend.Ulist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key f s$ >> + | Extend.Ulist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Extend.Ulist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key f s$ >> + | Extend.Ulist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Extend.Uopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key f s$ >> + | Extend.Umodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key f s$ >> + | Extend.Uentry e -> <:expr< Pcoq.Aentry $f e$ >> | Extend.Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (CString.equal e "tactic"); if l = 5 then <:expr< Pcoq.Aentry (Pcoq.name_of_entry Pcoq.Tactic.binder_tactic) >> else <:expr< Pcoq.Aentryl (Pcoq.name_of_entry Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> -let type_entry u e = - let Pcoq.TypedEntry (t, _) = Pcoq.get_entry u e in - Genarg.unquote t - let rec type_of_user_symbol = function | Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) | Umodifiers s -> Genarg.ListArgType (type_of_user_symbol s) | Uopt s -> Genarg.OptArgType (type_of_user_symbol s) -| Uentry e | Uentryl (e, _) -> - try type_entry Pcoq.uprim e with Not_found -> - try type_entry Pcoq.uconstr e with Not_found -> - try type_entry Pcoq.utactic e with Not_found -> - Genarg.ExtraArgType e +| Uentry e | Uentryl (e, _) -> Genarg.ExtraArgType e diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 837ec6fb02..712aa8509d 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -28,6 +28,6 @@ val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr val mlexpr_of_ident : string -> MLast.expr -val mlexpr_of_prod_entry_key : Extend.user_symbol -> MLast.expr +val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> Extend.user_symbol -> MLast.expr val type_of_user_symbol : Extend.user_symbol -> Genarg.argument_type diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index c35fa00d2e..8c85d01629 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -85,8 +85,9 @@ let make_fun_clauses loc s l = let make_prod_item = function | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> | ExtNonTerminal (nt, g, id) -> + let base s = <:expr< Pcoq.genarg_grammar $mk_extraarg loc s$ >> in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ - $mlexpr_of_prod_entry_key g$ >> + $mlexpr_of_prod_entry_key base g$ >> let mlexpr_of_clause cl = mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 3bb1e09076..d8c8850884 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -42,7 +42,7 @@ let rec make_let e = function let make_clause { r_patt = pt; r_branch = e; } = (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr e) pt)), + vala None, make_let e pt) (* To avoid warnings *) @@ -58,11 +58,11 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = match c ,cg with | Some c, _ -> (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr c) pt)), + vala None, make_let (mk_ignore c pt) pt) | None, Some cg -> (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr cg) pt)), + vala None, <:expr< fun () -> $cg$ $str:s$ >>) | None, None -> msg_warning (strbrk("Vernac entry \""^s^"\" misses a classifier. "^ @@ -85,7 +85,7 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = strbrk("Specific classifiers have precedence over global "^ "classifiers. Only one classifier is called.")++fnl()); (make_patt pt, - vala (Some (make_when loc pt)), + vala None, <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) let make_fun_clauses loc s l = diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index 13ed804641..eed6caea30 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -4,4 +4,3 @@ G_prim G_proofs G_tactic G_ltac -G_obligations diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 1b1ecaf910..05fd9f9d8c 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -229,12 +229,23 @@ let get_typed_entry e = let new_entry etyp u s = let utab = get_utable u in let uname = Entry.univ_name u in - let _ = Entry.create u s in + let entry = Entry.create u s in let ename = uname ^ ":" ^ s in let e = Gram.entry_create ename in - Hashtbl.add utab s (TypedEntry (etyp, e)); e + Hashtbl.add utab s (TypedEntry (etyp, e)); (entry, e) -let make_gen_entry u rawwit s = new_entry rawwit u s +let make_gen_entry u rawwit s = snd (new_entry rawwit u s) + +module GrammarObj = +struct + type ('r, _, _) obj = 'r Entry.t + let name = "grammar" + let default _ = None +end + +module Grammar = Register(GrammarObj) + +let genarg_grammar wit = Grammar.obj wit let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in @@ -242,7 +253,10 @@ let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a let u = Entry.univ_name u in failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); else - new_entry etyp u s + let (entry, e) = new_entry etyp u s in + let Rawwit t = etyp in + let () = Grammar.register0 t entry in + e (* Initial grammar entries *) @@ -841,3 +855,32 @@ let epsilon_value f e = let entry = G.entry_create "epsilon" in let () = maybe_uncurry (Gram.extend entry) ext in try Some (parse_string entry "") with _ -> None + +(** Registering grammar of generic arguments *) + +let () = + let open Stdarg in + let open Constrarg in +(* Grammar.register0 wit_unit; *) +(* Grammar.register0 wit_bool; *) + Grammar.register0 wit_int (name_of_entry Prim.integer); + Grammar.register0 wit_string (name_of_entry Prim.string); + Grammar.register0 wit_pre_ident (name_of_entry Prim.preident); + Grammar.register0 wit_int_or_var (name_of_entry Tactic.int_or_var); + Grammar.register0 wit_intro_pattern (name_of_entry Tactic.simple_intropattern); + Grammar.register0 wit_ident (name_of_entry Prim.ident); + Grammar.register0 wit_var (name_of_entry Prim.var); + Grammar.register0 wit_ref (name_of_entry Prim.reference); + Grammar.register0 wit_quant_hyp (name_of_entry Tactic.quantified_hypothesis); + Grammar.register0 wit_sort (name_of_entry Constr.sort); + Grammar.register0 wit_constr (name_of_entry Constr.constr); + Grammar.register0 wit_constr_may_eval (name_of_entry Tactic.constr_may_eval); + Grammar.register0 wit_uconstr (name_of_entry Tactic.uconstr); + Grammar.register0 wit_open_constr (name_of_entry Tactic.open_constr); + Grammar.register0 wit_constr_with_bindings (name_of_entry Tactic.constr_with_bindings); + Grammar.register0 wit_bindings (name_of_entry Tactic.bindings); +(* Grammar.register0 wit_hyp_location_flag; *) + Grammar.register0 wit_red_expr (name_of_entry Tactic.red_expr); + Grammar.register0 wit_tactic (name_of_entry Tactic.tactic); + Grammar.register0 wit_clause_dft_concl (name_of_entry Tactic.clause_dft_concl); + () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 625f0370e6..b1353ef8ad 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -160,6 +160,8 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe +val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t + val get_entry : gram_universe -> string -> typed_entry val create_generic_entry : gram_universe -> string -> diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 4bd69b9fe7..e93c395e3d 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -94,7 +94,7 @@ let out_disjunctive = function | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected." -ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat +ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] | [] ->[ None ] END diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 73b7bde9d7..6c02a7202f 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -15,6 +15,7 @@ open Misctypes open Genredexpr open Stdarg open Constrarg +open Extraargs open Pcoq.Constr open Pcoq.Prim open Pcoq.Tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 8215e785ab..d33ec91f9d 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -55,6 +55,14 @@ ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient | [ ] -> [ true ] END +let pr_int _ _ _ i = Pp.int i + +let _natural = Pcoq.Prim.natural + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int +| [ _natural(i) ] -> [ i ] +END + let pr_orient = pr_orient () () () @@ -122,6 +130,8 @@ let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) let glob_glob = Tacintern.intern_constr +let pr_lconstr _ prc _ c = prc c + let subst_glob = Tacsubst.subst_glob_constr_and_expr ARGUMENT EXTEND glob @@ -139,6 +149,14 @@ ARGUMENT EXTEND glob [ constr(c) ] -> [ c ] END +let l_constr = Pcoq.Constr.lconstr + +ARGUMENT EXTEND lconstr + TYPED AS constr + PRINTED BY pr_lconstr + [ l_constr(c) ] -> [ c ] +END + ARGUMENT EXTEND lglob PRINTED BY pr_globc diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index f7b379e69e..14aa69875f 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -21,6 +21,8 @@ val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg val pr_occurrences : int list or_var -> Pp.std_ppcmds val occurrences_of : int list -> Locus.occurrences +val wit_natural : int Genarg.uniform_genarg_type + val wit_glob : (constr_expr, Tacexpr.glob_constr_and_expr, @@ -31,6 +33,11 @@ val wit_lglob : Tacexpr.glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type +val wit_lconstr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Constr.t) Genarg.genarg_type + val glob : constr_expr Pcoq.Gram.entry val lglob : constr_expr Pcoq.Gram.entry diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 52419497d1..0cc796886c 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -154,23 +154,23 @@ TACTIC EXTEND einjection | [ "einjection" quantified_hypothesis(h) ] -> [ injClause None true (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND injection_as_main -| [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> +| [ "injection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> [ elimOnConstrWithHoles (injClause (Some ipat)) false c ] END TACTIC EXTEND injection_as -| [ "injection" "as" simple_intropattern_list(ipat)] -> +| [ "injection" "as" intropattern_list(ipat)] -> [ injClause (Some ipat) false None ] -| [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> +| [ "injection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> [ injClause (Some ipat) false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_as_main -| [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> +| [ "einjection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> [ elimOnConstrWithHoles (injClause (Some ipat)) true c ] END TACTIC EXTEND einjection_as -| [ "einjection" "as" simple_intropattern_list(ipat)] -> +| [ "einjection" "as" intropattern_list(ipat)] -> [ injClause (Some ipat) true None ] -| [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> +| [ "einjection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ] END diff --git a/tactics/g_obligations.ml4 b/tactics/g_obligations.ml4 new file mode 100644 index 0000000000..e67d701218 --- /dev/null +++ b/tactics/g_obligations.ml4 @@ -0,0 +1,141 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + *) + +module Gram = Pcoq.Gram +module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic + +open Pcoq + +let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type + +let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = + Genarg.create_arg "withtac" + +let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) + +GEXTEND Gram + GLOBAL: withtac; + + withtac: + [ [ "with"; t = Tactic.tactic -> Some t + | -> None ] ] + ; + + Constr.closed_binder: + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [LocalRawAssum ([id], default_binder_kind, typ)] + ] ]; + + END + +open Obligations + +let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, Some name, Some t) tac ] +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> + [ obligation (num, Some name, None) tac ] +| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, None, Some t) tac ] +| [ "Obligation" integer(num) withtac(tac) ] -> + [ obligation (num, None, None) tac ] +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> + [ next_obligation (Some name) tac ] +| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] +END + +VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF +| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> + [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] +END + +VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" "with" tactic(t) ] -> + [ try_solve_obligations None (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" ] -> + [ try_solve_obligations None None ] +END + +VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> + [ solve_all_obligations (Some (Tacinterp.interp t)) ] +| [ "Solve" "All" "Obligations" ] -> + [ solve_all_obligations None ] +END + +VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +END + +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ + set_default_tactic + (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (Tacintern.glob_tactic t) ] +END + +open Pp + +VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY +| [ "Show" "Obligation" "Tactic" ] -> [ + msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +END + +VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY +| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] +| [ "Obligations" ] -> [ show_obligations None ] +END + +VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY +| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ msg_info (show_term None) ] +END + +open Pp + +(* Declare a printer for the content of Program tactics *) +let () = + let printer _ _ _ = function + | None -> mt () + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + in + (* should not happen *) + let dummy _ _ _ expr = assert false in + Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 73f11d0be0..5c59465429 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,4 +1,5 @@ Extraargs +G_obligations Coretactics Autorewrite Extratactics diff --git a/toplevel/g_obligations.ml4 b/toplevel/g_obligations.ml4 deleted file mode 100644 index dd11efebd8..0000000000 --- a/toplevel/g_obligations.ml4 +++ /dev/null @@ -1,141 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - *) - -module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ -module Tactic = Pcoq.Tactic - -open Pcoq - -let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) - -type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type - -let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = - Genarg.create_arg "withtac" - -let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) - -GEXTEND Gram - GLOBAL: withtac; - - withtac: - [ [ "with"; t = Tactic.tactic -> Some t - | -> None ] ] - ; - - Constr.closed_binder: - [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in - [LocalRawAssum ([id], default_binder_kind, typ)] - ] ]; - - END - -open Obligations - -let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) - -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl -| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) withtac(tac) ] -> - [ obligation (num, Some name, Some t) tac ] -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> - [ obligation (num, Some name, None) tac ] -| [ "Obligation" integer(num) ":" lconstr(t) withtac(tac) ] -> - [ obligation (num, None, Some t) tac ] -| [ "Obligation" integer(num) withtac(tac) ] -> - [ obligation (num, None, None) tac ] -| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> - [ next_obligation (Some name) tac ] -| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] -END - -VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF -| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> - [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] -END - -VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF -| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" "with" tactic(t) ] -> - [ try_solve_obligations None (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" ] -> - [ try_solve_obligations None None ] -END - -VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF -| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> - [ solve_all_obligations (Some (Tacinterp.interp t)) ] -| [ "Solve" "All" "Obligations" ] -> - [ solve_all_obligations None ] -END - -VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] -END - -VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - set_default_tactic - (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (Tacintern.glob_tactic t) ] -END - -open Pp - -VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY -| [ "Show" "Obligation" "Tactic" ] -> [ - msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] -END - -VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY -| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] -| [ "Obligations" ] -> [ show_obligations None ] -END - -VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ msg_info (show_term None) ] -END - -open Pp - -(* Declare a printer for the content of Program tactics *) -let () = - let printer _ _ _ = function - | None -> mt () - | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac - in - (* should not happen *) - let dummy _ _ _ expr = assert false in - Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy -- cgit v1.2.3 From b5f6eb57a480d705be9362067e2fb887533c822c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 17 Mar 2016 23:49:40 +0100 Subject: ARGUMENT EXTEND made of only one entry share the same grammar. This fixes parsing conflicts with the [fix ... with] tactic. --- grammar/argextend.ml4 | 33 ++++++++++++++++++++++---------- grammar/tacextend.ml4 | 2 +- parsing/pcoq.ml | 53 ++++++++++++++++++++++++++------------------------- parsing/pcoq.mli | 3 ++- 4 files changed, 53 insertions(+), 38 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 82bc09519b..f26a66a12b 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -64,6 +64,27 @@ let rec make_prod = function let make_rule loc (prods,act) = <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> +let is_ident x = function +| <:expr< $lid:s$ >> -> CString.equal s x +| _ -> false + +let make_extend loc s cl wit = match cl with +| [[ExtNonTerminal (_, Uentry e, id)], act] when is_ident id act -> + (** Special handling of identity arguments by not redeclaring an entry *) + <:str_item< + value $lid:s$ = + let () = Pcoq.register_grammar $wit$ $lid:e$ in + $lid:e$ + >> +| _ -> + let se = mlexpr_of_string s in + let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in + <:str_item< + value $lid:s$ = + let $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ (Genarg.rawwit $wit$) in + let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in + $lid:s$ >> + let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let rawtyp, rawpr, globtyp, globpr = match typ with | `Uniform typ -> @@ -129,8 +150,6 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = in let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in - let rawwit = <:expr< Genarg.rawwit $wit$ >> in - let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$) = @@ -139,10 +158,8 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; - <:str_item< - value $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ $rawwit$ >>; + make_extend loc s cl wit; <:str_item< do { - Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$; Egramcoq.create_ltac_quotation $se$ @@ -153,8 +170,6 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in - let rawwit = <:expr< Genarg.rawwit $wit$ >> in - let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in let pr_rules = match pr with | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >> | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in @@ -162,10 +177,8 @@ let declare_vernac_argument loc s pr cl = [ <:str_item< value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) = Genarg.create_arg $se$ >>; - <:str_item< - value $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ $rawwit$ >>; + make_extend loc s cl wit; <:str_item< do { - Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule $wit$ $pr_rules$ (fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not globwit printer")) diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 8c85d01629..a18dfa5096 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -85,7 +85,7 @@ let make_fun_clauses loc s l = let make_prod_item = function | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> | ExtNonTerminal (nt, g, id) -> - let base s = <:expr< Pcoq.genarg_grammar $mk_extraarg loc s$ >> in + let base s = <:expr< Pcoq.name_of_entry (Pcoq.genarg_grammar $mk_extraarg loc s$) >> in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ $mlexpr_of_prod_entry_key base g$ >> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 05fd9f9d8c..b769a3cbc4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -229,23 +229,24 @@ let get_typed_entry e = let new_entry etyp u s = let utab = get_utable u in let uname = Entry.univ_name u in - let entry = Entry.create u s in + let _ = Entry.create u s in let ename = uname ^ ":" ^ s in let e = Gram.entry_create ename in - Hashtbl.add utab s (TypedEntry (etyp, e)); (entry, e) + Hashtbl.add utab s (TypedEntry (etyp, e)); e -let make_gen_entry u rawwit s = snd (new_entry rawwit u s) +let make_gen_entry u rawwit s = new_entry rawwit u s module GrammarObj = struct - type ('r, _, _) obj = 'r Entry.t + type ('r, _, _) obj = 'r Gram.entry let name = "grammar" let default _ = None end module Grammar = Register(GrammarObj) -let genarg_grammar wit = Grammar.obj wit +let register_grammar = Grammar.register0 +let genarg_grammar = Grammar.obj let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in @@ -253,9 +254,9 @@ let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a let u = Entry.univ_name u in failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); else - let (entry, e) = new_entry etyp u s in + let e = new_entry etyp u s in let Rawwit t = etyp in - let () = Grammar.register0 t entry in + let () = Grammar.register0 t e in e (* Initial grammar entries *) @@ -863,24 +864,24 @@ let () = let open Constrarg in (* Grammar.register0 wit_unit; *) (* Grammar.register0 wit_bool; *) - Grammar.register0 wit_int (name_of_entry Prim.integer); - Grammar.register0 wit_string (name_of_entry Prim.string); - Grammar.register0 wit_pre_ident (name_of_entry Prim.preident); - Grammar.register0 wit_int_or_var (name_of_entry Tactic.int_or_var); - Grammar.register0 wit_intro_pattern (name_of_entry Tactic.simple_intropattern); - Grammar.register0 wit_ident (name_of_entry Prim.ident); - Grammar.register0 wit_var (name_of_entry Prim.var); - Grammar.register0 wit_ref (name_of_entry Prim.reference); - Grammar.register0 wit_quant_hyp (name_of_entry Tactic.quantified_hypothesis); - Grammar.register0 wit_sort (name_of_entry Constr.sort); - Grammar.register0 wit_constr (name_of_entry Constr.constr); - Grammar.register0 wit_constr_may_eval (name_of_entry Tactic.constr_may_eval); - Grammar.register0 wit_uconstr (name_of_entry Tactic.uconstr); - Grammar.register0 wit_open_constr (name_of_entry Tactic.open_constr); - Grammar.register0 wit_constr_with_bindings (name_of_entry Tactic.constr_with_bindings); - Grammar.register0 wit_bindings (name_of_entry Tactic.bindings); + Grammar.register0 wit_int (Prim.integer); + Grammar.register0 wit_string (Prim.string); + Grammar.register0 wit_pre_ident (Prim.preident); + Grammar.register0 wit_int_or_var (Tactic.int_or_var); + Grammar.register0 wit_intro_pattern (Tactic.simple_intropattern); + Grammar.register0 wit_ident (Prim.ident); + Grammar.register0 wit_var (Prim.var); + Grammar.register0 wit_ref (Prim.reference); + Grammar.register0 wit_quant_hyp (Tactic.quantified_hypothesis); + Grammar.register0 wit_sort (Constr.sort); + Grammar.register0 wit_constr (Constr.constr); + Grammar.register0 wit_constr_may_eval (Tactic.constr_may_eval); + Grammar.register0 wit_uconstr (Tactic.uconstr); + Grammar.register0 wit_open_constr (Tactic.open_constr); + Grammar.register0 wit_constr_with_bindings (Tactic.constr_with_bindings); + Grammar.register0 wit_bindings (Tactic.bindings); (* Grammar.register0 wit_hyp_location_flag; *) - Grammar.register0 wit_red_expr (name_of_entry Tactic.red_expr); - Grammar.register0 wit_tactic (name_of_entry Tactic.tactic); - Grammar.register0 wit_clause_dft_concl (name_of_entry Tactic.clause_dft_concl); + Grammar.register0 wit_red_expr (Tactic.red_expr); + Grammar.register0 wit_tactic (Tactic.tactic); + Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl); () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index b1353ef8ad..64f6f720c2 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -160,7 +160,8 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe -val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t +val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit +val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry val get_entry : gram_universe -> string -> typed_entry -- cgit v1.2.3 From 1730369cd4f7b62a076c93b2a0ece190ee08f7eb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Mar 2016 00:32:02 +0100 Subject: Making the EXTEND macros almost self-contained. --- grammar/argextend.ml4 | 16 ++-------------- grammar/grammar.mllib | 24 ------------------------ grammar/q_util.ml4 | 40 ++++++++++++++++++++++++++++++++++++++++ grammar/q_util.mli | 2 ++ grammar/tacextend.ml4 | 27 ++------------------------- grammar/vernacextend.ml4 | 41 ++++++++++++++++++----------------------- parsing/lexer.ml4 | 2 +- 7 files changed, 65 insertions(+), 87 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index f26a66a12b..5bf7b65d77 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -10,10 +10,8 @@ open Genarg open Q_util -open Egramml open Compat open Extend -open Pcoq let loc = CompatLoc.ghost let default_loc = <:expr< Loc.ghost >> @@ -36,17 +34,10 @@ let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >> let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >> let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> -let has_extraarg l = - let check = function - | ExtNonTerminal(ExtraArgType _, _, _) -> true - | _ -> false - in - List.exists check l - let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> - | ExtNonTerminal (t, _, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> + | ExtNonTerminal (_, _, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> | ExtTerminal _ :: tl -> <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) @@ -241,10 +232,7 @@ EXTEND | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in ExtNonTerminal (type_of_user_symbol e, e, s) - | s = STRING -> - if String.length s > 0 && Util.is_letter s.[0] then - Lexer.add_keyword s; - ExtTerminal s + | s = STRING -> ExtTerminal s ] ] ; entry_name: diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 6a265bf4a8..ae18925ead 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -1,46 +1,22 @@ Coq_config -Hook -Terminal Hashset Hashcons -CSet CMap Int -Dyn -HMap Option Store Exninfo -Backtrace -Pp_control -Flags Loc CList CString -Serialize -Stateid -Feedback -Pp -CArray -CStack -Util -Ppstyle -Errors Segmenttree Unicodetable Unicode -Genarg - -Stdarg -Constrarg Tok Compat -Lexer -Entry -Pcoq Q_util Argextend diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index c43ce15be2..4160d03c5c 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -67,3 +67,43 @@ let rec type_of_user_symbol = function | Uopt s -> Genarg.OptArgType (type_of_user_symbol s) | Uentry e | Uentryl (e, _) -> Genarg.ExtraArgType e + +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let rec parse_user_entry s sep = + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + Ulist1 entry + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 3 (l-12)) "" in + Ulist1sep (entry, sep) + else if l > 5 && coincide s "_list" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + Ulist0 entry + else if l > 9 && coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 0 (l-9)) "" in + Ulist0sep (entry, sep) + else if l > 4 && coincide s "_opt" (l-4) then + let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + Uopt entry + else if l > 5 && coincide s "_mods" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-1)) "" in + Umodifiers entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) + else + let s = match s with "hyp" -> "var" | _ -> s in + Uentry s diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 712aa8509d..5f292baf32 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -31,3 +31,5 @@ val mlexpr_of_ident : string -> MLast.expr val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> Extend.user_symbol -> MLast.expr val type_of_user_symbol : Extend.user_symbol -> Genarg.argument_type + +val parse_user_entry : string -> string -> Extend.user_symbol diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index a18dfa5096..1951b8b452 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -10,14 +10,8 @@ (** Implementation of the TACTIC EXTEND macro. *) -open Util -open Pp -open Names -open Genarg open Q_util open Argextend -open Pcoq -open Egramml open Compat let dloc = <:expr< Loc.ghost >> @@ -39,14 +33,6 @@ let rec mlexpr_of_argtype loc = function <:expr< Genarg.PairArgType $t1$ $t2$ >> | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> -let rec make_when loc = function - | [] -> <:expr< True >> - | ExtNonTerminal (t, _, p) :: l -> - let l = make_when loc l in - let t = mlexpr_of_argtype loc t in - <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >> - | _::l -> make_when loc l - let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> | ExtNonTerminal (t, _, p) :: l -> @@ -64,21 +50,12 @@ let rec extract_signature = function | _::l -> extract_signature l - -let check_unicity s l = - let l' = List.map (fun (l,_,_) -> extract_signature l) l in - if not (Util.List.distinct l') then - Pp.msg_warning - (strbrk ("Two distinct rules of tactic entry "^s^" have the same "^ - "non-terminals in the same order: put them in distinct tactic entries")) - let make_clause (pt,_,e) = (make_patt pt, vala None, make_let false e pt) let make_fun_clauses loc s l = - check_unicity s l; let map c = Compat.make_fun loc [make_clause c] in mlexpr_of_list map l @@ -126,7 +103,7 @@ let declare_tactic loc s c cl = match cl with (** Special handling of tactics without arguments: such tactics do not do a Proofview.Goal.nf_enter to compute their arguments. It matters for some whole-prof tactics like [shelve_unifiable]. *) - if List.is_empty rem then + if CList.is_empty rem then <:expr< fun _ $lid:"ist"$ -> $tac$ >> else let f = Compat.make_fun loc [patt, vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in @@ -201,7 +178,7 @@ EXTEND let e = parse_user_entry e sep in ExtNonTerminal (type_of_user_symbol e, e, s) | s = STRING -> - if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); + let () = if CString.is_empty s then failwith "Empty terminal." in ExtTerminal s ] ] ; diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index d8c8850884..453907689e 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -10,13 +10,9 @@ (** Implementation of the VERNAC EXTEND macro. *) -open Pp -open Util open Q_util open Argextend open Tacextend -open Pcoq -open Egramml open Compat type rule = { @@ -64,26 +60,26 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = (make_patt pt, vala None, <:expr< fun () -> $cg$ $str:s$ >>) - | None, None -> msg_warning - (strbrk("Vernac entry \""^s^"\" misses a classifier. "^ + | None, None -> prerr_endline + (("Vernac entry \""^s^"\" misses a classifier. "^ "A classifier is a function that returns an expression "^ - "of type vernac_classification (see Vernacexpr). You can: ")++ - str"- "++hov 0 ( - strbrk("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ - "new vernacular command does not alter the system state;"))++fnl()++ - str"- "++hov 0 ( - strbrk("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ + "of type vernac_classification (see Vernacexpr). You can: ") ^ + "- " ^ ( + ("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ + "new vernacular command does not alter the system state;"))^ "\n" ^ + "- " ^ ( + ("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ "new vernacular command alters the system state but not the "^ - "parser nor it starts a proof or ends one;"))++fnl()++ - str"- "++hov 0 ( - strbrk("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ + "parser nor it starts a proof or ends one;"))^ "\n" ^ + "- " ^ ( + ("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ "a global function f. The function f will be called passing "^ - "\""^s^"\" as the only argument;")) ++fnl()++ - str"- "++hov 0 ( - strbrk"Add a specific classifier in each clause using the syntax:" - ++fnl()++strbrk("'[...] => [ f ] -> [...]'. "))++fnl()++ - strbrk("Specific classifiers have precedence over global "^ - "classifiers. Only one classifier is called.")++fnl()); + "\""^s^"\" as the only argument;")) ^ "\n" ^ + "- " ^ ( + "Add a specific classifier in each clause using the syntax:" + ^ "\n" ^("'[...] => [ f ] -> [...]'. "))^ "\n" ^ + ("Specific classifiers have precedence over global "^ + "classifiers. Only one classifier is called.") ^ "\n"); (make_patt pt, vala None, <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) @@ -164,8 +160,7 @@ EXTEND rule: [ [ "["; s = STRING; l = LIST0 args; "]"; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - if String.is_empty s then - Errors.user_err_loc (!@loc,"",Pp.str"Command name is empty."); + let () = if CString.is_empty s then failwith "Command name is empty." in let b = <:expr< fun () -> $e$ >> in { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } | "[" ; "-" ; l = LIST1 args ; "]" ; diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 232e9aee3f..8b8b38c34b 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -724,7 +724,7 @@ let strip s = let terminal s = let s = strip s in - let () = match s with "" -> Errors.error "empty token." | _ -> () in + let () = match s with "" -> failwith "empty token." | _ -> () in if is_ident_not_keyword s then IDENT s else if is_number s then INT s else KEYWORD s -- cgit v1.2.3 From f8f1f9d38bf2d35b0dc69fbf2e8ebbfc04b1a82d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Mar 2016 01:36:39 +0100 Subject: Documenting the change of EXTEND macros. --- dev/doc/changes.txt | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 0581a5f850..1f5ba7862f 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -66,6 +66,15 @@ Context.Named.t = LocalAssum of Names.Id.t * Constr.t | LocalDef of Names.Id.t * Constr.t * Constr.t +- The various EXTEND macros do not handle specially the Coq-defined entries + anymore. Instead, they just output a name that have to exist in the scope + of the ML code. The parsing rules (VERNAC) ARGUMENT EXTEND will look for + variables "$name" of type Gram.entry, while the parsing rules of + (VERNAC COMMAND | TACTIC) EXTEND, as well as the various TYPED AS clauses will + look for variables "wit_$name" of type Genarg.genarg_type. The small DSL + for constructing compound entries still works over this scheme. Note that in + the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound + in the parsing rules, so beware of recursive calls. ========================================= = CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = -- cgit v1.2.3 From 13c50b98b0a294a6056d2e00a0de44cedca7af12 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 16 Feb 2016 20:03:45 +0100 Subject: Removing dead code in Pcoq. --- grammar/grammar.mllib | 4 ---- parsing/egramcoq.ml | 4 ++-- parsing/pcoq.ml | 37 ++++++++++++------------------------- parsing/pcoq.mli | 21 +++++++-------------- toplevel/metasyntax.ml | 2 +- 5 files changed, 22 insertions(+), 46 deletions(-) diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index ae18925ead..42fc738783 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -11,10 +11,6 @@ Loc CList CString -Segmenttree -Unicodetable -Unicode - Tok Compat diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 2cf590b1d8..8c4930806e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -206,14 +206,14 @@ type notation_grammar = { let extend_constr_constr_notation ng = let level = ng.notgram_level in let mkact loc env = CNotation (loc, ng.notgram_notation, env) in - let e = interp_constr_entry_key false (ETConstr (level, ())) in + let e = interp_constr_entry_key false level in let ext = (ETConstr (level, ()), ng.notgram_assoc) in extend_constr e ext (make_constr_action mkact) false ng.notgram_prods let extend_constr_pat_notation ng = let level = ng.notgram_level in let mkact loc env = CPatNotation (loc, ng.notgram_notation, env, []) in - let e = interp_constr_entry_key true (ETConstr (level, ())) in + let e = interp_constr_entry_key true level in let ext = ETConstr (level, ()), ng.notgram_assoc in extend_constr e ext (make_cases_pattern_action mkact) true ng.notgram_prods diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b769a3cbc4..bf46fffffe 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -77,8 +77,8 @@ type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = | Aentry : 'a Entry.t -> ('self, 'a) entry_key | Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key -type 's entry_name = EntryName : - 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name +type entry_name = EntryName : + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) entry_key -> entry_name (** Grammar extensions *) @@ -586,7 +586,7 @@ let adjust_level assoc from = function | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) | _ -> Some (Some (n,false)) -let compute_entry allow_create adjust forpat = function +let compute_entry adjust forpat = function | ETConstr (n,q) -> (if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr), @@ -604,26 +604,19 @@ let compute_entry allow_create adjust forpat = function | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") | ETOther (u,n) -> let u = get_univ u in - let e = - try get_entry u n - with Not_found when allow_create -> - let wit = rawwit wit_constr in - TypedEntry (wit, create_generic_entry u n wit) - in + let e = get_entry u n in object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) -let interp_constr_entry_key forpat = function - | ETConstr(200,()) when not forpat -> - weaken_entry Constr.binder_constr, None - | e -> - let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in - (e, level) +let interp_constr_entry_key forpat level = + if level = 200 && not forpat then weaken_entry Constr.binder_constr, None + else if forpat then weaken_entry Constr.pattern, Some level + else weaken_entry Constr.operconstr, Some level (* This computes the name to give to a production knowing the name and associativity of the level where it must be added *) let interp_constr_prod_entry_key ass from forpat en = - compute_entry false (adjust_level ass from) forpat en + compute_entry (adjust_level ass from) forpat en (**********************************************************************) (* Binding constr entry keys to symbols *) @@ -759,17 +752,11 @@ let atactic n = let try_get_entry u s = (** Order the effects: get_entry can raise Not_found *) - let TypedEntry (typ, _) = get_entry u s in - EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) - -type _ target = -| TgAny : 's target -| TgTactic : int -> Tacexpr.raw_tactic_expr target + let TypedEntry (typ, e) = get_entry u s in + EntryName (typ, Aentry (name_of_entry e)) (** Quite ad-hoc *) -let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with -| TgAny -> EntryName (rawwit wit_tactic, atactic n) -| TgTactic m -> +let get_tacentry n m = let check_lvl n = Int.equal m n && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 64f6f720c2..e57da42cb3 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -153,8 +153,6 @@ type gram_universe = Entry.universe val get_univ : string -> gram_universe -type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a Gram.entry -> typed_entry - val uprim : gram_universe val uconstr : gram_universe val utactic : gram_universe @@ -163,8 +161,6 @@ val uvernac : gram_universe val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -val get_entry : gram_universe -> string -> typed_entry - val create_generic_entry : gram_universe -> string -> ('a, rlevel) abstract_argument_type -> 'a Gram.entry @@ -267,7 +263,7 @@ val main_entry : (Loc.t * vernac_expr) option Gram.entry (** Binding constr entry keys to entries and symbols *) val interp_constr_entry_key : bool (** true for cases_pattern *) -> - constr_entry_key -> grammar_object Gram.entry * int option + int -> grammar_object Gram.entry * int option val symbol_of_constr_prod_entry_key : gram_assoc option -> constr_entry_key -> bool -> constr_prod_entry_key -> @@ -279,16 +275,13 @@ val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** Binding general entry keys to symbols *) -type 's entry_name = EntryName : - 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name - -(** Interpret entry names of the form "ne_constr_list" as entry keys *) - -type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target - -val interp_entry_name : 's target -> string -> string -> 's entry_name +type entry_name = EntryName : + 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) entry_key -> entry_name -val parse_user_entry : string -> string -> user_symbol +(** [interp_entry_name lev n sep] returns the entry corresponding to the name + [n] of the form "ne_constr_list" in a tactic entry of level [lev] with + separator [sep]. *) +val interp_entry_name : int -> string -> string -> entry_name (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * argument_type) list diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 82bd5dac4c..e5edc74222 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -48,7 +48,7 @@ let add_token_obj s = Lib.add_anonymous_leaf (inToken s) let interp_prod_item lev = function | TacTerm s -> GramTerminal s | TacNonTerm (loc, nt, (_, sep)) -> - let EntryName (etyp, e) = interp_entry_name (TgTactic lev) nt sep in + let EntryName (etyp, e) = interp_entry_name lev nt sep in GramNonTerminal (loc, etyp, e) let make_terminal_status = function -- cgit v1.2.3 From a99aa093b962e228817066d00f7e12698f8df73a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Mar 2016 22:27:17 +0100 Subject: Simplifying the code of Entry. --- dev/top_printers.ml | 4 ++-- parsing/entry.ml | 49 +++++++++-------------------------------- parsing/entry.mli | 29 ++++-------------------- parsing/pcoq.ml | 63 +++++++++++++++++++++++++++++------------------------ parsing/pcoq.mli | 3 ++- 5 files changed, 52 insertions(+), 96 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index aef9b10b26..b8bc0483d3 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -520,7 +520,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")))] + (Loc.ghost,rawwit wit_constr,Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] let _ = try @@ -536,7 +536,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")))] + (Loc.ghost,rawwit wit_constr,Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] (* Setting printer of unbound global reference *) open Names diff --git a/parsing/entry.ml b/parsing/entry.ml index 0519903d3d..b7c6c23fa6 100644 --- a/parsing/entry.ml +++ b/parsing/entry.ml @@ -9,51 +9,22 @@ open Errors open Util -type 'a t = string * string - -type repr = string * string - -type universe = string - -(* The univ_tab is not part of the state. It contains all the grammars that - exist or have existed before in the session. *) - -let univ_tab = (Hashtbl.create 7 : (string, unit) Hashtbl.t) - -let create_univ s = - Hashtbl.add univ_tab s (); s - -let univ_name s = s - -let uprim = create_univ "prim" -let uconstr = create_univ "constr" -let utactic = create_univ "tactic" -let uvernac = create_univ "vernac" - -let get_univ s = - try - Hashtbl.find univ_tab s; s - with Not_found -> - anomaly (Pp.str ("Unknown grammar universe: "^s)) +type 'a t = string (** Entries are registered with a unique name *) let entries = ref String.Set.empty -let create u name = - let uname = u ^ ":" ^ name in +let create name = let () = - if String.Set.mem uname !entries then - anomaly (Pp.str ("Entry " ^ uname ^ " already defined")) + if String.Set.mem name !entries then + anomaly (Pp.str ("Entry " ^ name ^ " already defined")) in - let () = entries := String.Set.add uname !entries in - (u, name) - -let dynamic name = ("", name) + let () = entries := String.Set.add name !entries in + name -let unsafe_of_name (u, s) = - let uname = u ^ ":" ^ s in - assert (String.Set.mem uname !entries); - (u, s) +let unsafe_of_name name = + assert (String.Set.mem name !entries); + name -let repr (u, s) = (u, s) +let repr s = s diff --git a/parsing/entry.mli b/parsing/entry.mli index 97cd5b1105..4c73fe2049 100644 --- a/parsing/entry.mli +++ b/parsing/entry.mli @@ -11,34 +11,13 @@ type 'a t (** Typed grammar entries. We need to defined them here so that they are marshallable and defined before the Pcoq.Gram module. They are basically - unique names made of a universe and an entry name. They should be kept - synchronized with the {!Pcoq} entries though. *) + unique names. They should be kept synchronized with the {!Pcoq} entries. *) -type repr = string * string -(** Representation of entries. *) - -(** Table of Coq statically defined grammar entries *) - -type universe - -(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *) - -val get_univ : string -> universe -val univ_name : universe -> string - -val uprim : universe -val uconstr : universe -val utactic : universe -val uvernac : universe - -(** {5 Uniquely defined entries} *) - -val create : universe -> string -> 'a t +val create : string -> 'a t (** Create an entry. They should be synchronized with the entries defined in {!Pcoq}. *) (** {5 Meta-programming} *) -val repr : 'a t -> repr - -val unsafe_of_name : (string * string) -> 'a t +val repr : 'a t -> string +val unsafe_of_name : string -> 'a t diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index bf46fffffe..238b9edd44 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -198,40 +198,49 @@ let map_entry f en = let parse_string f x = let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) -type gram_universe = Entry.universe - -let uprim = Entry.uprim -let uconstr = Entry.uconstr -let utactic = Entry.utactic -let uvernac = Entry.uvernac -let get_univ = Entry.get_univ +type gram_universe = string let utables : (string, (string, typed_entry) Hashtbl.t) Hashtbl.t = Hashtbl.create 97 +let create_universe u = + let table = Hashtbl.create 97 in + let () = Hashtbl.add utables u table in + u + +let uprim = create_universe "prim" +let uconstr = create_universe "constr" +let utactic = create_universe "tactic" +let uvernac = create_universe "vernac" + +let get_univ u = + if Hashtbl.mem utables u then u + else raise Not_found + let get_utable u = - let u = Entry.univ_name u in try Hashtbl.find utables u - with Not_found -> - let table = Hashtbl.create 97 in - Hashtbl.add utables u table; - table + with Not_found -> assert false let get_entry u s = let utab = get_utable u in Hashtbl.find utab s -let get_typed_entry e = - let (u, s) = Entry.repr e in - let u = Entry.get_univ u in - get_entry u s +(** A table associating grammar to entries *) +let gtable : Obj.t Gram.entry String.Map.t ref = ref String.Map.empty + +let get_grammar (e : 'a Entry.t) : 'a Gram.entry = + Obj.magic (String.Map.find (Entry.repr e) !gtable) + +let set_grammar (e : 'a Entry.t) (g : 'a Gram.entry) = + assert (not (String.Map.mem (Entry.repr e) !gtable)); + gtable := String.Map.add (Entry.repr e) (Obj.magic g) !gtable let new_entry etyp u s = let utab = get_utable u in - let uname = Entry.univ_name u in - let _ = Entry.create u s in - let ename = uname ^ ":" ^ s in + let ename = u ^ ":" ^ s in + let entry = Entry.create ename in let e = Gram.entry_create ename in + let () = set_grammar entry e in Hashtbl.add utab s (TypedEntry (etyp, e)); e let make_gen_entry u rawwit s = new_entry rawwit u s @@ -251,8 +260,7 @@ let genarg_grammar = Grammar.obj let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = let utab = get_utable u in if Hashtbl.mem utab s then - let u = Entry.univ_name u in - failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists"); + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists") else let e = new_entry etyp u s in let Rawwit t = etyp in @@ -603,7 +611,6 @@ let compute_entry adjust forpat = function | ETPattern -> weaken_entry Constr.pattern, None, false | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") | ETOther (u,n) -> - let u = get_univ u in let e = get_entry u n in object_of_typed_entry e, None, true @@ -696,11 +703,11 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function | Aself -> Symbols.sself | Anext -> Symbols.snext | Aentry e -> - let e = get_typed_entry e in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + let e = get_grammar e in + Symbols.snterm (Gram.Entry.obj (weaken_entry e)) | Aentryl (e, n) -> - let e = get_typed_entry e in - Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n) + let e = get_grammar e in + Symbols.snterml (Gram.Entry.obj (weaken_entry e), string_of_int n) let level_of_snterml e = int_of_string (Symbols.snterml_level e) @@ -742,9 +749,7 @@ let coincide s pat off = done; !break -let name_of_entry e = match String.split ':' (Gram.Entry.name e) with -| u :: s :: [] -> Entry.unsafe_of_name (u, s) -| _ -> assert false +let name_of_entry e = Entry.unsafe_of_name (Gram.Entry.name e) let atactic n = if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index e57da42cb3..c1c0187137 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -149,7 +149,7 @@ val parse_string : 'a Gram.entry -> string -> 'a val eoi_entry : 'a Gram.entry -> 'a Gram.entry val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry -type gram_universe = Entry.universe +type gram_universe val get_univ : string -> gram_universe @@ -158,6 +158,7 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe +val set_grammar : 'a Entry.t -> 'a Gram.entry -> unit val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -- cgit v1.2.3 From 805c8987fbb5fdeb94838bb5a3a7364c0a3d3374 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 17 Feb 2016 13:45:24 +0100 Subject: Do not export entry_key from Pcoq anymore. --- dev/top_printers.ml | 4 ++-- grammar/argextend.ml4 | 2 +- grammar/q_util.ml4 | 18 +++++++++--------- parsing/egramml.ml | 3 ++- parsing/egramml.mli | 2 +- parsing/pcoq.ml | 17 ++--------------- parsing/pcoq.mli | 15 +-------------- 7 files changed, 18 insertions(+), 43 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b8bc0483d3..141eab3f3f 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -520,7 +520,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] + (Loc.ghost,rawwit wit_constr,Extend.Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] let _ = try @@ -536,7 +536,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] + (Loc.ghost,rawwit wit_constr,Extend.Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] (* Setting printer of unbound global reference *) open Names diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 5bf7b65d77..bebde706e4 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -43,7 +43,7 @@ let make_act loc act pil = make (List.rev pil) let make_prod_item = function - | ExtTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> + | ExtTerminal s -> <:expr< Extend.Atoken (Lexer.terminal $mlexpr_of_string s$) >> | ExtNonTerminal (_, g, _) -> let base s = <:expr< Pcoq.name_of_entry $lid:s$ >> in mlexpr_of_prod_entry_key base g diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 4160d03c5c..d91bfd7b8d 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -48,18 +48,18 @@ let mlexpr_of_ident id = <:expr< Names.Id.of_string $str:id$ >> let rec mlexpr_of_prod_entry_key f = function - | Extend.Ulist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key f s$ >> - | Extend.Ulist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> - | Extend.Ulist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key f s$ >> - | Extend.Ulist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> - | Extend.Uopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key f s$ >> - | Extend.Umodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key f s$ >> - | Extend.Uentry e -> <:expr< Pcoq.Aentry $f e$ >> + | Extend.Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> + | Extend.Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Extend.Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> + | Extend.Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Extend.Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> + | Extend.Umodifiers s -> <:expr< Extend.Amodifiers $mlexpr_of_prod_entry_key f s$ >> + | Extend.Uentry e -> <:expr< Extend.Aentry $f e$ >> | Extend.Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (CString.equal e "tactic"); - if l = 5 then <:expr< Pcoq.Aentry (Pcoq.name_of_entry Pcoq.Tactic.binder_tactic) >> - else <:expr< Pcoq.Aentryl (Pcoq.name_of_entry Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> + if l = 5 then <:expr< Extend.Aentry (Pcoq.name_of_entry Pcoq.Tactic.binder_tactic) >> + else <:expr< Extend.Aentryl (Pcoq.name_of_entry Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> let rec type_of_user_symbol = function | Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) | Umodifiers s -> diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 77252e7425..37fccdb3c2 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -9,6 +9,7 @@ open Util open Compat open Names +open Extend open Pcoq open Genarg open Vernacexpr @@ -18,7 +19,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) symbol -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index edf971574d..1ad9472007 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -16,7 +16,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * - ('s, 'a) Pcoq.entry_key -> 's grammar_prod_item + ('s, 'a) Extend.symbol -> 's grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 238b9edd44..dac5b3bfd8 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -64,21 +64,8 @@ let weaken_entry x = Gramobj.weaken_entry x dynamically interpreted as entries for the Coq level extensions *) -type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, string) entry_key -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) entry_key -> entry_name + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) symbol -> entry_name (** Grammar extensions *) @@ -684,7 +671,7 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) -let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function +let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Atoken t -> Symbols.stoken t | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index c1c0187137..d6bfe3eb39 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -112,19 +112,6 @@ type gram_reinit = gram_assoc * gram_position dynamically interpreted as entries for the Coq level extensions *) -type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, string) entry_key -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - (** Add one extension at some camlp4 position of some camlp4 entry *) val unsafe_grammar_extend : grammar_object Gram.entry -> @@ -277,7 +264,7 @@ val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** Binding general entry keys to symbols *) type entry_name = EntryName : - 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) entry_key -> entry_name + 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) Extend.symbol -> entry_name (** [interp_entry_name lev n sep] returns the entry corresponding to the name [n] of the form "ne_constr_list" in a tactic entry of level [lev] with -- cgit v1.2.3 From 25f39e54e4e8eaf08865121f06635dc3bd1092da Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 16 Feb 2016 21:17:12 +0100 Subject: Allowing generalized rules in typed symbols. --- intf/extend.mli | 21 ++++++++++++++++++++- parsing/pcoq.ml | 27 ++++++++++++++++++++------- 2 files changed, 40 insertions(+), 8 deletions(-) diff --git a/intf/extend.mli b/intf/extend.mli index 57abdc38fb..e1520dec54 100644 --- a/intf/extend.mli +++ b/intf/extend.mli @@ -65,6 +65,17 @@ type user_symbol = (** {5 Type-safe grammar extension} *) +(** (a, b, r) adj => [a = x₁ -> ... xₙ -> r] & [b = x₁ * (... (xₙ * unit))]. *) +type (_, _, _) adj = +| Adj0 : ('r, unit, 'r) adj +| AdjS : ('s, 'b, 'r) adj -> ('a -> 's, 'a * 'b, 'r) adj + +type _ index = +| I0 : 'a -> ('a * 'r) index +| IS : 'a index -> ('b * 'a) index + +(** This type should be marshallable, this is why we use a convoluted + representation in the [Arules] constructor instead of putting a function. *) type ('self, 'a) symbol = | Atoken : Tok.t -> ('self, string) symbol | Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol @@ -77,11 +88,19 @@ type ('self, 'a) symbol = | Anext : ('self, 'self) symbol | Aentry : 'a Entry.t -> ('self, 'a) symbol | Aentryl : 'a Entry.t * int -> ('self, 'a) symbol +| Arules : 'a rules -> ('self, 'a index) symbol -type ('self, _, 'r) rule = +and ('self, _, 'r) rule = | Stop : ('self, 'r, 'r) rule | Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule +and 'a rules = +| Rule0 : unit rules +| RuleS : + ('any, 'act, Loc.t -> Loc.t * 'a) rule * + ('act, 'a, Loc.t -> Loc.t * 'a) adj * + 'b rules -> ((Loc.t * 'a) * 'b) rules + type 'a production_rule = | Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index dac5b3bfd8..91f933987b 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -671,6 +671,13 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) +let tuplify l = + List.fold_left (fun accu x -> Obj.repr (x, accu)) (Obj.repr ()) l + +let rec adj : type a b c. (a, b, Loc.t -> Loc.t * c) adj -> _ = function +| Adj0 -> Obj.magic (fun accu f loc -> f (Obj.repr (to_coqloc loc, tuplify accu))) +| AdjS e -> Obj.magic (fun accu f x -> adj e (x :: accu) f) + let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Atoken t -> Symbols.stoken t | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) @@ -695,21 +702,27 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Aentryl (e, n) -> let e = get_grammar e in Symbols.snterml (Gram.Entry.obj (weaken_entry e), string_of_int n) + | Arules rs -> Gram.srules' (symbol_of_rules rs [] (fun x -> I0 x)) -let level_of_snterml e = int_of_string (Symbols.snterml_level e) - -let rec of_coq_rule : type self a r. (self, a, r) Extend.rule -> _ = function +and symbol_of_rule : type s a r. (s, a, r) Extend.rule -> _ = function | Stop -> fun accu -> accu -| Next (r, tok) -> fun accu -> - let symb = symbol_of_prod_entry_key tok in - of_coq_rule r (symb :: accu) +| Next (r, s) -> fun accu -> symbol_of_rule r (symbol_of_prod_entry_key s :: accu) + +and symbol_of_rules : type a. a Extend.rules -> _ = function +| Rule0 -> fun accu _ -> accu +| RuleS (r, e, rs) -> fun accu f -> + let symb = symbol_of_rule r [] in + let act = adj e [] f in + symbol_of_rules rs ((symb, act) :: accu) (fun x -> IS (f x)) + +let level_of_snterml e = int_of_string (Symbols.snterml_level e) let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> Gram.action = function | Stop -> fun f -> Gram.action (fun loc -> f (to_coqloc loc)) | Next (r, _) -> fun f -> Gram.action (fun x -> of_coq_action r (f x)) let of_coq_production_rule : type a. a Extend.production_rule -> _ = function -| Rule (toks, act) -> (of_coq_rule toks [], of_coq_action toks act) +| Rule (toks, act) -> (symbol_of_rule toks [], of_coq_action toks act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule) -- cgit v1.2.3 From a11dd2209f47b6b79ace3d32071d29bd5652e07a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Mar 2016 15:16:02 +0100 Subject: Relying on Vernac classifier to flag tactics in the STM. --- stm/stm.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/stm/stm.ml b/stm/stm.ml index 07262ef68f..1d16d99b32 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1140,9 +1140,10 @@ end = struct (* {{{ *) let perform_states query = if query = [] then [] else - let is_tac = function - | VernacSolve _ | VernacFocus _ | VernacUnfocus | VernacBullet _ -> true - | _ -> false in + let is_tac e = match classify_vernac e with + | VtProofStep _, _ -> true + | _ -> false + in let initial = let rec aux id = try match VCS.visit id with { next } -> aux next -- cgit v1.2.3 From d94a8b2024497e11ff9392a7fa4401ffcc131cc0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Mar 2016 15:20:47 +0100 Subject: Moving the proof mode parsing management to Pcoq. --- parsing/g_vernac.ml4 | 12 +----------- parsing/pcoq.ml | 9 +++++++++ parsing/pcoq.mli | 6 ++++++ plugins/decl_mode/g_decl_mode.ml4 | 4 ++-- 4 files changed, 18 insertions(+), 13 deletions(-) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 49baeb5560..2eb590132a 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -35,7 +35,6 @@ let _ = List.iter Lexer.add_keyword vernac_kw let query_command = Gram.entry_create "vernac:query_command" let tactic_mode = Gram.entry_create "vernac:tactic_command" -let noedit_mode = Gram.entry_create "vernac:noedit_command" let subprf = Gram.entry_create "vernac:subprf" let class_rawexpr = Gram.entry_create "vernac:class_rawexpr" @@ -48,11 +47,6 @@ let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" -let command_entry = ref noedit_mode -let set_command_entry e = command_entry := e -let get_command_entry () = !command_entry - - (* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for proof editing and changes nothing else). Then sets it as the default proof mode. *) let set_tactic_mode () = set_command_entry tactic_mode @@ -82,10 +76,6 @@ let test_bracket_ident = | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) -let default_command_entry = - Gram.Entry.of_parser "command_entry" - (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm) - GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST @@ -129,7 +119,7 @@ GEXTEND Gram ] ] ; vernac_aux: LAST - [ [ prfcom = default_command_entry -> prfcom ] ] + [ [ prfcom = command_entry -> prfcom ] ] ; noedit_mode: [ [ c = subgoal_command -> c None] ] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 91f933987b..9c2f09db84 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -383,6 +383,7 @@ module Vernac_ = let rec_definition = gec_vernac "Vernac.rec_definition" (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" + let noedit_mode = gec_vernac "noedit_command" let () = let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in @@ -393,10 +394,18 @@ module Vernac_ = ] in maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) + let command_entry_ref = ref noedit_mode + let command_entry = + Gram.Entry.of_parser "command_entry" + (fun strm -> Gram.parse_tokens_after_filter !command_entry_ref strm) + end let main_entry = Vernac_.main_entry +let set_command_entry e = Vernac_.command_entry_ref := e +let get_command_entry () = !Vernac_.command_entry_ref + (**********************************************************************) (* This determines (depending on the associativity of the current level and on the expected associativity) if a reference to constr_n is diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index d6bfe3eb39..7410d4e44c 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -241,11 +241,17 @@ module Vernac_ : val vernac : vernac_expr Gram.entry val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry val vernac_eoi : vernac_expr Gram.entry + val noedit_mode : vernac_expr Gram.entry + val command_entry : vernac_expr Gram.entry end (** The main entry: reads an optional vernac command *) val main_entry : (Loc.t * vernac_expr) option Gram.entry +(** Handling of the proof mode entry *) +val get_command_entry : unit -> vernac_expr Gram.entry +val set_command_entry : vernac_expr Gram.entry -> unit + (** Mapping formal entries into concrete ones *) (** Binding constr entry keys to entries and symbols *) diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 2afbaca2c8..a438ca79f4 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -135,7 +135,7 @@ let _ = set = begin fun () -> (* We set the command non terminal to [proof_mode] (which we just defined). *) - G_vernac.set_command_entry proof_mode ; + Pcoq.set_command_entry proof_mode ; (* We substitute the goal printer, by the one we built for the proof mode. *) Printer.set_printer_pr { Printer.default_printer_pr with @@ -147,7 +147,7 @@ let _ = reset = begin fun () -> (* We restore the command non terminal to [noedit_mode]. *) - G_vernac.set_command_entry G_vernac.noedit_mode ; + Pcoq.set_command_entry Pcoq.Vernac_.noedit_mode ; (* We restore the goal printer to default *) Printer.set_printer_pr Printer.default_printer_pr end -- cgit v1.2.3 From 5bce635ad876bde78a7ffabc3e781112e5418a65 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Mar 2016 23:56:22 +0100 Subject: Removing the dependency in VernacSolve in the STM. Instead of mangling the AST in order to interpret par: we remember the goal position to focus on it first and evaluate then the underlying vernacular expression. --- proofs/pfedit.ml | 4 +--- stm/stm.ml | 21 ++++++++++++--------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 20d696fd91..0fdcaa5875 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -104,9 +104,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let tac = match gi with | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac - | Vernacexpr.SelectAll -> tac - | Vernacexpr.SelectAllParallel -> - Errors.anomaly(str"SelectAllParallel not handled by Stm") + | Vernacexpr.SelectAll | Vernacexpr.SelectAllParallel -> tac in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in let () = diff --git a/stm/stm.ml b/stm/stm.ml index 1d16d99b32..92032e9bc3 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1414,7 +1414,7 @@ and TacTask : sig t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; - t_ast : ast; + t_ast : int * ast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } @@ -1431,7 +1431,7 @@ end = struct (* {{{ *) t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; - t_ast : ast; + t_ast : int * ast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } @@ -1440,7 +1440,7 @@ end = struct (* {{{ *) r_state : Stateid.t; r_state_fb : Stateid.t; r_document : VCS.vcs option; - r_ast : ast; + r_ast : int * ast; r_goal : Goal.goal; r_name : string } @@ -1484,6 +1484,9 @@ end = struct (* {{{ *) | Some { t_kill } -> t_kill () | _ -> () + let command_focus = Proof.new_focus_kind () + let focus_cond = Proof.no_cond command_focus + let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } = Option.iter VCS.restore vcs; try @@ -1499,7 +1502,9 @@ end = struct (* {{{ *) Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^ "goals only")) else begin - vernac_interp r_state_fb r_ast; + let (i, ast) = r_ast in + Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + vernac_interp r_state_fb ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> Errors.errorlabstrm "Stm" (str "no progress") @@ -1528,12 +1533,11 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) let vernac_interp cancel nworkers safe_id id { verbose; loc; expr = e } = - let e, etac, time, fail = + let e, time, fail = let rec find time fail = function - | VernacSolve(_,_,re,b) -> re, b, time, fail | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e | VernacFail e -> find time true e - | _ -> errorlabstrm "Stm" (str"unsupported") in find false false e in + | _ -> e, time, fail in find false false e in Hooks.call Hooks.with_fail fail (fun () -> (if time then System.with_time false else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> @@ -1545,8 +1549,7 @@ end = struct (* {{{ *) Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) (State.exn_on id ~valid:safe_id) in - let t_ast = - { verbose;loc;expr = VernacSolve(SelectNth i,None,e,etac) } in + let t_ast = (i, { verbose; loc; expr = e }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue ({ t_state = safe_id; t_state_fb = id; -- cgit v1.2.3 From 5c8fc9aebe072237a65fc9ed7acf8ae559a78243 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 16 Mar 2016 19:27:00 +0100 Subject: Moving the parsing of the Ltac proof mode to G_ltac. --- parsing/g_ltac.ml4 | 42 ++++++++++++++++++++++++++++++++++++++++- parsing/g_vernac.ml4 | 44 ++----------------------------------------- test-suite/bugs/opened/3410.v | 1 - test-suite/ide/undo013.fake | 2 +- test-suite/ide/undo014.fake | 2 +- test-suite/ide/undo015.fake | 2 +- test-suite/ide/undo016.fake | 2 +- 7 files changed, 47 insertions(+), 48 deletions(-) delete mode 100644 test-suite/bugs/opened/3410.v diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index e4ca936a69..35a9fede1b 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util open Pp open Compat open Constrexpr @@ -36,11 +37,35 @@ let reference_to_id = function Errors.user_err_loc (loc, "", str "This expression should be a simple identifier.") +let tactic_mode = Gram.entry_create "vernac:tactic_command" +let selector = Gram.entry_create "vernac:selector" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> set_command_entry tactic_mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Gram.Entry.of_parser "test_bracket_ident" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "[" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + (* Tactics grammar rules *) GEXTEND Gram GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - constr_may_eval constr_eval; + tactic_mode constr_may_eval constr_eval selector; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> @@ -262,4 +287,19 @@ GEXTEND Gram tactic: [ [ tac = tactic_expr -> tac ] ] ; + selector: + [ [ n=natural; ":" -> Vernacexpr.SelectNth n + | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id + | IDENT "all" ; ":" -> Vernacexpr.SelectAll + | IDENT "par" ; ":" -> Vernacexpr.SelectAllParallel ] ] + ; + tactic_mode: + [ [ g = OPT selector; + tac = G_vernac.subgoal_command -> tac g + | g = OPT selector; info = OPT [IDENT "Info";n=natural -> n]; + tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + Vernacexpr.VernacSolve (g, info, tac, use_dft_tac) + ] ] + ; END diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 2eb590132a..c89238d296 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -34,7 +34,6 @@ let _ = List.iter Lexer.add_keyword vernac_kw let query_command = Gram.entry_create "vernac:query_command" -let tactic_mode = Gram.entry_create "vernac:tactic_command" let subprf = Gram.entry_create "vernac:subprf" let class_rawexpr = Gram.entry_create "vernac:class_rawexpr" @@ -47,16 +46,6 @@ let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let set_tactic_mode () = set_command_entry tactic_mode -let set_noedit_mode () = set_command_entry noedit_mode -let _ = Proof_global.register_proof_mode {Proof_global. - name = "Classic" ; - set = set_tactic_mode ; - reset = set_noedit_mode - } - let make_bullet s = let n = String.length s in match s.[0] with @@ -65,19 +54,8 @@ let make_bullet s = | '*' -> Star n | _ -> assert false -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "[" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - GEXTEND Gram - GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; + GLOBAL: vernac gallina_ext noedit_mode subprf subgoal_command; vernac: FIRST [ [ IDENT "Time"; c = located_vernac -> VernacTime c | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c) @@ -125,18 +103,6 @@ GEXTEND Gram [ [ c = subgoal_command -> c None] ] ; - selector: - [ [ n=natural; ":" -> SelectNth n - | test_bracket_ident; "["; id = ident; "]"; ":" -> SelectId id - | IDENT "all" ; ":" -> SelectAll - | IDENT "par" ; ":" -> SelectAllParallel ] ] - ; - - tactic_mode: - [ [ gln = OPT selector; - tac = subgoal_command -> tac gln ] ] - ; - subprf: [ [ s = BULLET -> VernacBullet (make_bullet s) | "{" -> VernacSubproof None @@ -151,13 +117,7 @@ GEXTEND Gram | None -> c None | _ -> VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) - end - | info = OPT [IDENT "Info";n=natural -> n]; - tac = Tactic.tactic; - use_dft_tac = [ "." -> false | "..." -> true ] -> - (fun g -> - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - VernacSolve(g,info,tac,use_dft_tac)) ] ] + end ] ] ; located_vernac: [ [ v = vernac -> !@loc, v ] ] diff --git a/test-suite/bugs/opened/3410.v b/test-suite/bugs/opened/3410.v deleted file mode 100644 index 0d259181aa..0000000000 --- a/test-suite/bugs/opened/3410.v +++ /dev/null @@ -1 +0,0 @@ -Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end. diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake index f44156aa38..921a9d0f0d 100644 --- a/test-suite/ide/undo013.fake +++ b/test-suite/ide/undo013.fake @@ -23,5 +23,5 @@ ADD { Qed. } ADD { apply H. } # ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake index 6d58b061e6..f5fe774704 100644 --- a/test-suite/ide/undo014.fake +++ b/test-suite/ide/undo014.fake @@ -22,5 +22,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake index ac17985aab..a1e5c947b3 100644 --- a/test-suite/ide/undo015.fake +++ b/test-suite/ide/undo015.fake @@ -25,5 +25,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake index bdb81ecd95..f9414c1ea7 100644 --- a/test-suite/ide/undo016.fake +++ b/test-suite/ide/undo016.fake @@ -27,5 +27,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } -- cgit v1.2.3 From 65e0522033ea47ed479227be30a92fceaa8c6358 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 02:20:10 +0100 Subject: Replacing the interpretation of Proof using ... with a proper code. --- toplevel/vernacentries.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 02f8c17175..fd125b335c 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -884,13 +884,13 @@ let vernac_set_used_variables e = (str "Unknown variable: " ++ pr_id id)) l; let _, to_clear = set_used_variables l in - (** FIXME: too fragile *) - let open Tacexpr in - let tac = { mltac_plugin = "coretactics"; mltac_tactic = "clear" } in - let tac = { mltac_name = tac; mltac_index = 0 } in - let arg = Genarg.in_gen (Genarg.rawwit (Genarg.wit_list Constrarg.wit_var)) to_clear in - let tac = if List.is_empty to_clear then TacId [] else TacML (Loc.ghost, tac, [TacGeneric arg]) in - vernac_solve SelectAll None tac false + let to_clear = List.map snd to_clear in + Proof_global.with_current_proof begin fun _ p -> + if List.is_empty to_clear then (p, ()) + else + let tac = Proofview.V82.tactic (Tactics.clear to_clear) in + fst (solve SelectAll None tac p), () + end (*****************************) -- cgit v1.2.3 From ce2ffd090bd64963279cbbb84012d1b266ed9918 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 01:43:29 +0100 Subject: Moving VernacSolve to an EXTEND-based definition. --- intf/vernacexpr.mli | 2 -- parsing/g_ltac.ml4 | 86 ++++++++++++++++++++++++++++++++++++++++------ printing/ppvernac.ml | 18 ---------- proofs/pfedit.ml | 2 +- proofs/proof_global.ml | 1 - stm/texmacspp.ml | 2 +- stm/vernac_classifier.ml | 2 -- toplevel/vernacentries.ml | 31 ----------------- toplevel/vernacentries.mli | 2 ++ 9 files changed, 80 insertions(+), 66 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 5501ca7c7f..36b855ec3b 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -31,7 +31,6 @@ type goal_selector = | SelectNth of int | SelectId of Id.t | SelectAll - | SelectAllParallel type goal_identifier = string type scope_name = string @@ -363,7 +362,6 @@ type vernac_expr = (* Solving *) - | VernacSolve of goal_selector * int option * raw_tactic_expr * bool | VernacSolveExistential of int * constr_expr (* Auxiliary file and library management *) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 35a9fede1b..79392195fb 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(*i camlp4deps: "grammar/grammar.cma" i*) + open Util open Pp open Compat @@ -38,7 +40,14 @@ let reference_to_id = function str "This expression should be a simple identifier.") let tactic_mode = Gram.entry_create "vernac:tactic_command" -let selector = Gram.entry_create "vernac:selector" + +let new_entry name = + let e = Gram.entry_create name in + let entry = Entry.create name in + let () = Pcoq.set_grammar entry e in + e + +let selector = new_entry "vernac:selector" (* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for proof editing and changes nothing else). Then sets it as the default proof mode. *) @@ -290,16 +299,73 @@ GEXTEND Gram selector: [ [ n=natural; ":" -> Vernacexpr.SelectNth n | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id - | IDENT "all" ; ":" -> Vernacexpr.SelectAll - | IDENT "par" ; ":" -> Vernacexpr.SelectAllParallel ] ] + | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] ; tactic_mode: - [ [ g = OPT selector; - tac = G_vernac.subgoal_command -> tac g - | g = OPT selector; info = OPT [IDENT "Info";n=natural -> n]; - tac = Tactic.tactic; use_dft_tac = [ "." -> false | "..." -> true ] -> - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - Vernacexpr.VernacSolve (g, info, tac, use_dft_tac) - ] ] + [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] ; END + +open Stdarg +open Constrarg +open Vernacexpr +open Vernac_classifier + +let print_info_trace = ref None + +let _ = let open Goptions in declare_int_option { + optsync = true; + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Pp.feedback Feedback.AddedAxiom + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ selector(s) ] -> [ s ] +END + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info +| [ "Info" natural(n) ] -> [ n ] +END + +let pr_ltac_use_default b = if b then str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +VERNAC tactic_mode EXTEND VernacSolve +| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ classify_as_proofstep ] -> [ + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + vernac_solve g n t def + ] +| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ VtProofStep true, VtLater ] -> [ + vernac_solve SelectAll n t def + ] +END diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index a101540aba..887a14d2bf 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -979,24 +979,6 @@ module Make prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) ) (* Solving *) - | VernacSolve (i,info,tac,deftac) -> - let pr_goal_selector = function - | SelectNth i -> int i ++ str":" - | SelectId id -> pr_id id ++ str":" - | SelectAll -> str"all" ++ str":" - | SelectAllParallel -> str"par" - in - let pr_info = - match info with - | None -> mt () - | Some i -> str"Info"++spc()++int i++spc() - in - return ( - (if i = Proof_global.get_default_goal_selector () then mt() else pr_goal_selector i) ++ - pr_info ++ - pr_raw_tactic tac - ++ (if deftac then str ".." else mt ()) - ) | VernacSolveExistential (i,c) -> return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 0fdcaa5875..608ee2c700 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -104,7 +104,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let tac = match gi with | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac - | Vernacexpr.SelectAll | Vernacexpr.SelectAllParallel -> tac + | Vernacexpr.SelectAll -> tac in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in let () = diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index d19dc5ba0f..647dbe1115 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -664,7 +664,6 @@ let print_goal_selector = function | Vernacexpr.SelectAll -> "all" | Vernacexpr.SelectNth i -> string_of_int i | Vernacexpr.SelectId id -> Id.to_string id - | Vernacexpr.SelectAllParallel -> "par" let parse_goal_selector = function | "all" -> Vernacexpr.SelectAll diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index 3c4b8cb71e..a459cd65f8 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -671,7 +671,7 @@ let rec tmpp v loc = (* Solving *) - | (VernacSolve _ | VernacSolveExistential _) as x -> + | (VernacSolveExistential _) as x -> xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] (* Auxiliary file and library management *) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index f9f08f7afb..97d6e1fb71 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -102,12 +102,10 @@ let rec classify_vernac e = | VernacCheckMayEval _ -> VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater (* ProofStep *) - | VernacSolve (SelectAllParallel,_,_,_) -> VtProofStep true, VtLater | VernacProof _ | VernacBullet _ | VernacFocus _ | VernacUnfocus | VernacSubproof _ | VernacEndSubproof - | VernacSolve _ | VernacCheckGuard | VernacUnfocused | VernacSolveExistential _ -> VtProofStep false, VtLater diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index fd125b335c..8ba5eb3f7d 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -826,35 +826,6 @@ let vernac_declare_class id = let command_focus = Proof.new_focus_kind () let focus_command_cond = Proof.no_cond command_focus - -let print_info_trace = ref None - -let _ = let open Goptions in declare_int_option { - optsync = true; - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - if not (refining ()) then - error "Unknown command of the non proof-editing mode."; - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus command_focus p in - p,status) in - if not status then Pp.feedback Feedback.AddedAxiom - - (* A command which should be a tactic. It has been added by Christine to patch an error in the design of the proof machine, and enables to instantiate existential variables when @@ -892,7 +863,6 @@ let vernac_set_used_variables e = fst (solve SelectAll None tac p), () end - (*****************************) (* Auxiliary file management *) @@ -1909,7 +1879,6 @@ let interp ?proof ~loc locality poly c = | VernacDeclareClass id -> vernac_declare_class id (* Solving *) - | VernacSolve (n,info,tac,b) -> vernac_solve n info tac b | VernacSolveExistential (n,c) -> vernac_solve_existential n c (* Auxiliary file and library management *) diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 451ccdb4d4..4a59b1299b 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -59,3 +59,5 @@ val vernac_end_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit val with_fail : bool -> (unit -> unit) -> unit + +val command_focus : unit Proof.focus_kind -- cgit v1.2.3 From f25396b3a35ea5cd64b8b68670e66a14a78c418c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 17:04:07 +0100 Subject: Further reducing the dependencies of the EXTEND macros. --- grammar/argextend.ml4 | 15 +++++---------- grammar/grammar.mllib | 7 ------- grammar/q_util.ml4 | 2 +- grammar/tacextend.ml4 | 23 ++++------------------- grammar/vernacextend.ml4 | 20 ++++++++++++-------- parsing/tok.ml | 20 +++++++++++--------- 6 files changed, 33 insertions(+), 54 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index bebde706e4..801229bcb9 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -16,11 +16,6 @@ open Extend let loc = CompatLoc.ghost let default_loc = <:expr< Loc.ghost >> -let qualified_name loc s = - let path = CString.split '.' s in - let (name, path) = CList.sep_last path in - qualified_name loc path name - let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function @@ -56,7 +51,7 @@ let make_rule loc (prods,act) = <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> let is_ident x = function -| <:expr< $lid:s$ >> -> CString.equal s x +| <:expr< $lid:s$ >> -> (s : string) = x | _ -> false let make_extend loc s cl wit = match cl with @@ -85,7 +80,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let glob = match g with | None -> begin match rawtyp with - | Genarg.ExtraArgType s' when CString.equal s s' -> + | Genarg.ExtraArgType s' when s = s' -> <:expr< fun ist v -> (ist, v) >> | _ -> <:expr< fun ist v -> @@ -100,7 +95,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let interp = match f with | None -> begin match globtyp with - | Genarg.ExtraArgType s' when CString.equal s s' -> + | Genarg.ExtraArgType s' when s = s' -> <:expr< fun ist v -> Ftactic.return v >> | _ -> <:expr< fun ist x -> @@ -120,7 +115,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let subst = match h with | None -> begin match globtyp with - | Genarg.ExtraArgType s' when CString.equal s s' -> + | Genarg.ExtraArgType s' when s = s' -> <:expr< fun s v -> v >> | _ -> <:expr< fun s x -> @@ -132,7 +127,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let dyn = match typ with | `Uniform typ -> let is_new = match typ with - | Genarg.ExtraArgType s' when CString.equal s s' -> true + | Genarg.ExtraArgType s' when s = s' -> true | _ -> false in if is_new then <:expr< None >> diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 42fc738783..9b24c97974 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -1,15 +1,8 @@ Coq_config -Hashset -Hashcons -CMap -Int -Option Store Exninfo Loc -CList -CString Tok Compat diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index d91bfd7b8d..bde1e76517 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -57,7 +57,7 @@ let rec mlexpr_of_prod_entry_key f = function | Extend.Uentry e -> <:expr< Extend.Aentry $f e$ >> | Extend.Uentryl (e, l) -> (** Keep in sync with Pcoq! *) - assert (CString.equal e "tactic"); + assert (e = "tactic"); if l = 5 then <:expr< Extend.Aentry (Pcoq.name_of_entry Pcoq.Tactic.binder_tactic) >> else <:expr< Extend.Aentryl (Pcoq.name_of_entry Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 1951b8b452..a34b880ae4 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -24,15 +24,6 @@ let rec make_patt = function <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l -let rec mlexpr_of_argtype loc = function - | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> - | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> - | Genarg.PairArgType (t1,t2) -> - let t1 = mlexpr_of_argtype loc t1 in - let t2 = mlexpr_of_argtype loc t2 in - <:expr< Genarg.PairArgType $t1$ $t2$ >> - | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> - let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> | ExtNonTerminal (t, _, p) :: l -> @@ -44,12 +35,6 @@ let rec make_let raw e = function <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let raw e l -let rec extract_signature = function - | [] -> [] - | ExtNonTerminal (t, _, _) :: l -> t :: extract_signature l - | _::l -> extract_signature l - - let make_clause (pt,_,e) = (make_patt pt, vala None, @@ -99,13 +84,13 @@ let declare_tactic loc s c cl = match cl with let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in let name = mlexpr_of_string name in - let tac = + let tac = match rem with + | [] -> (** Special handling of tactics without arguments: such tactics do not do a Proofview.Goal.nf_enter to compute their arguments. It matters for some whole-prof tactics like [shelve_unifiable]. *) - if CList.is_empty rem then <:expr< fun _ $lid:"ist"$ -> $tac$ >> - else + | _ -> let f = Compat.make_fun loc [patt, vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in <:expr< Tacinterp.lift_constr_tac_to_ml_tac $vars$ $f$ >> in @@ -178,7 +163,7 @@ EXTEND let e = parse_user_entry e sep in ExtNonTerminal (type_of_user_symbol e, e, s) | s = STRING -> - let () = if CString.is_empty s then failwith "Empty terminal." in + let () = if s = "" then failwith "Empty terminal." in ExtTerminal s ] ] ; diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 453907689e..40e327c379 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -43,9 +43,11 @@ let make_clause { r_patt = pt; r_branch = e; } = (* To avoid warnings *) let mk_ignore c pt = - let names = CList.map_filter (function - | ExtNonTerminal (_, _, p) -> Some p - | _ -> None) pt in + let fold accu = function + | ExtNonTerminal (_, _, p) -> p :: accu + | _ -> accu + in + let names = List.fold_left fold [] pt in let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in let names = List.fold_left fold <:expr< () >> names in <:expr< do { let _ = $names$ in $c$ } >> @@ -99,10 +101,12 @@ let make_fun_classifiers loc s c l = let cl = List.map (fun x -> Compat.make_fun loc [make_clause_classifier c s x]) l in mlexpr_of_list (fun x -> x) cl -let mlexpr_of_clause = - mlexpr_of_list - (fun { r_head = a; r_patt = b; } -> mlexpr_of_list make_prod_item - (Option.List.cons (Option.map (fun a -> ExtTerminal a) a) b)) +let mlexpr_of_clause cl = + let mkexpr { r_head = a; r_patt = b; } = match a with + | None -> mlexpr_of_list make_prod_item b + | Some a -> mlexpr_of_list make_prod_item (ExtTerminal a :: b) + in + mlexpr_of_list mkexpr cl let declare_command loc s c nt cl = let se = mlexpr_of_string s in @@ -160,7 +164,7 @@ EXTEND rule: [ [ "["; s = STRING; l = LIST0 args; "]"; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let () = if CString.is_empty s then failwith "Command name is empty." in + let () = if s = "" then failwith "Command name is empty." in let b = <:expr< fun () -> $e$ >> in { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } | "[" ; "-" ; l = LIST1 args ; "]" ; diff --git a/parsing/tok.ml b/parsing/tok.ml index 6b90086155..df7e7c2a6b 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -8,6 +8,8 @@ (** The type of token for the Coq lexer and parser *) +let string_equal (s1 : string) s2 = s1 = s2 + type t = | KEYWORD of string | PATTERNIDENT of string @@ -21,16 +23,16 @@ type t = | EOI let equal t1 t2 = match t1, t2 with -| IDENT s1, KEYWORD s2 -> CString.equal s1 s2 -| KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 -| PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 -| IDENT s1, IDENT s2 -> CString.equal s1 s2 -| FIELD s1, FIELD s2 -> CString.equal s1 s2 -| INT s1, INT s2 -> CString.equal s1 s2 -| INDEX s1, INDEX s2 -> CString.equal s1 s2 -| STRING s1, STRING s2 -> CString.equal s1 s2 +| IDENT s1, KEYWORD s2 -> string_equal s1 s2 +| KEYWORD s1, KEYWORD s2 -> string_equal s1 s2 +| PATTERNIDENT s1, PATTERNIDENT s2 -> string_equal s1 s2 +| IDENT s1, IDENT s2 -> string_equal s1 s2 +| FIELD s1, FIELD s2 -> string_equal s1 s2 +| INT s1, INT s2 -> string_equal s1 s2 +| INDEX s1, INDEX s2 -> string_equal s1 s2 +| STRING s1, STRING s2 -> string_equal s1 s2 | LEFTQMARK, LEFTQMARK -> true -| BULLET s1, BULLET s2 -> CString.equal s1 s2 +| BULLET s1, BULLET s2 -> string_equal s1 s2 | EOI, EOI -> true | _ -> false -- cgit v1.2.3 From f329e1e63eb29958c4cc0d7bddfdb84a754351d2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 17:55:15 +0100 Subject: Do not keep the argument type in ExtNonTerminal. --- grammar/argextend.ml4 | 10 +++++----- grammar/q_util.ml4 | 2 +- grammar/q_util.mli | 2 +- grammar/tacextend.ml4 | 16 +++++++++------- grammar/vernacextend.ml4 | 9 +++++---- 5 files changed, 21 insertions(+), 18 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 801229bcb9..a38f57cdc9 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -32,14 +32,14 @@ let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> - | ExtNonTerminal (_, _, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> + | ExtNonTerminal (_, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> | ExtTerminal _ :: tl -> <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function | ExtTerminal s -> <:expr< Extend.Atoken (Lexer.terminal $mlexpr_of_string s$) >> - | ExtNonTerminal (_, g, _) -> + | ExtNonTerminal (g, _) -> let base s = <:expr< Pcoq.name_of_entry $lid:s$ >> in mlexpr_of_prod_entry_key base g @@ -55,7 +55,7 @@ let is_ident x = function | _ -> false let make_extend loc s cl wit = match cl with -| [[ExtNonTerminal (_, Uentry e, id)], act] when is_ident id act -> +| [[ExtNonTerminal (Uentry e, id)], act] when is_ident id act -> (** Special handling of identity arguments by not redeclaring an entry *) <:str_item< value $lid:s$ = @@ -223,10 +223,10 @@ EXTEND genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in - ExtNonTerminal (type_of_user_symbol e, e, s) + ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in - ExtNonTerminal (type_of_user_symbol e, e, s) + ExtNonTerminal (e, s) | s = STRING -> ExtTerminal s ] ] ; diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index bde1e76517..56deb61f3d 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -13,7 +13,7 @@ open Compat type extend_token = | ExtTerminal of string -| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * string +| ExtNonTerminal of Extend.user_symbol * string let mlexpr_of_list f l = List.fold_right diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 5f292baf32..c84e9d1406 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -10,7 +10,7 @@ open Compat (* necessary for camlp4 *) type extend_token = | ExtTerminal of string -| ExtNonTerminal of Genarg.argument_type * Extend.user_symbol * string +| ExtNonTerminal of Extend.user_symbol * string val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index a34b880ae4..51c382b3b7 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -20,13 +20,14 @@ let plugin_name = <:expr< __coq_plugin_name >> let rec make_patt = function | [] -> <:patt< [] >> - | ExtNonTerminal (_, _, p) :: l -> + | ExtNonTerminal (_, p) :: l -> <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> - | ExtNonTerminal (t, _, p) :: l -> + | ExtNonTerminal (g, p) :: l -> + let t = type_of_user_symbol g in let loc = MLast.loc_of_expr e in let e = make_let raw e l in let v = @@ -46,7 +47,8 @@ let make_fun_clauses loc s l = let make_prod_item = function | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | ExtNonTerminal (nt, g, id) -> + | ExtNonTerminal (g, id) -> + let nt = type_of_user_symbol g in let base s = <:expr< Pcoq.name_of_entry (Pcoq.genarg_grammar $mk_extraarg loc s$) >> in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ $mlexpr_of_prod_entry_key base g$ >> @@ -66,11 +68,11 @@ let make_printing_rule r = mlexpr_of_list make_one_printing_rule r (** Special treatment of constr entries *) let is_constr_gram = function | ExtTerminal _ -> false -| ExtNonTerminal (_, Extend.Uentry "constr", _) -> true +| ExtNonTerminal (Extend.Uentry "constr", _) -> true | _ -> false let make_var = function - | ExtNonTerminal (_, _, p) -> Some p + | ExtNonTerminal (_, p) -> Some p | _ -> assert false let declare_tactic loc s c cl = match cl with @@ -158,10 +160,10 @@ EXTEND tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in - ExtNonTerminal (type_of_user_symbol e, e, s) + ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in - ExtNonTerminal (type_of_user_symbol e, e, s) + ExtNonTerminal (e, s) | s = STRING -> let () = if s = "" then failwith "Empty terminal." in ExtTerminal s diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 40e327c379..aedaead71a 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -30,7 +30,8 @@ type rule = { let rec make_let e = function | [] -> e - | ExtNonTerminal (t, _, p) :: l -> + | ExtNonTerminal (g, p) :: l -> + let t = type_of_user_symbol g in let loc = MLast.loc_of_expr e in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> @@ -44,7 +45,7 @@ let make_clause { r_patt = pt; r_branch = e; } = (* To avoid warnings *) let mk_ignore c pt = let fold accu = function - | ExtNonTerminal (_, _, p) -> p :: accu + | ExtNonTerminal (_, p) -> p :: accu | _ -> accu in let names = List.fold_left fold [] pt in @@ -179,10 +180,10 @@ EXTEND args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let e = parse_user_entry e "" in - ExtNonTerminal (type_of_user_symbol e, e, s) + ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> let e = parse_user_entry e sep in - ExtNonTerminal (type_of_user_symbol e, e, s) + ExtNonTerminal (e, s) | s = STRING -> ExtTerminal s ] ] -- cgit v1.2.3 From a559727d0a219db79d4230cccc2b4e73c8fc30c8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 18:20:51 +0100 Subject: EXTEND macros use their own internal representations. --- grammar/argextend.ml4 | 30 +++++++++++------------------- grammar/q_util.ml4 | 41 ++++++++++++++++++++++++++++------------- grammar/q_util.mli | 24 ++++++++++++++++++++---- grammar/tacextend.ml4 | 2 +- 4 files changed, 60 insertions(+), 37 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index a38f57cdc9..f9f3ee988e 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -8,10 +8,8 @@ (*i camlp4deps: "tools/compat5b.cmo" i*) -open Genarg open Q_util open Compat -open Extend let loc = CompatLoc.ghost let default_loc = <:expr< Loc.ghost >> @@ -25,6 +23,10 @@ let rec make_wit loc = function <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >> | ExtraArgType s -> mk_extraarg loc s +let is_self s = function +| ExtraArgType s' -> s = s' +| _ -> false + let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >> let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >> let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> @@ -79,30 +81,26 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = in let glob = match g with | None -> - begin match rawtyp with - | Genarg.ExtraArgType s' when s = s' -> + if is_self s rawtyp then <:expr< fun ist v -> (ist, v) >> - | _ -> + else <:expr< fun ist v -> let ans = out_gen $make_globwit loc rawtyp$ (Tacintern.intern_genarg ist (Genarg.in_gen $make_rawwit loc rawtyp$ v)) in (ist, ans) >> - end | Some f -> <:expr< fun ist v -> (ist, $lid:f$ ist v) >> in let interp = match f with | None -> - begin match globtyp with - | Genarg.ExtraArgType s' when s = s' -> + if is_self s globtyp then <:expr< fun ist v -> Ftactic.return v >> - | _ -> + else <:expr< fun ist x -> Ftactic.bind (Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x)) (fun v -> Ftactic.return (Tacinterp.Value.cast $make_topwit loc globtyp$ v)) >> - end | Some f -> (** Compatibility layer, TODO: remove me *) <:expr< @@ -114,23 +112,17 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = >> in let subst = match h with | None -> - begin match globtyp with - | Genarg.ExtraArgType s' when s = s' -> + if is_self s globtyp then <:expr< fun s v -> v >> - | _ -> + else <:expr< fun s x -> out_gen $make_globwit loc globtyp$ (Tacsubst.subst_genarg s (Genarg.in_gen $make_globwit loc globtyp$ x)) >> - end | Some f -> <:expr< $lid:f$>> in let dyn = match typ with | `Uniform typ -> - let is_new = match typ with - | Genarg.ExtraArgType s' when s = s' -> true - | _ -> false - in - if is_new then <:expr< None >> + if is_self s typ then <:expr< None >> else <:expr< Some (Genarg.val_tag $make_topwit loc typ$) >> | `Specialized _ -> <:expr< None >> in diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 56deb61f3d..6821887327 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -8,12 +8,27 @@ (* This file defines standard combinators to build ml expressions *) -open Extend open Compat +type argument_type = +| ListArgType of argument_type +| OptArgType of argument_type +| PairArgType of argument_type * argument_type +| ExtraArgType of string + +type user_symbol = +| Ulist1 : user_symbol -> user_symbol +| Ulist1sep : user_symbol * string -> user_symbol +| Ulist0 : user_symbol -> user_symbol +| Ulist0sep : user_symbol * string -> user_symbol +| Uopt : user_symbol -> user_symbol +| Umodifiers : user_symbol -> user_symbol +| Uentry : string -> user_symbol +| Uentryl : string * int -> user_symbol + type extend_token = | ExtTerminal of string -| ExtNonTerminal of Extend.user_symbol * string +| ExtNonTerminal of user_symbol * string let mlexpr_of_list f l = List.fold_right @@ -48,14 +63,14 @@ let mlexpr_of_ident id = <:expr< Names.Id.of_string $str:id$ >> let rec mlexpr_of_prod_entry_key f = function - | Extend.Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> - | Extend.Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> - | Extend.Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> - | Extend.Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> - | Extend.Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> - | Extend.Umodifiers s -> <:expr< Extend.Amodifiers $mlexpr_of_prod_entry_key f s$ >> - | Extend.Uentry e -> <:expr< Extend.Aentry $f e$ >> - | Extend.Uentryl (e, l) -> + | Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> + | Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> + | Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> + | Umodifiers s -> <:expr< Extend.Amodifiers $mlexpr_of_prod_entry_key f s$ >> + | Uentry e -> <:expr< Extend.Aentry $f e$ >> + | Uentryl (e, l) -> (** Keep in sync with Pcoq! *) assert (e = "tactic"); if l = 5 then <:expr< Extend.Aentry (Pcoq.name_of_entry Pcoq.Tactic.binder_tactic) >> @@ -63,10 +78,10 @@ let rec mlexpr_of_prod_entry_key f = function let rec type_of_user_symbol = function | Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) | Umodifiers s -> - Genarg.ListArgType (type_of_user_symbol s) + ListArgType (type_of_user_symbol s) | Uopt s -> - Genarg.OptArgType (type_of_user_symbol s) -| Uentry e | Uentryl (e, _) -> Genarg.ExtraArgType e + OptArgType (type_of_user_symbol s) +| Uentry e | Uentryl (e, _) -> ExtraArgType e let coincide s pat off = let len = String.length pat in diff --git a/grammar/q_util.mli b/grammar/q_util.mli index c84e9d1406..7d4cc0200a 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -8,9 +8,25 @@ open Compat (* necessary for camlp4 *) +type argument_type = +| ListArgType of argument_type +| OptArgType of argument_type +| PairArgType of argument_type * argument_type +| ExtraArgType of string + +type user_symbol = +| Ulist1 : user_symbol -> user_symbol +| Ulist1sep : user_symbol * string -> user_symbol +| Ulist0 : user_symbol -> user_symbol +| Ulist0sep : user_symbol * string -> user_symbol +| Uopt : user_symbol -> user_symbol +| Umodifiers : user_symbol -> user_symbol +| Uentry : string -> user_symbol +| Uentryl : string * int -> user_symbol + type extend_token = | ExtTerminal of string -| ExtNonTerminal of Extend.user_symbol * string +| ExtNonTerminal of user_symbol * string val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr @@ -28,8 +44,8 @@ val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr val mlexpr_of_ident : string -> MLast.expr -val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> Extend.user_symbol -> MLast.expr +val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr -val type_of_user_symbol : Extend.user_symbol -> Genarg.argument_type +val type_of_user_symbol : user_symbol -> argument_type -val parse_user_entry : string -> string -> Extend.user_symbol +val parse_user_entry : string -> string -> user_symbol diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 51c382b3b7..bbd3d8a62f 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -68,7 +68,7 @@ let make_printing_rule r = mlexpr_of_list make_one_printing_rule r (** Special treatment of constr entries *) let is_constr_gram = function | ExtTerminal _ -> false -| ExtNonTerminal (Extend.Uentry "constr", _) -> true +| ExtNonTerminal (Uentry "constr", _) -> true | _ -> false let make_var = function -- cgit v1.2.3 From 2cf8f76ea6a15d46b57d5c4ecf9513683561e284 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 18:46:54 +0100 Subject: Removing the untyped representation of genargs. --- lib/genarg.ml | 53 +++++++++++++++++++++------------------------------- lib/genarg.mli | 7 +------ printing/genprint.ml | 5 +++-- printing/pptactic.ml | 4 ++-- 4 files changed, 27 insertions(+), 42 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index 7aada461f5..27d7b50e52 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -56,29 +56,6 @@ struct end -type argument_type = - (* Specific types *) - | ListArgType of argument_type - | OptArgType of argument_type - | PairArgType of argument_type * argument_type - | ExtraArgType of string - -let rec argument_type_eq arg1 arg2 = match arg1, arg2 with -| ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 -| OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 -| PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) -> - argument_type_eq arg1l arg2l && argument_type_eq arg1r arg2r -| ExtraArgType s1, ExtraArgType s2 -> CString.equal s1 s2 -| _ -> false - -let rec pr_argument_type = function -| ListArgType t -> pr_argument_type t ++ spc () ++ str "list" -| OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" -| PairArgType (t1, t2) -> - str "("++ pr_argument_type t1 ++ spc () ++ - str "*" ++ spc () ++ pr_argument_type t2 ++ str ")" -| ExtraArgType s -> str s - type (_, _, _) genarg_type = | ExtraArg : ('a * 'b * 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type | ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type @@ -86,6 +63,8 @@ type (_, _, _) genarg_type = | PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type +type argument_type = ArgumentType : ('a, 'b, 'c) genarg_type -> argument_type + let rec genarg_type_eq : type a1 a2 b1 b2 c1 c2. (a1, b1, c1) genarg_type -> (a2, b2, c2) genarg_type -> (a1 * b1 * c1, a2 * b2 * c2) CSig.eq option = @@ -111,6 +90,22 @@ fun t1 t2 -> match t1, t2 with end | _ -> None +let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> std_ppcmds = function +| ListArg t -> pr_genarg_type t ++ spc () ++ str "list" +| OptArg t -> pr_genarg_type t ++ spc () ++ str "opt" +| PairArg (t1, t2) -> + str "("++ pr_genarg_type t1 ++ spc () ++ + str "*" ++ spc () ++ pr_genarg_type t2 ++ str ")" +| ExtraArg s -> str (ArgT.repr s) + +let rec argument_type_eq arg1 arg2 = match arg1, arg2 with +| ArgumentType t1, ArgumentType t2 -> + match genarg_type_eq t1 t2 with + | None -> false + | Some Refl -> true + +let rec pr_argument_type (ArgumentType t) = pr_genarg_type t + type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision *) @@ -177,16 +172,10 @@ let has_type (GenArg (t, v)) u = match abstract_argument_type_eq t u with | None -> false | Some _ -> true -let rec untype : type a b c. (a, b, c) genarg_type -> argument_type = function -| ExtraArg t -> ExtraArgType (ArgT.repr t) -| ListArg t -> ListArgType (untype t) -| OptArg t -> OptArgType (untype t) -| PairArg (t1, t2) -> PairArgType (untype t1, untype t2) - let unquote : type l. (_, l) abstract_argument_type -> _ = function -| Rawwit t -> untype t -| Glbwit t -> untype t -| Topwit t -> untype t +| Rawwit t -> ArgumentType t +| Glbwit t -> ArgumentType t +| Topwit t -> ArgumentType t let genarg_tag (GenArg (t, _)) = unquote t diff --git a/lib/genarg.mli b/lib/genarg.mli index d509649f22..ac13f545ba 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -187,12 +187,7 @@ val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag (** {6 Type reification} *) -type argument_type = - (** Specific types *) - | ListArgType of argument_type - | OptArgType of argument_type - | PairArgType of argument_type * argument_type - | ExtraArgType of string +type argument_type = ArgumentType : ('a, 'b, 'c) genarg_type -> argument_type (** {6 Equalities} *) diff --git a/printing/genprint.ml b/printing/genprint.ml index d8bd81c4cc..0ec35e07be 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -19,8 +19,9 @@ module PrintObj = struct type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) printer let name = "printer" - let default wit = match unquote (rawwit wit) with - | ExtraArgType name -> + let default wit = match wit with + | ExtraArg tag -> + let name = ArgT.repr tag in let printer = { raw = (fun _ -> str ""); glb = (fun _ -> str ""); diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 7d5e7772c3..d99a5f0d89 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -67,8 +67,8 @@ type 'a extra_genarg_printer = let genarg_pprule = ref String.Map.empty let declare_extra_genarg_pprule wit f g h = - let s = match unquote (topwit wit) with - | ExtraArgType s -> s + let s = match wit with + | ExtraArg s -> ArgT.repr s | _ -> error "Can declare a pretty-printing rule only for extra argument types." in -- cgit v1.2.3 From 27d173f94a68367d91def90c6d287138c733054b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 18:55:01 +0100 Subject: Removing dead code in Genarg. --- interp/constrarg.ml | 21 --------------------- interp/stdarg.ml | 6 ------ lib/genarg.ml | 14 -------------- lib/genarg.mli | 10 ---------- 4 files changed, 51 deletions(-) diff --git a/interp/constrarg.ml b/interp/constrarg.ml index 20ee7aa4fb..81e942d828 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -63,27 +63,6 @@ let wit_red_expr = Genarg.make0 "redexpr" let wit_clause_dft_concl = Genarg.make0 "clause_dft_concl" -(** Register location *) - -let () = - register_name0 wit_int_or_var "Constrarg.wit_int_or_var"; - register_name0 wit_ref "Constrarg.wit_ref"; - register_name0 wit_ident "Constrarg.wit_ident"; - register_name0 wit_var "Constrarg.wit_var"; - register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern"; - register_name0 wit_tactic "Constrarg.wit_tactic"; - register_name0 wit_sort "Constrarg.wit_sort"; - register_name0 wit_constr "Constrarg.wit_constr"; - register_name0 wit_uconstr "Constrarg.wit_uconstr"; - register_name0 wit_open_constr "Constrarg.wit_open_constr"; - register_name0 wit_constr_may_eval "Constrarg.wit_constr_may_eval"; - register_name0 wit_red_expr "Constrarg.wit_red_expr"; - register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl"; - register_name0 wit_quant_hyp "Constrarg.wit_quant_hyp"; - register_name0 wit_bindings "Constrarg.wit_bindings"; - register_name0 wit_constr_with_bindings "Constrarg.wit_constr_with_bindings"; - () - (** Aliases *) let wit_reference = wit_ref diff --git a/interp/stdarg.ml b/interp/stdarg.ml index e497c996f7..244cdd0a70 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -23,12 +23,6 @@ let wit_string : string uniform_genarg_type = let wit_pre_ident : string uniform_genarg_type = make0 "preident" -let () = register_name0 wit_unit "Stdarg.wit_unit" -let () = register_name0 wit_bool "Stdarg.wit_bool" -let () = register_name0 wit_int "Stdarg.wit_int" -let () = register_name0 wit_string "Stdarg.wit_string" -let () = register_name0 wit_pre_ident "Stdarg.wit_pre_ident" - (** Aliases for compatibility *) let wit_integer = wit_int diff --git a/lib/genarg.ml b/lib/genarg.ml index 27d7b50e52..0deb34afd7 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -303,17 +303,3 @@ struct | _ -> assert false end - -(** Hackish part *) - -let arg0_names = ref (String.Map.empty : string String.Map.t) - -let register_name0 t name = match t with -| ExtraArg s -> - let s = ArgT.repr s in - let () = assert (not (String.Map.mem s !arg0_names)) in - arg0_names := String.Map.add s name !arg0_names -| _ -> failwith "register_name0" - -let get_name0 name = - String.Map.find name !arg0_names diff --git a/lib/genarg.mli b/lib/genarg.mli index ac13f545ba..30b96c7000 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -242,13 +242,3 @@ val wit_list : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_ty val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type - -(** {5 Magic used by the parser} *) - -val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit -(** Used by the extension to give a name to types. The string should be the - absolute path of the argument witness, e.g. - [register_name0 wit_toto "MyArg.wit_toto"]. *) - -val get_name0 : string -> string -(** Return the absolute path of a given witness. *) -- cgit v1.2.3 From 13dd3f8ebaf90f30afbcb48034e5bdd90c825765 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 20:33:32 +0100 Subject: Fixing compilation with old versions of CAMLP5. --- parsing/g_ltac.ml4 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 79392195fb..d1992c57bb 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -310,10 +310,11 @@ open Stdarg open Constrarg open Vernacexpr open Vernac_classifier +open Goptions let print_info_trace = ref None -let _ = let open Goptions in declare_int_option { +let _ = declare_int_option { optsync = true; optdepr = false; optname = "print info trace"; -- cgit v1.2.3 From 25d49062425ee080d3e8d06920d3073e7a81b603 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 20:42:36 +0100 Subject: Fixing compilation with old versions of CAMLP5. --- grammar/q_util.ml4 | 16 ++++++++-------- grammar/q_util.mli | 16 ++++++++-------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 6821887327..53e1f008d9 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -17,14 +17,14 @@ type argument_type = | ExtraArgType of string type user_symbol = -| Ulist1 : user_symbol -> user_symbol -| Ulist1sep : user_symbol * string -> user_symbol -| Ulist0 : user_symbol -> user_symbol -| Ulist0sep : user_symbol * string -> user_symbol -| Uopt : user_symbol -> user_symbol -| Umodifiers : user_symbol -> user_symbol -| Uentry : string -> user_symbol -| Uentryl : string * int -> user_symbol +| Ulist1 of user_symbol +| Ulist1sep of user_symbol * string +| Ulist0 of user_symbol +| Ulist0sep of user_symbol * string +| Uopt of user_symbol +| Umodifiers of user_symbol +| Uentry of string +| Uentryl of string * int type extend_token = | ExtTerminal of string diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 7d4cc0200a..8c437b42a1 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -15,14 +15,14 @@ type argument_type = | ExtraArgType of string type user_symbol = -| Ulist1 : user_symbol -> user_symbol -| Ulist1sep : user_symbol * string -> user_symbol -| Ulist0 : user_symbol -> user_symbol -| Ulist0sep : user_symbol * string -> user_symbol -| Uopt : user_symbol -> user_symbol -| Umodifiers : user_symbol -> user_symbol -| Uentry : string -> user_symbol -| Uentryl : string * int -> user_symbol +| Ulist1 of user_symbol +| Ulist1sep of user_symbol * string +| Ulist0 of user_symbol +| Ulist0sep of user_symbol * string +| Uopt of user_symbol +| Umodifiers of user_symbol +| Uentry of string +| Uentryl of string * int type extend_token = | ExtTerminal of string -- cgit v1.2.3 From 64d9e1d1b9875c64613c7c5a95c696ab3e6f04cb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Mar 2016 21:26:58 +0100 Subject: Moving the use of Tactic_option from Obligations to G_obligations. --- tactics/g_obligations.ml4 | 14 ++++++++++---- toplevel/obligations.ml | 7 +++---- toplevel/obligations.mli | 6 ++---- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/tactics/g_obligations.ml4 b/tactics/g_obligations.ml4 index e67d701218..4cd8bf1feb 100644 --- a/tactics/g_obligations.ml4 +++ b/tactics/g_obligations.ml4 @@ -19,16 +19,22 @@ open Constrexpr_ops open Stdarg open Constrarg open Extraargs -open Pcoq.Prim -open Pcoq.Constr -open Pcoq.Tactic + +let (set_default_tactic, get_default_tactic, print_default_tactic) = + Tactic_option.declare_tactic_option "Program tactic" + +let () = + (** Delay to recover the tactic imperatively *) + let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> + snd (get_default_tactic ()) + end in + Obligations.default_tactic := tac (* We define new entries for programs, with the use of this module * Subtac. These entries are named Subtac. *) module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic open Pcoq diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 44c83be46c..b2fc456d07 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -323,8 +323,7 @@ let get_info x = let assumption_message = Declare.assumption_message -let (set_default_tactic, get_default_tactic, print_default_tactic) = - Tactic_option.declare_tactic_option "Program tactic" +let default_tactic = ref (Proofview.tclUNIT ()) (* true = All transparent, false = Opaque if possible *) let proofs_transparency = ref true @@ -895,7 +894,7 @@ let rec solve_obligation prg num tac = let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type ~terminator hook in let () = trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type) in - let _ = Pfedit.by (snd (get_default_tactic ())) in + let _ = Pfedit.by !default_tactic in Option.iter (fun tac -> Pfedit.set_end_tac tac) tac and obligation (user_num, name, typ) tac = @@ -924,7 +923,7 @@ and solve_obligation_by_tac prg obls i tac = | None -> match obl.obl_tac with | Some t -> t - | None -> snd (get_default_tactic ()) + | None -> !default_tactic in let evd = Evd.from_ctx !prg.prg_ctx in let evd = Evd.update_sigma_env evd (Global.env ()) in diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index e257da0161..3e99f5760b 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -54,10 +54,8 @@ type progress = (* Resolution status of a program *) | Remain of int (* n obligations remaining *) | Dependent (* Dependent on other definitions *) | Defined of global_reference (* Defined as id *) - -val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit -val get_default_tactic : unit -> locality_flag * unit Proofview.tactic -val print_default_tactic : unit -> Pp.std_ppcmds + +val default_tactic : unit Proofview.tactic ref val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) val get_proofs_transparency : unit -> bool -- cgit v1.2.3 From 8cb2040e4af40594826df97a735c38c8882934ca Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 00:30:24 +0100 Subject: Moving Tacinterp to Hightactics. --- parsing/g_ltac.ml4 | 372 --------------------------------------------- parsing/highparsing.mllib | 1 - tactics/g_ltac.ml4 | 372 +++++++++++++++++++++++++++++++++++++++++++++ tactics/hightactics.mllib | 4 + tactics/tacinterp.ml | 2 + tactics/tactics.mllib | 3 - toplevel/vernacentries.ml | 10 +- toplevel/vernacentries.mli | 3 + 8 files changed, 387 insertions(+), 380 deletions(-) delete mode 100644 parsing/g_ltac.ml4 create mode 100644 tactics/g_ltac.ml4 diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 deleted file mode 100644 index d1992c57bb..0000000000 --- a/parsing/g_ltac.ml4 +++ /dev/null @@ -1,372 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a - | e -> Tacexp (e:raw_tactic_expr) - -let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () -let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c - -let reference_to_id = function - | Libnames.Ident (loc, id) -> (loc, id) - | Libnames.Qualid (loc,_) -> - Errors.user_err_loc (loc, "", - str "This expression should be a simple identifier.") - -let tactic_mode = Gram.entry_create "vernac:tactic_command" - -let new_entry name = - let e = Gram.entry_create name in - let entry = Entry.create name in - let () = Pcoq.set_grammar entry e in - e - -let selector = new_entry "vernac:selector" - -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> set_command_entry tactic_mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); - } in - Proof_global.register_proof_mode mode - -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "[" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* Tactics grammar rules *) - -GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - tactic_mode constr_may_eval constr_eval selector; - - tactic_then_last: - [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> - Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] - ] ] - ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) - | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) - | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) - | ta = tactic_expr -> ([ta], None) - | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) - | -> ([TacId []], None) - ] ] - ; - tactic_then_locality: (* [true] for the local variant [TacThens] and [false] - for [TacExtend] *) - [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] - ; - tactic_expr: - [ "5" RIGHTA - [ te = binder_tactic -> te ] - | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) - | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> - match l , tail with - | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) - | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) - | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) ] - | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) - | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "once"; ta = tactic_expr -> TacOnce ta - | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta - | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta -(*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = ident -> - TacAbstract (tc,Some s) ] -(*End of To do*) - | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] - | "1" RIGHTA - [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,false,mrl) - | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; - mrl = match_context_list; "end" -> - TacMatchGoal (b,true,mrl) - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (b,c,mrl) - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; l = LIST0 message_token -> TacId l - | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (g,n,l) - | st = simple_tactic -> st - | a = tactic_arg -> TacArg(!@loc,a) - | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(!@loc,TacCall (!@loc,r,la)) ] - | "0" - [ "("; a = tactic_expr; ")" -> a - | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> - begin match tail with - | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) - | None -> TacDispatch tf - end - | a = tactic_atom -> TacArg (!@loc,a) ] ] - ; - failkw: - [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] - ; - (* binder_tactic: level 5 of tactic_expr *) - binder_tactic: - [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> - TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; - llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) - | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] - ; - (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> a - | r = reference -> Reference r - | c = Constr.constr -> ConstrMayEval (ConstrTerm c) - (* Unambigous entries: tolerated w/o "ltac:" modifier *) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l - | IDENT "type_term"; c=uconstr -> TacPretype c - | IDENT "numgoals" -> TacNumgoals ] ] - ; - (* If a qualid is given, use its short name. TODO: have the shortest - non ambiguous name where dots are replaced by "_"? Probably too - verbose most of the time. *) - fresh_id: - [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) - | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] - ; - constr_eval: - [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) - | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) - | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] - ; - constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] - ; - tactic_atom: - [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (!@loc,r,[]) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - match_key: - [ [ "match" -> Once - | "lazymatch" -> Select - | "multimatch" -> General ] ] - ; - input_fun: - [ [ "_" -> None - | l = ident -> Some l ] ] - ; - let_clause: - [ [ id = identref; ":="; te = tactic_expr -> - (id, arg_of_expr te) - | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - (id, arg_of_expr (TacFun(args,te))) ] ] - ; - match_pattern: - [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - let mode = not (!Flags.tactic_context_compat) in - Subterm (mode, oid, pc) - | IDENT "appcontext"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - msg_warning (strbrk "appcontext is deprecated"); - Subterm (true,oid, pc) - | pc = Constr.lconstr_pattern -> Term pc ] ] - ; - match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) - | na = name; ":="; mpv = match_pattern -> - let t, ty = - match mpv with - | Term t -> (match t with - | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) - | _ -> mpv, None) - | _ -> mpv, None - in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) - ] ] - ; - match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_context_list: - [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] - ; - message_token: - [ [ id = identref -> MsgIdent id - | s = STRING -> MsgString s - | n = integer -> MsgInt n ] ] - ; - - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) - else - let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, body) - else - let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, body) - ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - selector: - [ [ n=natural; ":" -> Vernacexpr.SelectNth n - | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id - | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] - ; - tactic_mode: - [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] - ; - END - -open Stdarg -open Constrarg -open Vernacexpr -open Vernac_classifier -open Goptions - -let print_info_trace = ref None - -let _ = declare_int_option { - optsync = true; - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Pp.feedback Feedback.AddedAxiom - -let pr_ltac_selector = function -| SelectNth i -> int i ++ str ":" -| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" -| SelectAll -> str "all" ++ str ":" - -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ selector(s) ] -> [ s ] -END - -let pr_ltac_info n = str "Info" ++ spc () ++ int n - -VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info -| [ "Info" natural(n) ] -> [ n ] -END - -let pr_ltac_use_default b = if b then str ".." else mt () - -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] -END - -VERNAC tactic_mode EXTEND VernacSolve -| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ classify_as_proofstep ] -> [ - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - vernac_solve g n t def - ] -| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ VtProofStep true, VtLater ] -> [ - vernac_solve SelectAll n t def - ] -END diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index eed6caea30..8df519b567 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -3,4 +3,3 @@ G_vernac G_prim G_proofs G_tactic -G_ltac diff --git a/tactics/g_ltac.ml4 b/tactics/g_ltac.ml4 new file mode 100644 index 0000000000..d1992c57bb --- /dev/null +++ b/tactics/g_ltac.ml4 @@ -0,0 +1,372 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a + | e -> Tacexp (e:raw_tactic_expr) + +let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () +let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n +let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c + +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + Errors.user_err_loc (loc, "", + str "This expression should be a simple identifier.") + +let tactic_mode = Gram.entry_create "vernac:tactic_command" + +let new_entry name = + let e = Gram.entry_create name in + let entry = Entry.create name in + let () = Pcoq.set_grammar entry e in + e + +let selector = new_entry "vernac:selector" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> set_command_entry tactic_mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Gram.Entry.of_parser "test_bracket_ident" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "[" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* Tactics grammar rules *) + +GEXTEND Gram + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg + tactic_mode constr_may_eval constr_eval selector; + + tactic_then_last: + [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> + Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) + | -> [||] + ] ] + ; + tactic_then_gen: + [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) + | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) + | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) + | ta = tactic_expr -> ([ta], None) + | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) + | -> ([TacId []], None) + ] ] + ; + tactic_then_locality: (* [true] for the local variant [TacThens] and [false] + for [TacExtend] *) + [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] + ; + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> te ] + | "4" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) + | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> + match l , tail with + | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | false , None -> TacThen (ta0,TacDispatch first) + | true , None -> TacThens (ta0,first) ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> TacTry ta + | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) + | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) + | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) + | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta + | IDENT "progress"; ta = tactic_expr -> TacProgress ta + | IDENT "once"; ta = tactic_expr -> TacOnce ta + | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta + | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> + TacAbstract (tc,Some s) ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) + | IDENT "tryif" ; ta = tactic_expr ; + "then" ; tat = tactic_expr ; + "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) + | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] + | "1" RIGHTA + [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + TacMatchGoal (b,false,mrl) + | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + TacMatchGoal (b,true,mrl) + | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + TacMatch (b,c,mrl) + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacFirst l + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacSolve l + | IDENT "idtac"; l = LIST0 message_token -> TacId l + | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; + l = LIST0 message_token -> TacFail (g,n,l) + | st = simple_tactic -> st + | a = tactic_arg -> TacArg(!@loc,a) + | r = reference; la = LIST0 tactic_arg_compat -> + TacArg(!@loc,TacCall (!@loc,r,la)) ] + | "0" + [ "("; a = tactic_expr; ")" -> a + | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> + begin match tail with + | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) + | None -> TacDispatch tf + end + | a = tactic_atom -> TacArg (!@loc,a) ] ] + ; + failkw: + [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] + ; + (* binder_tactic: level 5 of tactic_expr *) + binder_tactic: + [ RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + TacFun (it,body) + | "let"; isrec = [IDENT "rec" -> true | -> false]; + llc = LIST1 let_clause SEP "with"; "in"; + body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) + | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] + ; + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> a + | r = reference -> Reference r + | c = Constr.constr -> ConstrMayEval (ConstrTerm c) + (* Unambigous entries: tolerated w/o "ltac:" modifier *) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + (* Can be used as argument and at toplevel in tactic expressions. *) + tactic_arg: + [ [ c = constr_eval -> ConstrMayEval c + | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l + | IDENT "type_term"; c=uconstr -> TacPretype c + | IDENT "numgoals" -> TacNumgoals ] ] + ; + (* If a qualid is given, use its short name. TODO: have the shortest + non ambiguous name where dots are replaced by "_"? Probably too + verbose most of the time. *) + fresh_id: + [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) + | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] + ; + constr_eval: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrEval (rtc,c) + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + ConstrContext (id,c) + | IDENT "type"; IDENT "of"; c = Constr.constr -> + ConstrTypeOf c ] ] + ; + constr_may_eval: (* For extensions *) + [ [ c = constr_eval -> c + | c = Constr.constr -> ConstrTerm c ] ] + ; + tactic_atom: + [ [ n = integer -> TacGeneric (genarg_of_int n) + | r = reference -> TacCall (!@loc,r,[]) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + match_key: + [ [ "match" -> Once + | "lazymatch" -> Select + | "multimatch" -> General ] ] + ; + input_fun: + [ [ "_" -> None + | l = ident -> Some l ] ] + ; + let_clause: + [ [ id = identref; ":="; te = tactic_expr -> + (id, arg_of_expr te) + | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + (id, arg_of_expr (TacFun(args,te))) ] ] + ; + match_pattern: + [ [ IDENT "context"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + let mode = not (!Flags.tactic_context_compat) in + Subterm (mode, oid, pc) + | IDENT "appcontext"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + msg_warning (strbrk "appcontext is deprecated"); + Subterm (true,oid, pc) + | pc = Constr.lconstr_pattern -> Term pc ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) + | na = name; ":="; mpv = match_pattern -> + let t, ty = + match mpv with + | Term t -> (match t with + | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) + ] ] + ; + match_context_rule: + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] + ; + message_token: + [ [ id = identref -> MsgIdent id + | s = STRING -> MsgString s + | n = integer -> MsgInt n ] ] + ; + + ltac_def_kind: + [ [ ":=" -> false + | "::=" -> true ] ] + ; + + (* Definitions for tactics *) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, body) + ] ] + ; + tactic: + [ [ tac = tactic_expr -> tac ] ] + ; + selector: + [ [ n=natural; ":" -> Vernacexpr.SelectNth n + | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id + | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] + ; + tactic_mode: + [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] + ; + END + +open Stdarg +open Constrarg +open Vernacexpr +open Vernac_classifier +open Goptions + +let print_info_trace = ref None + +let _ = declare_int_option { + optsync = true; + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Pp.feedback Feedback.AddedAxiom + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ selector(s) ] -> [ s ] +END + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info +| [ "Info" natural(n) ] -> [ n ] +END + +let pr_ltac_use_default b = if b then str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +VERNAC tactic_mode EXTEND VernacSolve +| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ classify_as_proofstep ] -> [ + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + vernac_solve g n t def + ] +| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ VtProofStep true, VtLater ] -> [ + vernac_solve SelectAll n t def + ] +END diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 5c59465429..0649f2f72e 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,3 +1,6 @@ +Tacinterp +Evar_tactics +Tactic_option Extraargs G_obligations Coretactics @@ -12,3 +15,4 @@ G_rewrite Tauto Eqdecide G_eqdecide +G_ltac diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 36faba1137..6bf0e2aa73 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -2214,3 +2214,5 @@ let _ = optkey = ["Ltac";"Debug"]; optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } + +let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index fd7fab0c58..584cc0b730 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -22,7 +22,4 @@ Auto Tacintern Tactic_matching Tactic_debug -Tacinterp -Evar_tactics Term_dnet -Tactic_option diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 8ba5eb3f7d..64f9cd9caa 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -20,7 +20,6 @@ open Tacmach open Constrintern open Prettyp open Printer -open Tacinterp open Command open Goptions open Libnames @@ -34,6 +33,9 @@ open Misctypes open Locality open Sigma.Notations +(** TODO: make this function independent of Ltac *) +let (f_interp_redexp, interp_redexp_hook) = Hook.make () + let debug = false let prerr_endline = if debug then prerr_endline else fun _ -> () @@ -471,7 +473,7 @@ let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = | None -> None | Some r -> let (evc,env)= get_current_context () in - Some (snd (interp_redexp env evc r)) in + Some (snd (Hook.get f_interp_redexp env evc r)) in do_definition id (local,p,k) pl bl red_option c typ_opt hook) let vernac_start_proof locality p kind l lettop = @@ -1501,7 +1503,7 @@ let vernac_check_may_eval redexp glopt rc = Printer.pr_universe_ctx sigma uctx) | Some r -> Tacintern.dump_glob_red_expr r; - let (sigma',r_interp) = interp_redexp env sigma' r in + let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in let redfun env evm c = let (redfun, _) = reduction_of_red_expr env r_interp in let evm = Sigma.Unsafe.of_evar_map evm in @@ -1512,7 +1514,7 @@ let vernac_check_may_eval redexp glopt rc = let vernac_declare_reduction locality s r = let local = make_locality locality in - declare_red_expr local s (snd (interp_redexp (Global.env()) Evd.empty r)) + declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r)) (* The same but avoiding the current goal context if any *) let vernac_global_check c = diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 4a59b1299b..4e7fa4a087 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -61,3 +61,6 @@ val vernac_end_proof : val with_fail : bool -> (unit -> unit) -> unit val command_focus : unit Proof.focus_kind + +val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Tacexpr.raw_red_expr -> + Evd.evar_map * Redexpr.red_expr) Hook.t -- cgit v1.2.3 From 0af598b77a6242d796c66884477a046448ef1e21 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 01:31:43 +0100 Subject: Moving Tactic Notation to an EXTEND based command. --- intf/vernacexpr.mli | 2 -- parsing/g_vernac.ml4 | 13 ------------- printing/ppvernac.ml | 13 ------------- stm/texmacspp.ml | 3 --- stm/vernac_classifier.ml | 1 - tactics/g_ltac.ml4 | 34 ++++++++++++++++++++++++++++++++++ toplevel/vernacentries.ml | 5 +---- 7 files changed, 35 insertions(+), 36 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 36b855ec3b..123b3ec1b7 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -291,8 +291,6 @@ type vernac_expr = | VernacError of exn (* always fails *) (* Syntax *) - | VernacTacticNotation of - int * grammar_tactic_prod_item_expr list * raw_tactic_expr | VernacSyntaxExtension of obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index c89238d296..3b5d276dd2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1048,10 +1048,6 @@ GEXTEND Gram | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> VernacNotationAddFormat (n,s,fmt) - | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; - pil = LIST1 production_item; ":="; t = Tactic.tactic - -> VernacTacticNotation (n,pil,t) - | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> Metasyntax.check_infix_modifiers l; @@ -1077,9 +1073,6 @@ GEXTEND Gram obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] ; - tactic_level: - [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ] - ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] @@ -1111,10 +1104,4 @@ GEXTEND Gram | IDENT "closed"; IDENT "binder" -> ETBinder false ] ] ; - production_item: - [ [ s = ne_string -> TacTerm s - | nt = IDENT; - po = [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; - ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ] - ; END diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 887a14d2bf..88bb805a72 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -378,17 +378,6 @@ module Make | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") - let print_level n = - if not (Int.equal n 0) then - spc () ++ tag_keyword (str "(at level " ++ int n ++ str ")") - else - mt () - - let pr_grammar_tactic_rule n (_,pil,t) = - hov 2 (keyword "Tactic Notation" ++ print_level n ++ spc() ++ - hov 0 (prlist_with_sep sep pr_production_item pil ++ - spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) - let pr_univs pl = match pl with | None -> mt () @@ -644,8 +633,6 @@ module Make return (keyword "No-parsing-rule for VernacError") (* Syntax *) - | VernacTacticNotation (n,r,e) -> - return (pr_grammar_tactic_rule n ("",r,e)) | VernacOpenCloseScope (_,(opening,sc)) -> return ( keyword (if opening then "Open " else "Close ") ++ diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index a459cd65f8..e83313aa8e 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -503,9 +503,6 @@ let rec tmpp v loc = | VernacError _ -> xmlWithLoc loc "error" [] [] (* Syntax *) - | VernacTacticNotation _ as x -> - xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - | VernacSyntaxExtension (_, ((_, name), sml)) -> let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in xmlReservedNotation attrs name loc diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 97d6e1fb71..41b753fb8b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -195,7 +195,6 @@ let rec classify_vernac e = | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ | VernacSyntaxExtension _ | VernacSyntacticDefinition _ - | VernacTacticNotation _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) diff --git a/tactics/g_ltac.ml4 b/tactics/g_ltac.ml4 index d1992c57bb..3573ca7177 100644 --- a/tactics/g_ltac.ml4 +++ b/tactics/g_ltac.ml4 @@ -370,3 +370,37 @@ VERNAC tactic_mode EXTEND VernacSolve vernac_solve SelectAll n t def ] END + +let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level +| [ "(" "at" "level" natural(n) ")" ] -> [ n ] +END + +VERNAC ARGUMENT EXTEND ltac_production_sep +| [ "," string(sep) ] -> [ sep ] +END + +let pr_ltac_production_item = function +| TacTerm s -> quote (str s) +| TacNonTerm (_, arg, (id, sep)) -> + let sep = match sep with + | "" -> mt () + | sep -> str "," ++ spc () ++ quote (str sep) + in + str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item +| [ string(s) ] -> [ TacTerm s ] +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + [ TacNonTerm (loc, Names.Id.to_string nt, (p, Option.default "" sep)) ] +END + +VERNAC COMMAND EXTEND VernacTacticNotation CLASSIFIED AS SIDEFF +| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] -> + [ + let l = Locality.LocalityFixme.consume () in + let n = Option.default 0 n in + Metasyntax.add_tactic_notation (Locality.make_module_locality l, n, r, e) + ] +END diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 64f9cd9caa..bdf0ada2cd 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1822,8 +1822,6 @@ let interp ?proof ~loc locality poly c = | VernacError e -> raise e (* Syntax *) - | VernacTacticNotation (n,r,e) -> - Metasyntax.add_tactic_notation (make_module_locality locality,n,r,e) | VernacSyntaxExtension (local,sl) -> vernac_syntax_extension locality local sl | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr @@ -1978,8 +1976,7 @@ let check_vernac_supports_locality c l = match l, c with | None, _ -> () | Some _, ( - VernacTacticNotation _ - | VernacOpenCloseScope _ + VernacOpenCloseScope _ | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ | VernacAssumption _ | VernacStartTheoremProof _ -- cgit v1.2.3 From 01cd0dd64e4faa52b5094a99e2c31ecc4e7b767d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 02:09:54 +0100 Subject: Moving Print Ltac to an EXTEND based command. --- intf/vernacexpr.mli | 1 - parsing/g_vernac.ml4 | 1 - printing/ppvernac.ml | 2 -- tactics/g_ltac.ml4 | 5 +++++ toplevel/vernacentries.ml | 1 - 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 123b3ec1b7..1a67a37d7f 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -60,7 +60,6 @@ type printable = | PrintClasses | PrintTypeClasses | PrintInstances of reference or_by_notation - | PrintLtac of reference | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr | PrintCanonicalConversions diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 3b5d276dd2..0ad39d8047 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -890,7 +890,6 @@ GEXTEND Gram | IDENT "Classes" -> PrintClasses | IDENT "TypeClasses" -> PrintTypeClasses | IDENT "Instances"; qid = smart_global -> PrintInstances qid - | IDENT "Ltac"; qid = global -> PrintLtac qid | IDENT "Coercions" -> PrintCoercions | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> PrintCoercionPaths (s,t) diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 88bb805a72..edd32e8337 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -455,8 +455,6 @@ module Make keyword "Print TypeClasses" | PrintInstances qid -> keyword "Print Instances" ++ spc () ++ pr_smart_global qid - | PrintLtac qid -> - keyword "Print Ltac" ++ spc() ++ pr_ltac_ref qid | PrintCoercions -> keyword "Print Coercions" | PrintCoercionPaths (s,t) -> diff --git a/tactics/g_ltac.ml4 b/tactics/g_ltac.ml4 index 3573ca7177..5c0ae215d8 100644 --- a/tactics/g_ltac.ml4 +++ b/tactics/g_ltac.ml4 @@ -404,3 +404,8 @@ VERNAC COMMAND EXTEND VernacTacticNotation CLASSIFIED AS SIDEFF Metasyntax.add_tactic_notation (Locality.make_module_locality l, n, r, e) ] END + +VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY +| [ "Print" "Ltac" reference(r) ] -> + [ msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] +END diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index bdf0ada2cd..d0af1b951b 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1582,7 +1582,6 @@ let vernac_print = function | PrintClasses -> msg_notice (Prettyp.print_classes()) | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses()) | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c)) - | PrintLtac qid -> msg_notice (Tacintern.print_ltac (snd (qualid_of_reference qid))) | PrintCoercions -> msg_notice (Prettyp.print_coercions()) | PrintCoercionPaths (cls,clt) -> msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) -- cgit v1.2.3 From 9f5d9cd2622f3890e70dad01898868fe29df6048 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 01:23:02 +0100 Subject: Moving the tactic related code from Metasyntax to a new file. --- grammar/tacextend.ml4 | 2 +- tactics/g_ltac.ml4 | 2 +- tactics/hightactics.mllib | 1 + tactics/tacentries.ml | 186 ++++++++++++++++++++++++++++++++++++++++++++++ tactics/tacentries.mli | 19 +++++ toplevel/metasyntax.ml | 170 ------------------------------------------ toplevel/metasyntax.mli | 9 --- 7 files changed, 208 insertions(+), 181 deletions(-) create mode 100644 tactics/tacentries.ml create mode 100644 tactics/tacentries.mli diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index bbd3d8a62f..2ef30f299b 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -120,7 +120,7 @@ let declare_tactic loc s c cl = match cl with let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let pp = make_printing_rule cl in let gl = mlexpr_of_clause cl in - let obj = <:expr< fun () -> Metasyntax.add_ml_tactic_notation $se$ $gl$ >> in + let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in declare_str_items loc [ <:str_item< do { try do { diff --git a/tactics/g_ltac.ml4 b/tactics/g_ltac.ml4 index 5c0ae215d8..d75073877e 100644 --- a/tactics/g_ltac.ml4 +++ b/tactics/g_ltac.ml4 @@ -401,7 +401,7 @@ VERNAC COMMAND EXTEND VernacTacticNotation CLASSIFIED AS SIDEFF [ let l = Locality.LocalityFixme.consume () in let n = Option.default 0 n in - Metasyntax.add_tactic_notation (Locality.make_module_locality l, n, r, e) + Tacentries.add_tactic_notation (Locality.make_module_locality l, n, r, e) ] END diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 0649f2f72e..b18d148ec6 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,3 +1,4 @@ +Tacentries Tacinterp Evar_tactics Tactic_option diff --git a/tactics/tacentries.ml b/tactics/tacentries.ml new file mode 100644 index 0000000000..e40f5f46a0 --- /dev/null +++ b/tactics/tacentries.ml @@ -0,0 +1,186 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* GramTerminal s + | TacNonTerm (loc, nt, (_, sep)) -> + let EntryName (etyp, e) = interp_entry_name lev nt sep in + GramNonTerminal (loc, etyp, e) + +let make_terminal_status = function + | GramTerminal s -> Some s + | GramNonTerminal _ -> None + +let make_fresh_key = + let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in + fun () -> + let cur = incr id; !id in + let lbl = Id.of_string ("_" ^ string_of_int cur) in + let kn = Lib.make_kn lbl in + let (mp, dir, _) = KerName.repr kn in + (** We embed the full path of the kernel name in the label so that the + identifier should be unique. This ensures that including two modules + together won't confuse the corresponding labels. *) + let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" + (ModPath.to_string mp) (DirPath.to_string dir) cur) + in + KerName.make mp dir (Label.of_id lbl) + +type tactic_grammar_obj = { + tacobj_key : KerName.t; + tacobj_local : locality_flag; + tacobj_tacgram : tactic_grammar; + tacobj_tacpp : Pptactic.pp_tactic; + tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; +} + +let check_key key = + if Tacenv.check_alias key then + error "Conflicting tactic notations keys. This can happen when including \ + twice the same module." + +let cache_tactic_notation (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + Tacenv.register_alias key tobj.tacobj_body; + Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram; + Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp + +let open_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + if Int.equal i 1 && not tobj.tacobj_local then + Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram + +let load_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + (** Only add the printing and interpretation rules. *) + Tacenv.register_alias key tobj.tacobj_body; + Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp; + if Int.equal i 1 && not tobj.tacobj_local then + Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram + +let subst_tactic_notation (subst, tobj) = + let (ids, body) = tobj.tacobj_body in + { tobj with + tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; + tacobj_body = (ids, Tacsubst.subst_tactic subst body); + } + +let classify_tactic_notation tacobj = Substitute tacobj + +let inTacticGrammar : tactic_grammar_obj -> obj = + declare_object {(default_object "TacticGrammar") with + open_function = open_tactic_notation; + load_function = load_tactic_notation; + cache_function = cache_tactic_notation; + subst_function = subst_tactic_notation; + classify_function = classify_tactic_notation} + +let cons_production_parameter = function +| TacTerm _ -> None +| TacNonTerm (_, _, (id, _)) -> Some id + +let add_tactic_notation (local,n,prods,e) = + let ids = List.map_filter cons_production_parameter prods in + let prods = List.map (interp_prod_item n) prods in + let pprule = { + Pptactic.pptac_level = n; + pptac_prods = prods; + } in + let tac = Tacintern.glob_tactic_env ids (Global.env()) e in + let parule = { + tacgram_level = n; + tacgram_prods = prods; + } in + let tacobj = { + tacobj_key = make_fresh_key (); + tacobj_local = local; + tacobj_tacgram = parule; + tacobj_tacpp = pprule; + tacobj_body = (ids, tac); + } in + Lib.add_anonymous_leaf (inTacticGrammar tacobj) + +(**********************************************************************) +(* ML Tactic entries *) + +type ml_tactic_grammar_obj = { + mltacobj_name : Tacexpr.ml_tactic_name; + (** ML-side unique name *) + mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list; + (** Grammar rules generating the ML tactic. *) +} + +exception NonEmptyArgument + +(** ML tactic notations whose use can be restricted to an identifier are added + as true Ltac entries. *) +let extend_atomic_tactic name entries = + let open Tacexpr in + let map_prod prods = + let (hd, rem) = match prods with + | GramTerminal s :: rem -> (s, rem) + | _ -> assert false (** Not handled by the ML extension syntax *) + in + let empty_value = function + | GramTerminal s -> raise NonEmptyArgument + | GramNonTerminal (_, typ, e) -> + let Genarg.Rawwit wit = typ in + let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in + let default = epsilon_value inj e in + match default with + | None -> raise NonEmptyArgument + | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + in + try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None + in + let entries = List.map map_prod entries in + let add_atomic i args = match args with + | None -> () + | Some (id, args) -> + let args = List.map (fun a -> Tacexp a) args in + let entry = { mltac_name = name; mltac_index = i } in + let body = TacML (Loc.ghost, entry, args) in + Tacenv.register_ltac false false (Names.Id.of_string id) body + in + List.iteri add_atomic entries + +let cache_ml_tactic_notation (_, obj) = + extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod + +let open_ml_tactic_notation i obj = + if Int.equal i 1 then cache_ml_tactic_notation obj + +let inMLTacticGrammar : ml_tactic_grammar_obj -> obj = + declare_object { (default_object "MLTacticGrammar") with + open_function = open_ml_tactic_notation; + cache_function = cache_ml_tactic_notation; + classify_function = (fun o -> Substitute o); + subst_function = (fun (_, o) -> o); + } + +let add_ml_tactic_notation name prods = + let obj = { + mltacobj_name = name; + mltacobj_prod = prods; + } in + Lib.add_anonymous_leaf (inMLTacticGrammar obj); + extend_atomic_tactic name prods diff --git a/tactics/tacentries.mli b/tactics/tacentries.mli new file mode 100644 index 0000000000..635415b9d2 --- /dev/null +++ b/tactics/tacentries.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + unit + +val add_ml_tactic_notation : ml_tactic_name -> + Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index e5edc74222..6277a8146a 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -42,176 +42,6 @@ let inToken : string -> obj = let add_token_obj s = Lib.add_anonymous_leaf (inToken s) -(**********************************************************************) -(* Tactic Notation *) - -let interp_prod_item lev = function - | TacTerm s -> GramTerminal s - | TacNonTerm (loc, nt, (_, sep)) -> - let EntryName (etyp, e) = interp_entry_name lev nt sep in - GramNonTerminal (loc, etyp, e) - -let make_terminal_status = function - | GramTerminal s -> Some s - | GramNonTerminal _ -> None - -let make_fresh_key = - let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in - fun () -> - let cur = incr id; !id in - let lbl = Id.of_string ("_" ^ string_of_int cur) in - let kn = Lib.make_kn lbl in - let (mp, dir, _) = KerName.repr kn in - (** We embed the full path of the kernel name in the label so that the - identifier should be unique. This ensures that including two modules - together won't confuse the corresponding labels. *) - let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" - (ModPath.to_string mp) (DirPath.to_string dir) cur) - in - KerName.make mp dir (Label.of_id lbl) - -type tactic_grammar_obj = { - tacobj_key : KerName.t; - tacobj_local : locality_flag; - tacobj_tacgram : tactic_grammar; - tacobj_tacpp : Pptactic.pp_tactic; - tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; -} - -let check_key key = - if Tacenv.check_alias key then - error "Conflicting tactic notations keys. This can happen when including \ - twice the same module." - -let cache_tactic_notation (_, tobj) = - let key = tobj.tacobj_key in - let () = check_key key in - Tacenv.register_alias key tobj.tacobj_body; - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram; - Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp - -let open_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram - -let load_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - let () = check_key key in - (** Only add the printing and interpretation rules. *) - Tacenv.register_alias key tobj.tacobj_body; - Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp; - if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram - -let subst_tactic_notation (subst, tobj) = - let (ids, body) = tobj.tacobj_body in - { tobj with - tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = (ids, Tacsubst.subst_tactic subst body); - } - -let classify_tactic_notation tacobj = Substitute tacobj - -let inTacticGrammar : tactic_grammar_obj -> obj = - declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; - load_function = load_tactic_notation; - cache_function = cache_tactic_notation; - subst_function = subst_tactic_notation; - classify_function = classify_tactic_notation} - -let cons_production_parameter = function -| TacTerm _ -> None -| TacNonTerm (_, _, (id, _)) -> Some id - -let add_tactic_notation (local,n,prods,e) = - let ids = List.map_filter cons_production_parameter prods in - let prods = List.map (interp_prod_item n) prods in - let pprule = { - Pptactic.pptac_level = n; - pptac_prods = prods; - } in - let tac = Tacintern.glob_tactic_env ids (Global.env()) e in - let parule = { - tacgram_level = n; - tacgram_prods = prods; - } in - let tacobj = { - tacobj_key = make_fresh_key (); - tacobj_local = local; - tacobj_tacgram = parule; - tacobj_tacpp = pprule; - tacobj_body = (ids, tac); - } in - Lib.add_anonymous_leaf (inTacticGrammar tacobj) - -(**********************************************************************) -(* ML Tactic entries *) - -type ml_tactic_grammar_obj = { - mltacobj_name : Tacexpr.ml_tactic_name; - (** ML-side unique name *) - mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list; - (** Grammar rules generating the ML tactic. *) -} - -exception NonEmptyArgument - -(** ML tactic notations whose use can be restricted to an identifier are added - as true Ltac entries. *) -let extend_atomic_tactic name entries = - let open Tacexpr in - let map_prod prods = - let (hd, rem) = match prods with - | GramTerminal s :: rem -> (s, rem) - | _ -> assert false (** Not handled by the ML extension syntax *) - in - let empty_value = function - | GramTerminal s -> raise NonEmptyArgument - | GramNonTerminal (_, typ, e) -> - let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in - let default = epsilon_value inj e in - match default with - | None -> raise NonEmptyArgument - | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def - in - try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None - in - let entries = List.map map_prod entries in - let add_atomic i args = match args with - | None -> () - | Some (id, args) -> - let args = List.map (fun a -> Tacexp a) args in - let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.ghost, entry, args) in - Tacenv.register_ltac false false (Names.Id.of_string id) body - in - List.iteri add_atomic entries - -let cache_ml_tactic_notation (_, obj) = - extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod - -let open_ml_tactic_notation i obj = - if Int.equal i 1 then cache_ml_tactic_notation obj - -let inMLTacticGrammar : ml_tactic_grammar_obj -> obj = - declare_object { (default_object "MLTacticGrammar") with - open_function = open_ml_tactic_notation; - cache_function = cache_ml_tactic_notation; - classify_function = (fun o -> Substitute o); - subst_function = (fun (_, o) -> o); - } - -let add_ml_tactic_notation name prods = - let obj = { - mltacobj_name = name; - mltacobj_prod = prods; - } in - Lib.add_anonymous_leaf (inMLTacticGrammar obj); - extend_atomic_tactic name prods - (**********************************************************************) (* Printing grammar entries *) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 5d01405b27..085cc87c8b 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -15,15 +15,6 @@ open Notation_term val add_token_obj : string -> unit -(** Adding a tactic notation in the environment *) - -val add_tactic_notation : - locality_flag * int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> - unit - -val add_ml_tactic_notation : ml_tactic_name -> - Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit - (** Adding a (constr) notation in the environment*) val add_infix : locality_flag -> (lstring * syntax_modifier list) -> -- cgit v1.2.3 From 4f52bd681ad9bbcbbd68406a58b47d8e962336ed Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 02:23:21 +0100 Subject: Moving the Ltac definition command to an EXTEND based command. --- intf/vernacexpr.mli | 1 - parsing/g_vernac.ml4 | 6 +--- parsing/pcoq.ml | 3 -- parsing/pcoq.mli | 1 - printing/ppvernac.ml | 23 -------------- stm/texmacspp.ml | 1 - stm/vernac_classifier.ml | 7 ----- tactics/g_ltac.ml4 | 18 +++++++++++ tactics/tacentries.ml | 77 ++++++++++++++++++++++++++++++++++++++++++++++ tactics/tacentries.mli | 2 ++ toplevel/vernacentries.ml | 78 ----------------------------------------------- 11 files changed, 98 insertions(+), 119 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 1a67a37d7f..bd5890e296 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -379,7 +379,6 @@ type vernac_expr = | VernacBackTo of int (* Commands *) - | VernacDeclareTacticDefinition of tacdef_body list | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list | VernacHints of obsolete_locality * string list * hints_expr diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 0ad39d8047..8d7b6a2b48 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -751,11 +751,7 @@ GEXTEND Gram GLOBAL: command query_command class_rawexpr; command: - [ [ IDENT "Ltac"; - l = LIST1 tacdef_body SEP "with" -> - VernacDeclareTacticDefinition l - - | IDENT "Comments"; l = LIST0 comment -> VernacComments l + [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 9c2f09db84..c7cb62d592 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -364,9 +364,6 @@ module Tactic = (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic - (* For Ltac definition *) - let tacdef_body = Gram.entry_create "tactic:tacdef_body" - end module Vernac_ = diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 7410d4e44c..35973a4d72 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -229,7 +229,6 @@ module Tactic : val binder_tactic : raw_tactic_expr Gram.entry val tactic : raw_tactic_expr Gram.entry val tactic_eoi : raw_tactic_expr Gram.entry - val tacdef_body : Vernacexpr.tacdef_body Gram.entry end module Vernac_ : diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index edd32e8337..c1f5e122bd 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -995,29 +995,6 @@ module Make return (keyword "Cd" ++ pr_opt qs s) (* Commands *) - | VernacDeclareTacticDefinition l -> - let pr_tac_body tacdef_body = - let id, redef, body = - match tacdef_body with - | TacticDefinition ((_,id), body) -> pr_id id, false, body - | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body - in - let idl, body = - match body with - | Tacexpr.TacFun (idl,b) -> idl,b - | _ -> [], body in - id ++ - prlist (function None -> str " _" - | Some id -> spc () ++ pr_id id) idl - ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ - pr_raw_tactic body - in - return ( - hov 1 - (keyword "Ltac" ++ spc () ++ - prlist_with_sep (fun () -> - fnl() ++ keyword "with" ++ spc ()) pr_tac_body l) - ) | VernacCreateHintDb (dbname,b) -> return ( hov 1 (keyword "Create HintDb" ++ spc () ++ diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index e83313aa8e..2d2ea1f8b0 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -694,7 +694,6 @@ let rec tmpp v loc = | VernacBackTo _ -> PCData "VernacBackTo" (* Commands *) - | VernacDeclareTacticDefinition _ as x -> xmlTODO loc x | VernacCreateHintDb _ as x -> xmlTODO loc x | VernacRemoveHints _ as x -> xmlTODO loc x | VernacHints _ as x -> xmlTODO loc x diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 41b753fb8b..ecaf0fb7c5 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -173,13 +173,6 @@ let rec classify_vernac e = | VernacRegister _ | VernacNameSectionHypSet _ | VernacComments _ -> VtSideff [], VtLater - | VernacDeclareTacticDefinition l -> - let open Libnames in - let open Vernacexpr in - VtSideff (List.map (function - | TacticDefinition ((_,r),_) -> r - | TacticRedefinition (Ident (_,r),_) -> r - | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater (* Who knows *) | VernacLoad _ -> VtSideff [], VtNow (* (Local) Notations have to disappear *) diff --git a/tactics/g_ltac.ml4 b/tactics/g_ltac.ml4 index d75073877e..f46a670080 100644 --- a/tactics/g_ltac.ml4 +++ b/tactics/g_ltac.ml4 @@ -48,6 +48,7 @@ let new_entry name = e let selector = new_entry "vernac:selector" +let tacdef_body = new_entry "tactic:tacdef_body" (* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for proof editing and changes nothing else). Then sets it as the default proof mode. *) @@ -311,6 +312,7 @@ open Constrarg open Vernacexpr open Vernac_classifier open Goptions +open Libnames let print_info_trace = ref None @@ -409,3 +411,19 @@ VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> [ msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] END + +VERNAC ARGUMENT EXTEND ltac_tacdef_body +| [ tacdef_body(t) ] -> [ t ] +END + +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ + VtSideff (List.map (function + | TacticDefinition ((_,r),_) -> r + | TacticRedefinition (Ident (_,r),_) -> r + | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater + ] -> [ + let lc = Locality.LocalityFixme.consume () in + Tacentries.register_ltac (Locality.make_module_locality lc) l + ] +END diff --git a/tactics/tacentries.ml b/tactics/tacentries.ml index e40f5f46a0..711cd8d9d0 100644 --- a/tactics/tacentries.ml +++ b/tactics/tacentries.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Pp open Errors open Util open Names @@ -14,6 +15,8 @@ open Pcoq open Egramml open Egramcoq open Vernacexpr +open Libnames +open Nameops (**********************************************************************) (* Tactic Notation *) @@ -184,3 +187,77 @@ let add_ml_tactic_notation name prods = } in Lib.add_anonymous_leaf (inMLTacticGrammar obj); extend_atomic_tactic name prods + +(** Command *) + + +type tacdef_kind = + | NewTac of Id.t + | UpdateTac of Nametab.ltac_constant + +let is_defined_tac kn = + try ignore (Tacenv.interp_ltac kn); true with Not_found -> false + +let register_ltac local tacl = + let map tactic_body = + match tactic_body with + | TacticDefinition ((loc,id), body) -> + let kn = Lib.make_kn id in + let id_pp = pr_id id in + let () = if is_defined_tac kn then + Errors.user_err_loc (loc, "", + str "There is already an Ltac named " ++ id_pp ++ str".") + in + let is_primitive = + try + match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with + | Tacexpr.TacArg _ -> false + | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) + with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) + in + let () = if is_primitive then + msg_warning (str "The Ltac name " ++ id_pp ++ + str " may be unusable because of a conflict with a notation.") + in + NewTac id, body + | TacticRedefinition (ident, body) -> + let loc = loc_of_reference ident in + let kn = + try Nametab.locate_tactic (snd (qualid_of_reference ident)) + with Not_found -> + Errors.user_err_loc (loc, "", + str "There is no Ltac named " ++ pr_reference ident ++ str ".") + in + UpdateTac kn, body + in + let rfun = List.map map tacl in + let recvars = + let fold accu (op, _) = match op with + | UpdateTac _ -> accu + | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu + in + List.fold_left fold [] rfun + in + let ist = Tacintern.make_empty_glob_sign () in + let map (name, body) = + let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in + (name, body) + in + let defs () = + (** Register locally the tactic to handle recursivity. This function affects + the whole environment, so that we transactify it afterwards. *) + let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in + let () = List.iter iter_rec recvars in + List.map map rfun + in + let defs = Future.transactify defs () in + let iter (def, tac) = match def with + | NewTac id -> + Tacenv.register_ltac false local id tac; + Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined") + | UpdateTac kn -> + Tacenv.redefine_ltac local kn tac; + let name = Nametab.shortest_qualid_of_tactic kn in + Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined") + in + List.iter iter defs diff --git a/tactics/tacentries.mli b/tactics/tacentries.mli index 635415b9d2..3cf0bc5cc9 100644 --- a/tactics/tacentries.mli +++ b/tactics/tacentries.mli @@ -17,3 +17,5 @@ val add_tactic_notation : val add_ml_tactic_notation : ml_tactic_name -> Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit + +val register_ltac : bool -> Vernacexpr.tacdef_body list -> unit diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index d0af1b951b..bbfa8818b0 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -914,81 +914,6 @@ let vernac_restore_state file = (************) (* Commands *) -type tacdef_kind = - | NewTac of Id.t - | UpdateTac of Nametab.ltac_constant - -let is_defined_tac kn = - try ignore (Tacenv.interp_ltac kn); true with Not_found -> false - -let register_ltac local tacl = - let map tactic_body = - match tactic_body with - | TacticDefinition ((loc,id), body) -> - let kn = Lib.make_kn id in - let id_pp = pr_id id in - let () = if is_defined_tac kn then - Errors.user_err_loc (loc, "", - str "There is already an Ltac named " ++ id_pp ++ str".") - in - let is_primitive = - try - match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with - | Tacexpr.TacArg _ -> false - | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) - with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) - in - let () = if is_primitive then - msg_warning (str "The Ltac name " ++ id_pp ++ - str " may be unusable because of a conflict with a notation.") - in - NewTac id, body - | TacticRedefinition (ident, body) -> - let loc = loc_of_reference ident in - let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) - with Not_found -> - Errors.user_err_loc (loc, "", - str "There is no Ltac named " ++ pr_reference ident ++ str ".") - in - UpdateTac kn, body - in - let rfun = List.map map tacl in - let recvars = - let fold accu (op, _) = match op with - | UpdateTac _ -> accu - | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu - in - List.fold_left fold [] rfun - in - let ist = Tacintern.make_empty_glob_sign () in - let map (name, body) = - let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in - (name, body) - in - let defs () = - (** Register locally the tactic to handle recursivity. This function affects - the whole environment, so that we transactify it afterwards. *) - let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in - let () = List.iter iter_rec recvars in - List.map map rfun - in - let defs = Future.transactify defs () in - let iter (def, tac) = match def with - | NewTac id -> - Tacenv.register_ltac false local id tac; - Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined") - | UpdateTac kn -> - Tacenv.redefine_ltac local kn tac; - let name = Nametab.shortest_qualid_of_tactic kn in - Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined") - in - List.iter iter defs - -let vernac_declare_tactic_definition locality def = - let local = make_module_locality locality in - register_ltac local def - let vernac_create_hintdb locality id b = let local = make_module_locality locality in Hints.create_hint_db local id full_transparent_state b @@ -1898,8 +1823,6 @@ let interp ?proof ~loc locality poly c = | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm") (* Commands *) - | VernacDeclareTacticDefinition def -> - vernac_declare_tactic_definition locality def | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids | VernacHints (local,dbnames,hints) -> @@ -1982,7 +1905,6 @@ let check_vernac_supports_locality c l = | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ | VernacDeclareMLModule _ - | VernacDeclareTacticDefinition _ | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _ | VernacSyntacticDefinition _ | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _ -- cgit v1.2.3 From 5f703bbb8b4f439af9d76b1f6ef24162b67049c2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 02:43:45 +0100 Subject: Moving Tacintern to Hightactics. --- tactics/hightactics.mllib | 1 + tactics/tactics.mllib | 1 - toplevel/vernacentries.ml | 1 - 3 files changed, 1 insertion(+), 2 deletions(-) diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index b18d148ec6..468b938b6a 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,3 +1,4 @@ +Tacintern Tacentries Tacinterp Evar_tactics diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 584cc0b730..b495a885f8 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -19,7 +19,6 @@ Taccoerce Tacenv Hints Auto -Tacintern Tactic_matching Tactic_debug Term_dnet diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index bbfa8818b0..bdd52d5be0 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1427,7 +1427,6 @@ let vernac_check_may_eval redexp glopt rc = pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ Printer.pr_universe_ctx sigma uctx) | Some r -> - Tacintern.dump_glob_red_expr r; let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in let redfun env evm c = let (redfun, _) = reduction_of_red_expr env r_interp in -- cgit v1.2.3 From 09c2011fbdbb2ac1ce33e5abe52d93b907b21a3c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 16:01:52 +0100 Subject: Fixing bug #4630: Some tactics are 20x slower in 8.5 than 8.4. The interpretation of arguments of tactic notations were normalizing the goal beforehand, which incurred an important time penalty. We now do this argumentwise which allows to save time in frequent cases, notably tactic arguments. --- tactics/tacinterp.ml | 56 ++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 46 insertions(+), 10 deletions(-) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 54adbd937f..5ecc46d670 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -1219,34 +1219,53 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return arg) end | _ as tag -> (** Special treatment. TODO: use generic handler *) - Ftactic.nf_enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let env = Proofview.Goal.env gl in match tag with | IntOrVarArgType -> + Ftactic.enter begin fun _ -> Ftactic.return (mk_int_or_var_value ist (out_gen (glbwit wit_int_or_var) x)) + end | IdentArgType -> + Ftactic.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env (Proofview.Goal.assume gl) in Ftactic.return (value_of_ident (interp_ident ist env sigma (out_gen (glbwit wit_ident) x))) + end | VarArgType -> + Ftactic.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env (Proofview.Goal.assume gl) in Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x)) - | GenArgType -> f (out_gen (glbwit wit_genarg) x) + end + | GenArgType -> + Ftactic.enter begin fun _ -> + f (out_gen (glbwit wit_genarg) x) + end | ConstrArgType -> + Ftactic.nf_enter begin fun gl -> let (sigma,v) = Tacmach.New.of_old (fun gl -> mk_constr_value ist gl (out_gen (glbwit wit_constr) x)) gl in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) + end | OpenConstrArgType -> + Ftactic.nf_enter begin fun gl -> let (sigma,v) = Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (out_gen (glbwit wit_open_constr) x))) gl in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) + end | ConstrMayEvalArgType -> + Ftactic.nf_enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma (out_gen (glbwit wit_constr_may_eval) x) in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) + end | ListArgType ConstrArgType -> + Ftactic.nf_enter begin fun gl -> let wit = glbwit (wit_list wit_constr) in let (sigma,l_interp) = Tacmach.New.of_old begin fun gl -> Evd.MonadR.List.map_right @@ -1255,22 +1274,34 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with (project gl) end gl in Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (in_gen (topwit (wit_list wit_genarg)) l_interp)) + end | ListArgType VarArgType -> + Ftactic.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env (Proofview.Goal.assume gl) in let wit = glbwit (wit_list wit_var) in Ftactic.return ( let ans = List.map (mk_hyp_value ist env sigma) (out_gen wit x) in in_gen (topwit (wit_list wit_genarg)) ans ) + end | ListArgType IntOrVarArgType -> + Ftactic.enter begin fun _ -> let wit = glbwit (wit_list wit_int_or_var) in let ans = List.map (mk_int_or_var_value ist) (out_gen wit x) in Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) + end | ListArgType IdentArgType -> + Ftactic.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env (Proofview.Goal.assume gl) in let wit = glbwit (wit_list wit_ident) in let mk_ident x = value_of_ident (interp_ident ist env sigma x) in let ans = List.map mk_ident (out_gen wit x) in Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) + end | ListArgType t -> + Ftactic.enter begin fun gl -> let open Ftactic in let list_unpacker wit l = let map x = @@ -1281,17 +1312,22 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.return (in_gen (topwit (wit_list wit)) l) in list_unpack { list_unpacker } x + end | ExtraArgType _ -> (** Special treatment of tactics *) - if has_type x (glbwit wit_tactic) then + if has_type x (glbwit wit_tactic) then + Ftactic.enter begin fun _ -> let tac = out_gen (glbwit wit_tactic) x in val_interp ist tac - else - let goal = Proofview.Goal.goal gl in - let (newsigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS newsigma) <*> return v) + end + else + Ftactic.nf_enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let goal = Proofview.Goal.goal gl in + let (newsigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} x in + Ftactic.(lift (Proofview.Unsafe.tclEVARS newsigma) <*> return v) + end | _ -> assert false - end in let (>>=) = Ftactic.bind in let interp_vars = -- cgit v1.2.3 From 1890a2cdc0dcda7335d7f81fc9ce77c0debc4324 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 16:34:56 +0100 Subject: Fixing the classification of Tactic Notation. --- tactics/g_ltac.ml4 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tactics/g_ltac.ml4 b/tactics/g_ltac.ml4 index f46a670080..b55ac9ad06 100644 --- a/tactics/g_ltac.ml4 +++ b/tactics/g_ltac.ml4 @@ -398,8 +398,9 @@ VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item [ TacNonTerm (loc, Names.Id.to_string nt, (p, Option.default "" sep)) ] END -VERNAC COMMAND EXTEND VernacTacticNotation CLASSIFIED AS SIDEFF -| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] -> +VERNAC COMMAND EXTEND VernacTacticNotation +| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => + [ VtUnknown, VtNow ] -> [ let l = Locality.LocalityFixme.consume () in let n = Option.default 0 n in -- cgit v1.2.3 From 48e4831fa56e3b0acd92aabdb78847696b84daf7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 17:33:26 +0100 Subject: Extruding the code for the Existential command from Proofview. --- proofs/evar_refiner.ml | 11 ----------- proofs/evar_refiner.mli | 5 ----- proofs/proof.ml | 22 ++++++++++++++++++++-- proofs/proofview.ml | 14 -------------- proofs/proofview.mli | 3 --- 5 files changed, 20 insertions(+), 35 deletions(-) diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 059ae54c9d..3192a6a29a 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -59,14 +59,3 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = str (string_of_existential evk)) in define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma) - -(* vernac command Existential *) - -(* Main component of vernac command Existential *) -let instantiate_pf_com evk com sigma = - let evi = Evd.find sigma evk in - let env = Evd.evar_filtered_env evi in - let rawc = Constrintern.intern_constr env com in - let ltac_vars = Pretyping.empty_lvar in - let sigma' = w_refine (evk, evi) (ltac_vars, rawc) sigma in - sigma' diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 35a3e5d828..e3778e94c9 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -13,8 +13,3 @@ open Pretyping val w_refine : evar * evar_info -> glob_constr_ltac_closure -> evar_map -> evar_map - -val instantiate_pf_com : - Evd.evar -> Constrexpr.constr_expr -> Evd.evar_map -> Evd.evar_map - -(** the instantiate tactic was moved to [tactics/evar_tactics.ml] *) diff --git a/proofs/proof.ml b/proofs/proof.ml index 0489305aa7..b604fde4eb 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -387,9 +387,27 @@ module V82 = struct { p with proofview = Proofview.V82.grab p.proofview } + (* Main component of vernac command Existential *) let instantiate_evar n com pr = - let sp = pr.proofview in - let proofview = Proofview.V82.instantiate_evar n com sp in + let tac = + Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> + let (evk, evi) = + let evl = Evarutil.non_instantiated sigma in + let evl = Evar.Map.bindings evl in + if (n <= 0) then + Errors.error "incorrect existential variable index" + else if CList.length evl < n then + Errors.error "not so many uninstantiated existential variables" + else + CList.nth evl (n-1) + in + let env = Evd.evar_filtered_env evi in + let rawc = Constrintern.intern_constr env com in + let ltac_vars = Pretyping.empty_lvar in + let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in + Proofview.Unsafe.tclEVARS sigma + end in + let ((), proofview, _, _) = Proofview.apply (Global.env ()) tac pr.proofview in let shelf = List.filter begin fun g -> Evd.is_undefined (Proofview.return proofview) g diff --git a/proofs/proofview.ml b/proofs/proofview.ml index a382e9873f..b68fa042e3 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1272,20 +1272,6 @@ module V82 = struct in CList.flatten (CList.map evars_of_initial initial) - let instantiate_evar n com pv = - let (evk,_) = - let evl = Evarutil.non_instantiated pv.solution in - let evl = Evar.Map.bindings evl in - if (n <= 0) then - Errors.error "incorrect existential variable index" - else if CList.length evl < n then - Errors.error "not so many uninstantiated existential variables" - else - CList.nth evl (n-1) - in - { pv with - solution = Evar_refiner.instantiate_pf_com evk com pv.solution } - let of_tactic t gls = try let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 7f95a053a8..61014468b5 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -577,9 +577,6 @@ module V82 : sig (* returns the existential variable used to start the proof *) val top_evars : entry -> Evd.evar list - - (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> proofview -> proofview (* Caution: this function loses quite a bit of information. It should be avoided as much as possible. It should work as -- cgit v1.2.3 From 32bf41967bbcd2bf21dea8a6b4f5f500eb15aacc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 18:01:07 +0100 Subject: Making Proofview independent from Goal. --- proofs/proofview.ml | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index b68fa042e3..2a09d52f7d 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -924,8 +924,20 @@ let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) (** {6 Goal-dependent tactics} *) -(* To avoid shadowing by the local [Goal] module *) -module GoalV82 = Goal.V82 +let goal_env evars gl = + let evi = Evd.find evars gl in + Evd.evar_filtered_env evi + +let goal_nf_evar sigma gl = + let evi = Evd.find sigma gl in + let evi = Evarutil.nf_evar_info sigma evi in + let sigma = Evd.add sigma gl evi in + (gl, sigma) + +let goal_extra evars gl = + let evi = Evd.find evars gl in + evi.Evd.evar_extra + let catchable_exception = function | Logic_monad.Exception _ -> false @@ -950,7 +962,7 @@ module Goal = struct let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma let hyps { env=env } = Environ.named_context env let concl { concl=concl } = concl - let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self + let extra { sigma=sigma; self=self } = goal_extra sigma self let raw_concl { concl=concl } = concl @@ -1225,7 +1237,7 @@ module V82 = struct in (* Old style tactics expect the goals normalized with respect to evars. *) let (initgoals,initevd) = - Evd.Monad.List.map (fun g s -> GoalV82.nf_evar s g) ps.comb ps.solution + Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution in let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in let sgs = CList.flatten goalss in @@ -1241,7 +1253,7 @@ module V82 = struct solution. *) let nf_evar_goals = Pv.modify begin fun ps -> - let map g s = GoalV82.nf_evar s g in + let map g s = goal_nf_evar s g in let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in { ps with solution = evd; comb = goals; } end @@ -1275,7 +1287,7 @@ module V82 = struct let of_tactic t gls = try let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in - let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in + let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = final.comb } with Logic_monad.TacticFailure e as src -> let (_, info) = Errors.push src in -- cgit v1.2.3 From b2a2cb77f38549a25417d199e90d745715f3e465 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 18:08:42 +0100 Subject: Making Proofview independent of Logic. --- engine/proofview_monad.ml | 4 ++-- engine/proofview_monad.mli | 4 ++-- proofs/proofview.ml | 6 +++--- proofs/proofview.mli | 4 ++-- tactics/tactics.ml | 6 +++++- 5 files changed, 14 insertions(+), 10 deletions(-) diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 2b9db60b4f..6f52b3ee90 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -154,8 +154,8 @@ end focused goals. *) type proofview = { solution : Evd.evar_map; - comb : Goal.goal list; - shelf : Goal.goal list; + comb : Evar.t list; + shelf : Evar.t list; } (** {6 Instantiation of the logic monad} *) diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 7a6ea10fe3..0aff0a7207 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -70,8 +70,8 @@ end focused goals. *) type proofview = { solution : Evd.evar_map; - comb : Goal.goal list; - shelf : Goal.goal list; + comb : Evar.t list; + shelf : Evar.t list; } (** {6 Instantiation of the logic monad} *) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 2a09d52f7d..f42a60d9db 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -625,18 +625,18 @@ let shelve_unifiable = InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> Shelf.modify (fun gls -> gls @ u) -(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some +(** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) let guard_no_unifiable = let open Proof in Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in match u with - | [] -> tclUNIT () + | [] -> tclUNIT None | gls -> let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in let l = CList.map (fun id -> Names.Name id) l in - tclZERO (Logic.RefinerError (Logic.UnresolvedBindings l)) + tclUNIT (Some l) (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 61014468b5..20f67f2584 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -295,9 +295,9 @@ val shelve : unit tactic considered). *) val shelve_unifiable : unit tactic -(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some +(** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -val guard_no_unifiable : unit tactic +val guard_no_unifiable : Names.Name.t list option tactic (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f725a06549..ffe10d81c6 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4095,6 +4095,10 @@ let check_enough_applied env sigma elim = (* Last argument is supposed to be the induction argument *) check_expected_type env sigma elimc elimt +let guard_no_unifiable = Proofview.guard_no_unifiable >>= function +| None -> Proofview.tclUNIT () +| Some l -> Proofview.tclZERO (RefinerError (UnresolvedBindings l)) + let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -4129,7 +4133,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in Sigma (ans, sigma, p +> q) end }; - Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable); + if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0])) else Proofview.tclUNIT (); -- cgit v1.2.3 From 93a77f3cb8ee36072f93b4c0ace6f0f9c19f51a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 18:41:37 +0100 Subject: Moving Refine to its proper module. --- dev/printers.mllib | 1 + printing/printer.ml | 2 +- proofs/proof.ml | 28 ++++++----- proofs/proofs.mllib | 1 + proofs/proofview.ml | 117 +-------------------------------------------- proofs/proofview.mli | 41 +++------------- proofs/refine.ml | 122 +++++++++++++++++++++++++++++++++++++++++++++++ proofs/refine.mli | 37 ++++++++++++++ tactics/extratactics.ml4 | 2 +- tactics/inv.ml | 2 +- tactics/rewrite.ml | 6 +-- tactics/tactics.ml | 32 ++++++------- tactics/tactics.mli | 2 +- toplevel/classes.ml | 2 +- 14 files changed, 209 insertions(+), 186 deletions(-) create mode 100644 proofs/refine.ml create mode 100644 proofs/refine.mli diff --git a/dev/printers.mllib b/dev/printers.mllib index 7710033dba..c46f6b72a4 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -184,6 +184,7 @@ Proof_errors Logic_monad Proofview_monad Proofview +Refine Proof Proof_global Pfedit diff --git a/printing/printer.ml b/printing/printer.ml index b89005887f..2e67fa5ff1 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -50,7 +50,7 @@ let pr_lconstr_core goal_concl_style env sigma t = let pr_lconstr_env env = pr_lconstr_core false env let pr_constr_env env = pr_constr_core false env -let _ = Hook.set Proofview.Refine.pr_constr pr_constr_env +let _ = Hook.set Refine.pr_constr pr_constr_env let pr_lconstr_goal_style_env env = pr_lconstr_core true env let pr_constr_goal_style_env env = pr_constr_core true env diff --git a/proofs/proof.ml b/proofs/proof.ml index b604fde4eb..86af420dc4 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -334,22 +334,24 @@ let compact p = (*** Tactics ***) let run_tactic env tac pr = + let open Proofview.Notations in let sp = pr.proofview in - let (_,tacticced_proofview,(status,to_shelve,give_up),info_trace) = - Proofview.apply env tac sp + let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in + let tac = + tac >>= fun () -> + Proofview.tclEVARMAP >>= fun sigma -> + (* Already solved goals are not to be counted as shelved. Nor are + they to be marked as unresolvable. *) + let retrieved = undef sigma (List.rev (Evd.future_goals sigma)) in + let sigma = List.fold_left Proofview.Unsafe.mark_as_goal sigma retrieved in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT retrieved in - let sigma = Proofview.return tacticced_proofview in - (* Already solved goals are not to be counted as shelved. Nor are - they to be marked as unresolvable. *) - let undef l = List.filter (fun g -> Evd.is_undefined sigma g) l in - let retrieved = undef (List.rev (Evd.future_goals sigma)) in - let shelf = (undef pr.shelf)@retrieved@(undef to_shelve) in - let proofview = - List.fold_left - Proofview.Unsafe.mark_as_goal - tacticced_proofview - retrieved + let (retrieved,proofview,(status,to_shelve,give_up),info_trace) = + Proofview.apply env tac sp in + let sigma = Proofview.return proofview in + let shelf = (undef sigma pr.shelf)@retrieved@(undef sigma to_shelve) in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in { pr with proofview ; shelf ; given_up },(status,info_trace) diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 08556d62ec..236d479320 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -5,6 +5,7 @@ Proof_using Proof_errors Logic Proofview +Refine Proof Proof_global Redexpr diff --git a/proofs/proofview.ml b/proofs/proofview.ml index f42a60d9db..20be02e76d 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -901,7 +901,7 @@ module Unsafe = struct let reset_future_goals p = { p with solution = Evd.reset_future_goals p.solution } - let mark_as_goal_evm evd content = + let mark_as_goal evd content = let info = Evd.find evd content in let info = { info with Evd.evar_source = match info.Evd.evar_source with @@ -911,8 +911,7 @@ module Unsafe = struct let info = Typeclasses.mark_unresolvable info in Evd.add evd content info - let mark_as_goal p gl = - { p with solution = mark_as_goal_evm p.solution gl } + let advance = advance end @@ -1075,118 +1074,6 @@ end -(** {6 The refine tactic} *) - -module Refine = -struct - - let extract_prefix env info = - let ctx1 = List.rev (Environ.named_context env) in - let ctx2 = List.rev (Evd.evar_context info) in - let rec share l1 l2 accu = match l1, l2 with - | d1 :: l1, d2 :: l2 -> - if d1 == d2 then share l1 l2 (d1 :: accu) - else (accu, d2 :: l2) - | _ -> (accu, l2) - in - share ctx1 ctx2 [] - - let typecheck_evar ev env sigma = - let info = Evd.find sigma ev in - (** Typecheck the hypotheses. *) - let type_hyp (sigma, env) decl = - let t = get_type decl in - let evdref = ref sigma in - let _ = Typing.e_sort_of env evdref t in - let () = match decl with - | LocalAssum _ -> () - | LocalDef (_,body,_) -> Typing.e_check env evdref body t - in - (!evdref, Environ.push_named decl env) - in - let (common, changed) = extract_prefix env info in - let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in - let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in - (** Typecheck the conclusion *) - let evdref = ref sigma in - let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in - !evdref - - let typecheck_proof c concl env sigma = - let evdref = ref sigma in - let () = Typing.e_check env evdref c concl in - !evdref - - let (pr_constrv,pr_constr) = - Hook.make ~default:(fun _env _sigma _c -> Pp.str"") () - - let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl -> - let sigma = Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in - let env = Goal.env gl in - let concl = Goal.concl gl in - (** Save the [future_goals] state to restore them after the - refinement. *) - let prev_future_goals = Evd.future_goals sigma in - let prev_principal_goal = Evd.principal_future_goal sigma in - (** Create the refinement term *) - let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in - let evs = Evd.future_goals sigma in - let evkmain = Evd.principal_future_goal sigma in - (** Check that the introduced evars are well-typed *) - let fold accu ev = typecheck_evar ev env accu in - let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in - (** Check that the refined term is typesafe *) - let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in - (** Check that the goal itself does not appear in the refined term *) - let _ = - if not (Evarutil.occur_evar_upto sigma gl.Goal.self c) then () - else Pretype_errors.error_occur_check env sigma gl.Goal.self c - in - (** Proceed to the refinement *) - let sigma = match evkmain with - | None -> Evd.define gl.Goal.self c sigma - | Some evk -> - let id = Evd.evar_ident gl.Goal.self sigma in - let sigma = Evd.define gl.Goal.self c sigma in - match id with - | None -> sigma - | Some id -> Evd.rename evk id sigma - in - (** Restore the [future goals] state. *) - let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in - (** Select the goals *) - let comb = undefined sigma (CList.rev evs) in - let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> - Pv.modify (fun ps -> { ps with solution = sigma; comb; }) - end } - - (** Useful definitions *) - - let with_type env evd c t = - let my_type = Retyping.get_type_of env evd c in - let j = Environ.make_judge c my_type in - let (evd,j') = - Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t - in - evd , j'.Environ.uj_val - - let refine_casted ?unsafe f = Goal.enter { Goal.enter = begin fun gl -> - let concl = Goal.concl gl in - let env = Goal.env gl in - let f = { run = fun h -> - let Sigma (c, h, p) = f.run h in - let sigma, c = with_type env (Sigma.to_evar_map h) c concl in - Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) - } in - refine ?unsafe f - end } -end - - - (** {6 Trace} *) module Trace = struct diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 20f67f2584..6bc2e9a0ed 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -406,7 +406,13 @@ module Unsafe : sig (** Give an evar the status of a goal (changes its source location and makes it unresolvable for type classes. *) - val mark_as_goal : proofview -> Evar.t -> proofview + val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map + + (** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) + val advance : Evd.evar_map -> Evar.t -> Evar.t option end (** This module gives access to the innards of the monad. Its use is @@ -491,39 +497,6 @@ module Goal : sig end -(** {6 The refine tactic} *) - -module Refine : sig - - (** Printer used to print the constr which refine refines. *) - val pr_constr : - (Environ.env -> Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t - - (** {7 Refinement primitives} *) - - val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic - (** In [refine ?unsafe t], [t] is a term with holes under some - [evar_map] context. The term [t] is used as a partial solution - for the current goal (refine is a goal-dependent tactic), the - new holes created by [t] become the new subgoals. Exceptions - raised during the interpretation of [t] are caught and result in - tactic failures. If [unsafe] is [false] (default is [true]) [t] is - type-checked beforehand. *) - - (** {7 Helper functions} *) - - val with_type : Environ.env -> Evd.evar_map -> - Term.constr -> Term.types -> Evd.evar_map * Term.constr - (** [with_type env sigma c t] ensures that [c] is of type [t] - inserting a coercion if needed. *) - - val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic - (** Like {!refine} except the refined term is coerced to the conclusion of the - current goal. *) - -end - - (** {6 Trace} *) module Trace : sig diff --git a/proofs/refine.ml b/proofs/refine.ml new file mode 100644 index 0000000000..db0b26f7e5 --- /dev/null +++ b/proofs/refine.ml @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + if d1 == d2 then share l1 l2 (d1 :: accu) + else (accu, d2 :: l2) + | _ -> (accu, l2) + in + share ctx1 ctx2 [] + +let typecheck_evar ev env sigma = + let info = Evd.find sigma ev in + (** Typecheck the hypotheses. *) + let type_hyp (sigma, env) decl = + let t = get_type decl in + let evdref = ref sigma in + let _ = Typing.e_sort_of env evdref t in + let () = match decl with + | LocalAssum _ -> () + | LocalDef (_,body,_) -> Typing.e_check env evdref body t + in + (!evdref, Environ.push_named decl env) + in + let (common, changed) = extract_prefix env info in + let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in + let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in + (** Typecheck the conclusion *) + let evdref = ref sigma in + let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in + !evdref + +let typecheck_proof c concl env sigma = + let evdref = ref sigma in + let () = Typing.e_check env evdref c concl in + !evdref + +let (pr_constrv,pr_constr) = + Hook.make ~default:(fun _env _sigma _c -> Pp.str"") () + +let refine ?(unsafe = true) f = Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + (** Save the [future_goals] state to restore them after the + refinement. *) + let prev_future_goals = Evd.future_goals sigma in + let prev_principal_goal = Evd.principal_future_goal sigma in + (** Create the refinement term *) + let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in + let evs = Evd.future_goals sigma in + let evkmain = Evd.principal_future_goal sigma in + (** Check that the introduced evars are well-typed *) + let fold accu ev = typecheck_evar ev env accu in + let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in + (** Check that the refined term is typesafe *) + let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in + (** Check that the goal itself does not appear in the refined term *) + let self = Proofview.Goal.goal gl in + let _ = + if not (Evarutil.occur_evar_upto sigma self c) then () + else Pretype_errors.error_occur_check env sigma self c + in + (** Proceed to the refinement *) + let sigma = match evkmain with + | None -> Evd.define self c sigma + | Some evk -> + let id = Evd.evar_ident self sigma in + let sigma = Evd.define self c sigma in + match id with + | None -> sigma + | Some id -> Evd.rename evk id sigma + in + (** Restore the [future goals] state. *) + let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in + (** Select the goals *) + let comb = CList.map_filter (Proofview.Unsafe.advance sigma) (CList.rev evs) in + let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in + let trace () = Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)) in + Proofview.Trace.name_tactic trace (Proofview.tclUNIT ()) >>= fun () -> + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.Unsafe.tclSETGOALS comb +end } + +(** Useful definitions *) + +let with_type env evd c t = + let my_type = Retyping.get_type_of env evd c in + let j = Environ.make_judge c my_type in + let (evd,j') = + Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t + in + evd , j'.Environ.uj_val + +let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let f = { run = fun h -> + let Sigma (c, h, p) = f.run h in + let sigma, c = with_type env (Sigma.to_evar_map h) c concl in + Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) + } in + refine ?unsafe f +end } diff --git a/proofs/refine.mli b/proofs/refine.mli new file mode 100644 index 0000000000..17c7e28ca9 --- /dev/null +++ b/proofs/refine.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t + +(** {7 Refinement primitives} *) + +val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic +(** In [refine ?unsafe t], [t] is a term with holes under some + [evar_map] context. The term [t] is used as a partial solution + for the current goal (refine is a goal-dependent tactic), the + new holes created by [t] become the new subgoals. Exceptions + raised during the interpretation of [t] are caught and result in + tactic failures. If [unsafe] is [false] (default is [true]) [t] is + type-checked beforehand. *) + +(** {7 Helper functions} *) + +val with_type : Environ.env -> Evd.evar_map -> + Term.constr -> Term.types -> Evd.evar_map * Term.constr +(** [with_type env sigma c t] ensures that [c] is of type [t] + inserting a coercion if needed. *) + +val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic +(** Like {!refine} except the refined term is coerced to the conclusion of the + current goal. *) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 0cc796886c..23aa8dcb47 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -370,7 +370,7 @@ let refine_tac ist simple c = let expected_type = Pretyping.OfType concl in let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in let update = { run = fun sigma -> c.delayed env sigma } in - let refine = Proofview.Refine.refine ~unsafe:false update in + let refine = Refine.refine ~unsafe:false update in if simple then refine else refine <*> Tactics.New.reduce_after_refine <*> diff --git a/tactics/inv.ml b/tactics/inv.ml index 6841ab0ecd..89c6beb321 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -459,7 +459,7 @@ let raw_inversion inv_kind id status names = in let refined id = let prf = mkApp (mkVar id, args) in - Proofview.Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } + Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } in let neqns = List.length realargs in let as_mode = names != None in diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 67d21886b2..4c06550d44 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1539,7 +1539,7 @@ let assert_replacing id newt tac = | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in - Proofview.Refine.refine ~unsafe:false { run = begin fun sigma -> + Refine.refine ~unsafe:false { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in let map d = @@ -1568,7 +1568,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let gls = List.rev (Evd.fold_undefined fold undef []) in match clause, prf with | Some id, Some p -> - let tac = Proofview.Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in + let tac = Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in Proofview.Unsafe.tclEVARS undef <*> assert_replacing id newt tac | Some id, None -> @@ -1582,7 +1582,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in Sigma (mkApp (p, [| ev |]), sigma, q) end } in - Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls + Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls end } | None, None -> Proofview.Unsafe.tclEVARS undef <*> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index ffe10d81c6..7ae178af57 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -163,7 +163,7 @@ let _ = does not check anything. *) let unsafe_intro env store decl b = let open Context.Named.Declaration in - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in let inst = List.map (mkVar % get_id) (named_context env) in @@ -199,7 +199,7 @@ let convert_concl ?(check=true) ty k = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin let sigma = Sigma.to_evar_map sigma in @@ -222,7 +222,7 @@ let convert_hyp ?(check=true) d = let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end } end } @@ -345,7 +345,7 @@ let rename_hyp repl = let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in let instance = List.map (mkVar % get_id) hyps in - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~store instance end } end } @@ -1070,7 +1070,7 @@ let cut c = let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in - Proofview.Refine.refine ~unsafe:true { run = begin fun h -> + Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in @@ -1736,7 +1736,7 @@ let cut_and_apply c = | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in - Proofview.Refine.refine { run = begin fun sigma -> + Refine.refine { run = begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in @@ -1757,7 +1757,7 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let new_exact_no_check c = - Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } + Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -1808,7 +1808,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar (get_id decl)) h } + Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar (get_id decl)) h } else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -1893,7 +1893,7 @@ let clear_body ids = check_is_type env concl msg in check_hyps <*> check_concl <*> - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl end } end } @@ -1950,7 +1950,7 @@ let apply_type newcl args = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Proofview.Refine.refine { run = begin fun sigma -> + Refine.refine { run = begin fun sigma -> let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in @@ -1971,7 +1971,7 @@ let bring_hyps hyps = let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (Context.Named.to_instance hyps) in - Proofview.Refine.refine { run = begin fun sigma -> + Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in Sigma (mkApp (ev, args), sigma, p) @@ -2671,7 +2671,7 @@ let new_generalize_gen_let lconstr = 0 lconstr (concl, sigma, []) in let tac = - Proofview.Refine.refine { run = begin fun sigma -> + Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in Sigma ((applist (ev, args)), sigma, p) end } @@ -3325,7 +3325,7 @@ let mk_term_eq env sigma ty t ty' t' = let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let open Context.Rel.Declaration in - Proofview.Refine.refine { run = begin fun sigma -> + Refine.refine { run = begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let abshypeq, abshypt = @@ -4126,7 +4126,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> let b = not with_evars && with_eq != None in let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in @@ -4150,7 +4150,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let env = reset_with_named_context sign env in let tac = Tacticals.New.tclTHENLIST [ - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end }; tac @@ -4795,6 +4795,6 @@ module New = struct {onhyps=None; concl_occs=AllOccurrences } let refine ?unsafe c = - Proofview.Refine.refine ?unsafe c <*> + Refine.refine ?unsafe c <*> reduce_after_refine end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 26ea017696..4c4a96ec07 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -431,7 +431,7 @@ end module New : sig val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic - (** [refine ?unsafe c] is [Proofview.Refine.refine ?unsafe c] + (** [refine ?unsafe c] is [Refine.refine ?unsafe c] followed by beta-iota-reduction of the conclusion. *) val reduce_after_refine : unit Proofview.tactic diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 0a83c49c8d..4bf0450d27 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -330,7 +330,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Proofview.Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) }; + Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) }; Proofview.Unsafe.tclNEWGOALS gls; Tactics.New.reduce_after_refine; ] -- cgit v1.2.3 From ea4e09c26747fa9c49882580a72139fe748a0d64 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 19:38:36 +0100 Subject: Moving Proofview to pretyping/. --- pretyping/pretyping.mllib | 1 + pretyping/proofview.ml | 1204 +++++++++++++++++++++++++++++++++++++++++++++ pretyping/proofview.mli | 586 ++++++++++++++++++++++ proofs/proofs.mllib | 1 - proofs/proofview.ml | 1204 --------------------------------------------- proofs/proofview.mli | 586 ---------------------- 6 files changed, 1791 insertions(+), 1791 deletions(-) create mode 100644 pretyping/proofview.ml create mode 100644 pretyping/proofview.mli delete mode 100644 proofs/proofview.ml delete mode 100644 proofs/proofview.mli diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index b59589bda2..5dfdd0379a 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -21,6 +21,7 @@ Constr_matching Tacred Typeclasses_errors Typeclasses +Proofview Classops Program Coercion diff --git a/pretyping/proofview.ml b/pretyping/proofview.ml new file mode 100644 index 0000000000..20be02e76d --- /dev/null +++ b/pretyping/proofview.ml @@ -0,0 +1,1204 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* i+1) solution 0 in + let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in + let pruned_solution = Evd.drop_all_defined solution in + let apply_subst_einfo _ ei = + Evd.({ ei with + evar_concl = nf ei.evar_concl; + evar_hyps = Environ.map_named_val nf ei.evar_hyps; + evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in + let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in + let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in + msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); + new_el, { pv with solution = new_solution; } + + +(** {6 Starting and querying a proof view} *) + +type telescope = + | TNil of Evd.evar_map + | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) + +let dependent_init = + (* Goals are created with a store which marks them as unresolvable + for type classes. *) + let store = Typeclasses.set_resolvable Evd.Store.empty false in + (* Goals don't have a source location. *) + let src = (Loc.ghost,Evar_kinds.GoalEvar) in + (* Main routine *) + let rec aux = function + | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } + | TCons (env, sigma, typ, t) -> + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in + let sigma = Sigma.to_evar_map sigma in + let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in + let (gl, _) = Term.destEvar econstr in + let entry = (econstr, typ) :: ret in + entry, { solution = sol; comb = gl :: comb; shelf = [] } + in + fun t -> + let entry, v = aux t in + (* The created goal are not to be shelved. *) + let solution = Evd.reset_future_goals v.solution in + entry, { v with solution } + +let init = + let rec aux sigma = function + | [] -> TNil sigma + | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l)) + in + fun sigma l -> dependent_init (aux sigma l) + +let initial_goals initial = initial + +let finished = function + | {comb = []} -> true + | _ -> false + +let return { solution=defs } = defs + +let return_constr { solution = defs } c = Evarutil.nf_evar defs c + +let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry) + + +(** {6 Focusing commands} *) + +(** A [focus_context] represents the part of the proof view which has + been removed by a focusing action, it can be used to unfocus later + on. *) +(* First component is a reverse list of the goals which come before + and second component is the list of the goals which go after (in + the expected order). *) +type focus_context = Evar.t list * Evar.t list + + +(** Returns a stylised view of a focus_context for use by, for + instance, ide-s. *) +(* spiwack: the type of [focus_context] will change as we push more + refined functions to ide-s. This would be better than spawning a + new nearly identical function everytime. Hence the generic name. *) +(* In this version: the goals in the context, as a "zipper" (the first + list is in reversed order). *) +let focus_context f = f + +(** This (internal) function extracts a sublist between two indices, + and returns this sublist together with its context: if it returns + [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the + original list. The focused list has lenght [j-i-1] and contains + the goals from number [i] to number [j] (both included) the first + goal of the list being numbered [1]. [focus_sublist i j l] raises + [IndexOutOfRange] if [i > length l], or [j > length l] or [j < + i]. *) +let focus_sublist i j l = + let (left,sub_right) = CList.goto (i-1) l in + let (sub, right) = + try CList.chop (j-i+1) sub_right + with Failure _ -> raise CList.IndexOutOfRange + in + (sub, (left,right)) + +(** Inverse operation to the previous one. *) +let unfocus_sublist (left,right) s = + CList.rev_append left (s@right) + + +(** [focus i j] focuses a proofview on the goals from index [i] to + index [j] (inclusive, goals are indexed from [1]). I.e. goals + number [i] to [j] become the only focused goals of the returned + proofview. It returns the focused proofview, and a context for + the focus stack. *) +let focus i j sp = + let (new_comb, context) = focus_sublist i j sp.comb in + ( { sp with comb = new_comb } , context ) + + +(** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) +(* spiwack: [advance] is probably performance critical, and the good + behaviour of its definition may depend sensitively to the actual + definition of [Evd.find]. Currently, [Evd.find] starts looking for + a value in the heap of undefined variable, which is small. Hence in + the most common case, where [advance] is applied to an unsolved + goal ([advance] is used to figure if a side effect has modified the + goal) it terminates quickly. *) +let rec advance sigma g = + let open Evd in + let evi = Evd.find sigma g in + match evi.evar_body with + | Evar_empty -> Some g + | Evar_defined v -> + if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then + let (e,_) = Term.destEvar v in + advance sigma e + else + None + +(** [undefined defs l] is the list of goals in [l] which are still + unsolved (after advancing cleared goals). *) +let undefined defs l = CList.map_filter (advance defs) l + +(** Unfocuses a proofview with respect to a context. *) +let unfocus c sp = + { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } + + +(** {6 The tactic monad} *) + +(** - Tactics are objects which apply a transformation to all the + subgoals of the current view at the same time. By opposition to + the old vision of applying it to a single goal. It allows tactics + such as [shelve_unifiable], tactics to reorder the focused goals, + or global automation tactic for dependent subgoals (instantiating + an evar has influences on the other goals of the proof in + progress, not being able to take that into account causes the + current eauto tactic to fail on some instances where it could + succeed). Another benefit is that it is possible to write tactics + that can be executed even if there are no focused goals. + - Tactics form a monad ['a tactic], in a sense a tactic can be + seen as a function (without argument) which returns a value of + type 'a and modifies the environment (in our case: the view). + Tactics of course have arguments, but these are given at the + meta-level as OCaml functions. Most tactics in the sense we are + used to return [()], that is no really interesting values. But + some might pass information around. The tactics seen in Coq's + Ltac are (for now at least) only [unit tactic], the return values + are kept for the OCaml toolkit. The operation or the monad are + [Proofview.tclUNIT] (which is the "return" of the tactic monad) + [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] + (which is a specialized bind on unit-returning tactics). + - Tactics have support for full-backtracking. Tactics can be seen + having multiple success: if after returning the first success a + failure is encountered, the tactic can backtrack and use a second + success if available. The state is backtracked to its previous + value, except the non-logical state defined in the {!NonLogical} + module below. +*) +(* spiwack: as far as I'm aware this doesn't really relate to + F. Kirchner and C. Muñoz. *) + +module Proof = Logical + +(** type of tactics: + + tactics can + - access the environment, + - report unsafe status, shelved goals and given up goals + - access and change the current [proofview] + - backtrack on previous changes of the proofview *) +type +'a tactic = 'a Proof.t + +(** Applies a tactic to the current proofview. *) +let apply env t sp = + let open Logic_monad in + let ans = Proof.repr (Proof.run t false (sp,env)) in + let ans = Logic_monad.NonLogical.run ans in + match ans with + | Nil (e, info) -> iraise (TacticFailure e, info) + | Cons ((r, (state, _), status, info), _) -> + let (status, gaveup) = status in + let status = (status, state.shelf, gaveup) in + let state = { state with shelf = [] } in + r, state, status, Trace.to_tree info + + + +(** {7 Monadic primitives} *) + +(** Unit of the tactic monad. *) +let tclUNIT = Proof.return + +(** Bind operation of the tactic monad. *) +let tclBIND = Proof.(>>=) + +(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, + it's a specialized "bind". *) +let tclTHEN = Proof.(>>) + +(** [tclIGNORE t] has the same operational content as [t], but drops + the returned value. *) +let tclIGNORE = Proof.ignore + +module Monad = Proof + + + +(** {7 Failure and backtracking} *) + + +(** [tclZERO e] fails with exception [e]. It has no success. *) +let tclZERO ?info e = + let info = match info with + | None -> Exninfo.null + | Some info -> info + in + Proof.zero (e, info) + +(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever + the successes of [t1] have been depleted and it failed with [e], + then it behaves as [t2 e]. In other words, [tclOR] inserts a + backtracking point. *) +let tclOR = Proof.plus + +(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one + success or [t2 e] if [t1] fails with [e]. It is analogous to + [try/with] handler of exception in that it is not a backtracking + point. *) +let tclORELSE t1 t2 = + let open Logic_monad in + let open Proof in + split t1 >>= function + | Nil e -> t2 e + | Cons (a,t1') -> plus (return a) t1' + +(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] + succeeds at least once then it behaves as [tclBIND a s] otherwise, + if [a] fails with [e], then it behaves as [f e]. *) +let tclIFCATCH a s f = + let open Logic_monad in + let open Proof in + split a >>= function + | Nil e -> f e + | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x')) + +(** [tclONCE t] behave like [t] except it has at most one success: + [tclONCE t] stops after the first success of [t]. If [t] fails + with [e], [tclONCE t] also fails with [e]. *) +let tclONCE = Proof.once + +exception MoreThanOneSuccess +let _ = Errors.register_handler begin function + | MoreThanOneSuccess -> Errors.error "This tactic has more than one success." + | _ -> raise Errors.Unhandled +end + +(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one + success. Otherwise it fails. The tactic [t] is run until its first + success, then a failure with exception [e] is simulated. It [t] + yields another success, then [tclEXACTLY_ONCE e t] fails with + [MoreThanOneSuccess] (it is a user error). Otherwise, + [tclEXACTLY_ONCE e t] succeeds with the first success of + [t]. Notice that the choice of [e] is relevant, as the presence of + further successes may depend on [e] (see {!tclOR}). *) +let tclEXACTLY_ONCE e t = + let open Logic_monad in + let open Proof in + split t >>= function + | Nil (e, info) -> tclZERO ~info e + | Cons (x,k) -> + Proof.split (k (e, Exninfo.null)) >>= function + | Nil _ -> tclUNIT x + | _ -> tclZERO MoreThanOneSuccess + + +(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) +type 'a case = +| Fail of iexn +| Next of 'a * (iexn -> 'a tactic) +let tclCASE t = + let open Logic_monad in + let map = function + | Nil e -> Fail e + | Cons (x, t) -> Next (x, t) + in + Proof.map map (Proof.split t) + +let tclBREAK = Proof.break + + + +(** {7 Focusing tactics} *) + +exception NoSuchGoals of int + +(* This hook returns a string to be appended to the usual message. + Primarily used to add a suggestion about the right bullet to use to + focus the next goal, if applicable. *) +let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) +let set_nosuchgoals_hook f = nosuchgoals_hook := f + + + +(* This uses the hook above *) +let _ = Errors.register_handler begin function + | NoSuchGoals n -> + let suffix = !nosuchgoals_hook n in + Errors.errorlabstrm "" + (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) + | _ -> raise Errors.Unhandled +end + +(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where + only the goals numbered [i] to [j] are focused (the rest of the goals + is restored at the end of the tactic). If the range [i]-[j] is not + valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) +let tclFOCUS_gen nosuchgoal i j t = + let open Proof in + Pv.get >>= fun initial -> + try + let (focused,context) = focus i j initial in + Pv.set focused >> + t >>= fun result -> + Pv.modify (fun next -> unfocus context next) >> + return result + with CList.IndexOutOfRange -> nosuchgoal + +let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t +let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t + +(** Like {!tclFOCUS} but selects a single goal by name. *) +let tclFOCUSID id t = + let open Proof in + Pv.get >>= fun initial -> + try + let ev = Evd.evar_key id initial.solution in + try + let n = CList.index Evar.equal ev initial.comb in + (* goal is already under focus *) + let (focused,context) = focus n n initial in + Pv.set focused >> + t >>= fun result -> + Pv.modify (fun next -> unfocus context next) >> + return result + with Not_found -> + (* otherwise, save current focus and work purely on the shelve *) + Comb.set [ev] >> + t >>= fun result -> + Comb.set initial.comb >> + return result + with Not_found -> tclZERO (NoSuchGoals 1) + +(** {7 Dispatching on goals} *) + +exception SizeMismatch of int*int +let _ = Errors.register_handler begin function + | SizeMismatch (i,_) -> + let open Pp in + let errmsg = + str"Incorrect number of goals" ++ spc() ++ + str"(expected "++int i++str(String.plural i " tactic") ++ str")." + in + Errors.errorlabstrm "" errmsg + | _ -> raise Errors.Unhandled +end + +(** A variant of [Monad.List.iter] where we iter over the focused list + of goals. The argument tactic is executed in a focus comprising + only of the current goal, a goal which has been solved by side + effect is skipped. The generated subgoals are concatenated in + order. *) +let iter_goal i = + let open Proof in + Comb.get >>= fun initial -> + Proof.List.fold_left begin fun (subgoals as cur) goal -> + Solution.get >>= fun step -> + match advance step goal with + | None -> return cur + | Some goal -> + Comb.set [goal] >> + i goal >> + Proof.map (fun comb -> comb :: subgoals) Comb.get + end [] initial >>= fun subgoals -> + Solution.get >>= fun evd -> + Comb.set CList.(undefined evd (flatten (rev subgoals))) + +(** A variant of [Monad.List.fold_left2] where the first list is the + list of focused goals. The argument tactic is executed in a focus + comprising only of the current goal, a goal which has been solved + by side effect is skipped. The generated subgoals are concatenated + in order. *) +let fold_left2_goal i s l = + let open Proof in + Pv.get >>= fun initial -> + let err = + return () >>= fun () -> (* Delay the computation of list lengths. *) + tclZERO (SizeMismatch (CList.length initial.comb,CList.length l)) + in + Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> + Solution.get >>= fun step -> + match advance step goal with + | None -> return cur + | Some goal -> + Comb.set [goal] >> + i goal a r >>= fun r -> + Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get + end (s,[]) initial.comb l >>= fun (r,subgoals) -> + Solution.get >>= fun evd -> + Comb.set CList.(undefined evd (flatten (rev subgoals))) >> + return r + +(** Dispatch tacticals are used to apply a different tactic to each + goal under focus. They come in two flavours: [tclDISPATCH] takes a + list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] + takes a list of ['a tactic] and returns an ['a list tactic]. + + They both work by applying each of the tactic in a focus + restricted to the corresponding goal (starting with the first + goal). In the case of [tclDISPATCHL], the tactic returns a list of + the same size as the argument list (of tactics), each element + being the result of the tactic executed in the corresponding goal. + + When the length of the tactic list is not the number of goal, + raises [SizeMismatch (g,t)] where [g] is the number of available + goals, and [t] the number of tactics passed. + + [tclDISPATCHGEN join tacs] generalises both functions as the + successive results of [tacs] are stored in reverse order in a + list, and [join] is used to convert the result into the expected + form. *) +let tclDISPATCHGEN0 join tacs = + match tacs with + | [] -> + begin + let open Proof in + Comb.get >>= function + | [] -> tclUNIT (join []) + | comb -> tclZERO (SizeMismatch (CList.length comb,0)) + end + | [tac] -> + begin + let open Proof in + Pv.get >>= function + | { comb=[goal] ; solution } -> + begin match advance solution goal with + | None -> tclUNIT (join []) + | Some _ -> Proof.map (fun res -> join [res]) tac + end + | {comb} -> tclZERO (SizeMismatch(CList.length comb,1)) + end + | _ -> + let iter _ t cur = Proof.map (fun y -> y :: cur) t in + let ans = fold_left2_goal iter [] tacs in + Proof.map join ans + +let tclDISPATCHGEN join tacs = + let branch t = InfoL.tag (Info.DBranch) t in + let tacs = CList.map branch tacs in + InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs) + +let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs + +let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs + + +(** [extend_to_list startxs rx endxs l] builds a list + [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises + [SizeMismatch] if [startxs@endxs] is already longer than [l]. *) +let extend_to_list startxs rx endxs l = + (* spiwack: I use [l] essentially as a natural number *) + let rec duplicate acc = function + | [] -> acc + | _::rest -> duplicate (rx::acc) rest + in + let rec tail to_match rest = + match rest, to_match with + | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) + | _::rest , _::to_match -> tail to_match rest + | _ , [] -> duplicate endxs rest + in + let rec copy pref rest = + match rest,pref with + | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) + | _::rest, a::pref -> a::(copy pref rest) + | _ , [] -> tail endxs rest + in + copy startxs l + +(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] + tactic is "repeated" enough time such that every goal has a tactic + assigned to it ([b] is the list of tactics applied to the first + goals, [e] to the last goals, and [r] is applied to every goal in + between). *) +let tclEXTEND tacs1 rtac tacs2 = + let open Proof in + Comb.get >>= fun comb -> + try + let tacs = extend_to_list tacs1 rtac tacs2 comb in + tclDISPATCH tacs + with SizeMismatch _ -> + tclZERO (SizeMismatch( + CList.length comb, + (CList.length tacs1)+(CList.length tacs2))) +(* spiwack: failure occurs only when the number of goals is too + small. Hence we can assume that [rtac] is replicated 0 times for + any error message. *) + +(** [tclEXTEND [] tac []]. *) +let tclINDEPENDENT tac = + let open Proof in + Pv.get >>= fun initial -> + match initial.comb with + | [] -> tclUNIT () + | [_] -> tac + | _ -> + let tac = InfoL.tag (Info.DBranch) tac in + InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac)) + + + +(** {7 Goal manipulation} *) + +(** Shelves all the goals under focus. *) +let shelve = + let open Proof in + Comb.get >>= fun initial -> + Comb.set [] >> + InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> + Shelf.modify (fun gls -> gls @ initial) + + +(** [contained_in_info e evi] checks whether the evar [e] appears in + the hypotheses, the conclusion or the body of the evar_info + [evi]. Note: since we want to use it on goals, the body is actually + supposed to be empty. *) +let contained_in_info sigma e evi = + Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) + +(** [depends_on sigma src tgt] checks whether the goal [src] appears + as an existential variable in the definition of the goal [tgt] in + [sigma]. *) +let depends_on sigma src tgt = + let evi = Evd.find sigma tgt in + contained_in_info sigma src evi + +(** [unifiable sigma g l] checks whether [g] appears in another + subgoal of [l]. The list [l] may contain [g], but it does not + affect the result. *) +let unifiable sigma g l = + CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l + +(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] + where [u] is composed of the unifiable goals, i.e. the goals on + whose definition other goals of [l] depend, and [n] are the + non-unifiable goals. *) +let partition_unifiable sigma l = + CList.partition (fun g -> unifiable sigma g l) l + +(** Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +let shelve_unifiable = + let open Proof in + Pv.get >>= fun initial -> + let (u,n) = partition_unifiable initial.solution initial.comb in + Comb.set n >> + InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> + Shelf.modify (fun gls -> gls @ u) + +(** [guard_no_unifiable] returns the list of unifiable goals if some + goals are unifiable (see {!shelve_unifiable}) in the current focus. *) +let guard_no_unifiable = + let open Proof in + Pv.get >>= fun initial -> + let (u,n) = partition_unifiable initial.solution initial.comb in + match u with + | [] -> tclUNIT None + | gls -> + let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in + let l = CList.map (fun id -> Names.Name id) l in + tclUNIT (Some l) + +(** [unshelve l p] adds all the goals in [l] at the end of the focused + goals of p *) +let unshelve l p = + (* advance the goals in case of clear *) + let l = undefined p.solution l in + { p with comb = p.comb@l } + +let with_shelf tac = + let open Proof in + Pv.get >>= fun pv -> + let { shelf; solution } = pv in + Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> + tac >>= fun ans -> + Pv.get >>= fun npv -> + let { shelf = gls; solution = sigma } = npv in + let gls' = Evd.future_goals sigma in + let fgoals = Evd.future_goals solution in + let pgoal = Evd.principal_future_goal solution in + let sigma = Evd.restore_future_goals sigma fgoals pgoal in + Pv.set { npv with shelf; solution = sigma } >> + tclUNIT (CList.rev_append gls' gls, ans) + +(** [goodmod p m] computes the representative of [p] modulo [m] in the + interval [[0,m-1]].*) +let goodmod p m = + let p' = p mod m in + (* if [n] is negative [n mod l] is negative of absolute value less + than [l], so [(n mod l)+l] is the representative of [n] in the + interval [[0,l-1]].*) + if p' < 0 then p'+m else p' + +let cycle n = + let open Proof in + InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> + Comb.modify begin fun initial -> + let l = CList.length initial in + let n' = goodmod n l in + let (front,rear) = CList.chop n' initial in + rear@front + end + +let swap i j = + let open Proof in + InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> + Comb.modify begin fun initial -> + let l = CList.length initial in + let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in + let i = goodmod i l and j = goodmod j l in + CList.map_i begin fun k x -> + match k with + | k when Int.equal k i -> CList.nth initial j + | k when Int.equal k j -> CList.nth initial i + | _ -> x + end 0 initial + end + +let revgoals = + let open Proof in + InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> + Comb.modify CList.rev + +let numgoals = + let open Proof in + Comb.get >>= fun comb -> + return (CList.length comb) + + + +(** {7 Access primitives} *) + +let tclEVARMAP = Solution.get + +let tclENV = Env.get + + + +(** {7 Put-like primitives} *) + + +let emit_side_effects eff x = + { x with solution = Evd.emit_side_effects eff x.solution } + +let tclEFFECTS eff = + let open Proof in + return () >>= fun () -> (* The Global.env should be taken at exec time *) + Env.set (Global.env ()) >> + Pv.modify (fun initial -> emit_side_effects eff initial) + +let mark_as_unsafe = Status.put false + +(** Gives up on the goal under focus. Reports an unsafe status. Proofs + with given up goals cannot be closed. *) +let give_up = + let open Proof in + Comb.get >>= fun initial -> + Comb.set [] >> + mark_as_unsafe >> + InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> + Giveup.put initial + + + +(** {7 Control primitives} *) + + +module Progress = struct + + let eq_constr = Evarutil.eq_constr_univs_test + + (** equality function on hypothesis contexts *) + let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = + let open Environ in + let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in + let eq_named_declaration d1 d2 = + match d1, d2 with + | LocalAssum (i1,t1), LocalAssum (i2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 + | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 + && eq_constr sigma1 sigma2 t1 t2 + | _ -> + false + in List.equal eq_named_declaration c1 c2 + + let eq_evar_body sigma1 sigma2 b1 b2 = + let open Evd in + match b1, b2 with + | Evar_empty, Evar_empty -> true + | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2 + | _ -> false + + let eq_evar_info sigma1 sigma2 ei1 ei2 = + let open Evd in + eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl && + eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) && + eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body + + (** Equality function on goals *) + let goal_equal evars1 gl1 evars2 gl2 = + let evi1 = Evd.find evars1 gl1 in + let evi2 = Evd.find evars2 gl2 in + eq_evar_info evars1 evars2 evi1 evi2 + +end + +let tclPROGRESS t = + let open Proof in + Pv.get >>= fun initial -> + t >>= fun res -> + Pv.get >>= fun final -> + (* [*_test] test absence of progress. [quick_test] is approximate + whereas [exhaustive_test] is complete. *) + let quick_test = + initial.solution == final.solution && initial.comb == final.comb + in + let exhaustive_test = + Util.List.for_all2eq begin fun i f -> + Progress.goal_equal initial.solution i final.solution f + end initial.comb final.comb + in + let test = + quick_test || exhaustive_test + in + if not test then + tclUNIT res + else + tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) + +exception Timeout +let _ = Errors.register_handler begin function + | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | _ -> Pervasives.raise Errors.Unhandled +end + +let tclTIMEOUT n t = + let open Proof in + (* spiwack: as one of the monad is a continuation passing monad, it + doesn't force the computation to be threaded inside the underlying + (IO) monad. Hence I force it myself by asking for the evaluation of + a dummy value first, lest [timeout] be called when everything has + already been computed. *) + let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in + Proof.get >>= fun initial -> + Proof.current >>= fun envvar -> + Proof.lift begin + Logic_monad.NonLogical.catch + begin + let open Logic_monad.NonLogical in + timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> + match r with + | Logic_monad.Nil e -> return (Util.Inr e) + | Logic_monad.Cons (r, _) -> return (Util.Inl r) + end + begin let open Logic_monad.NonLogical in function (e, info) -> + match e with + | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) + | Logic_monad.TacticFailure e -> + return (Util.Inr (e, info)) + | e -> Logic_monad.NonLogical.raise ~info e + end + end >>= function + | Util.Inl (res,s,m,i) -> + Proof.set s >> + Proof.put m >> + Proof.update (fun _ -> i) >> + return res + | Util.Inr (e, info) -> tclZERO ~info e + +let tclTIME s t = + let pr_time t1 t2 n msg = + let msg = + if n = 0 then + str msg + else + str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking") + in + msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ + System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in + let rec aux n t = + let open Proof in + tclUNIT () >>= fun () -> + let tstart = System.get_time() in + Proof.split t >>= let open Logic_monad in function + | Nil (e, info) -> + begin + let tend = System.get_time() in + pr_time tstart tend n "failure"; + tclZERO ~info e + end + | Cons (x,k) -> + let tend = System.get_time() in + pr_time tstart tend n "success"; + tclOR (tclUNIT x) (fun e -> aux (n+1) (k e)) + in aux 0 t + + + +(** {7 Unsafe primitives} *) + +module Unsafe = struct + + let tclEVARS evd = + Pv.modify (fun ps -> { ps with solution = evd }) + + let tclNEWGOALS gls = + Pv.modify begin fun step -> + let gls = undefined step.solution gls in + { step with comb = step.comb @ gls } + end + + let tclGETGOALS = Comb.get + + let tclSETGOALS = Comb.set + + let tclEVARSADVANCE evd = + Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) + + let tclEVARUNIVCONTEXT ctx = + Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) + + let reset_future_goals p = + { p with solution = Evd.reset_future_goals p.solution } + + let mark_as_goal evd content = + let info = Evd.find evd content in + let info = + { info with Evd.evar_source = match info.Evd.evar_source with + | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x + | loc,_ -> loc,Evar_kinds.GoalEvar } + in + let info = Typeclasses.mark_unresolvable info in + Evd.add evd content info + + let advance = advance + +end + +module UnsafeRepr = Proof.Unsafe + +let (>>=) = tclBIND +let (<*>) = tclTHEN +let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + +(** {6 Goal-dependent tactics} *) + +let goal_env evars gl = + let evi = Evd.find evars gl in + Evd.evar_filtered_env evi + +let goal_nf_evar sigma gl = + let evi = Evd.find sigma gl in + let evi = Evarutil.nf_evar_info sigma evi in + let sigma = Evd.add sigma gl evi in + (gl, sigma) + +let goal_extra evars gl = + let evi = Evd.find evars gl in + evi.Evd.evar_extra + + +let catchable_exception = function + | Logic_monad.Exception _ -> false + | e -> Errors.noncritical e + + +module Goal = struct + + type ('a, 'r) t = { + env : Environ.env; + sigma : Evd.evar_map; + concl : Term.constr ; + self : Evar.t ; (* for compatibility with old-style definitions *) + } + + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } + + let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) + + let env { env=env } = env + let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma + let hyps { env=env } = Environ.named_context env + let concl { concl=concl } = concl + let extra { sigma=sigma; self=self } = goal_extra sigma self + + let raw_concl { concl=concl } = concl + + + let gmake_with info env sigma goal = + { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ; + sigma = sigma ; + concl = Evd.evar_concl info ; + self = goal } + + let nf_gmake env sigma goal = + let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in + let sigma = Evd.add sigma goal info in + gmake_with info env sigma goal , sigma + + let nf_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let (gl, sigma) = nf_gmake env sigma goal in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let normalize { self } = + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + let (gl,sigma) = nf_gmake env sigma self in + tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) + + let gmake env sigma goal = + let info = Evd.find sigma goal in + gmake_with info env sigma goal + + let enter f = + let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try f (gmake env sigma goal) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } + + let s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let gl = gmake env sigma goal in + let Sigma (tac, sigma, _) = f.s_enter gl in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let nf_s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let (gl, sigma) = nf_gmake env sigma goal in + let Sigma (tac, sigma, _) = f.s_enter gl in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let goals = + Pv.get >>= fun step -> + let sigma = step.solution in + let map goal = + match advance sigma goal with + | None -> None (** ppedrot: Is this check really necessary? *) + | Some goal -> + let gl = + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + tclUNIT (gmake env sigma goal) + in + Some gl + in + tclUNIT (CList.map_filter map step.comb) + + (* compatibility *) + let goal { self=self } = self + + let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) + +end + + + +(** {6 Trace} *) + +module Trace = struct + + let record_info_trace = InfoL.record_trace + + let log m = InfoL.leaf (Info.Msg m) + let name_tactic m t = InfoL.tag (Info.Tactic m) t + + let pr_info ?(lvl=0) info = + assert (lvl >= 0); + Info.(print (collapse lvl info)) + +end + + + +(** {6 Non-logical state} *) + +module NonLogical = Logic_monad.NonLogical + +let tclLIFT = Proof.lift + +let tclCHECKINTERRUPT = + tclLIFT (NonLogical.make Control.check_for_interrupt) + + + + + +(*** Compatibility layer with <= 8.2 tactics ***) +module V82 = struct + type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma + + let tactic tac = + (* spiwack: we ignore the dependencies between goals here, + expectingly preserving the semantics of <= 8.2 tactics *) + (* spiwack: convenience notations, waiting for ocaml 3.12 *) + let open Proof in + Pv.get >>= fun ps -> + try + let tac gl evd = + let glsigma = + tac { Evd.it = gl ; sigma = evd; } in + let sigma = glsigma.Evd.sigma in + let g = glsigma.Evd.it in + ( g, sigma ) + in + (* Old style tactics expect the goals normalized with respect to evars. *) + let (initgoals,initevd) = + Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution + in + let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in + let sgs = CList.flatten goalss in + let sgs = undefined evd sgs in + InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> + Pv.set { ps with solution = evd; comb = sgs; } + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + + + (* normalises the evars in the goals, and stores the result in + solution. *) + let nf_evar_goals = + Pv.modify begin fun ps -> + let map g s = goal_nf_evar s g in + let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in + { ps with solution = evd; comb = goals; } + end + + let has_unresolved_evar pv = + Evd.has_undefined pv.solution + + (* Main function in the implementation of Grab Existential Variables.*) + let grab pv = + let undef = Evd.undefined_map pv.solution in + let goals = CList.rev_map fst (Evar.Map.bindings undef) in + { pv with comb = goals } + + + + (* Returns the open goals of the proofview together with the evar_map to + interpret them. *) + let goals { comb = comb ; solution = solution; } = + { Evd.it = comb ; sigma = solution } + + let top_goals initial { solution=solution; } = + let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in + { Evd.it = goals ; sigma=solution; } + + let top_evars initial = + let evars_of_initial (c,_) = + Evar.Set.elements (Evd.evars_of_term c) + in + CList.flatten (CList.map evars_of_initial initial) + + let of_tactic t gls = + try + let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in + let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in + { Evd.sigma = final.solution ; it = final.comb } + with Logic_monad.TacticFailure e as src -> + let (_, info) = Errors.push src in + iraise (e, info) + + let put_status = Status.put + + let catchable_exception = catchable_exception + + let wrap_exceptions f = + try f () + with e when catchable_exception e -> + let (e, info) = Errors.push e in tclZERO ~info e + +end + +(** {7 Notations} *) + +module Notations = struct + let (>>=) = tclBIND + let (<*>) = tclTHEN + let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } +end diff --git a/pretyping/proofview.mli b/pretyping/proofview.mli new file mode 100644 index 0000000000..6bc2e9a0ed --- /dev/null +++ b/pretyping/proofview.mli @@ -0,0 +1,586 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Goal.goal list * Evd.evar_map + + +(** {6 Starting and querying a proof view} *) + +(** Abstract representation of the initial goals of a proof. *) +type entry + +(** Optimize memory consumption *) +val compact : entry -> proofview -> entry * proofview + +(** Initialises a proofview, the main argument is a list of + environments (including a [named_context] which are used as + hypotheses) pair with conclusion types, creating accordingly many + initial goals. Because a proof does not necessarily starts in an + empty [evar_map] (indeed a proof can be triggered by an incomplete + pretyping), [init] takes an additional argument to represent the + initial [evar_map]. *) +val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview + +(** A [telescope] is a list of environment and conclusion like in + {!init}, except that each element may depend on the previous + goals. The telescope passes the goals in the form of a + [Term.constr] which represents the goal as an [evar]. The + [evar_map] is threaded in state passing style. *) +type telescope = + | TNil of Evd.evar_map + | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) + +(** Like {!init}, but goals are allowed to be dependent on one + another. Dependencies between goals is represented with the type + [telescope] instead of [list]. Note that the first [evar_map] of + the telescope plays the role of the [evar_map] argument in + [init]. *) +val dependent_init : telescope -> entry * proofview + +(** [finished pv] is [true] if and only if [pv] is complete. That is, + if it has an empty list of focused goals. There could still be + unsolved subgoaled, but they would then be out of focus. *) +val finished : proofview -> bool + +(** Returns the current [evar] state. *) +val return : proofview -> Evd.evar_map + +val partial_proof : entry -> proofview -> constr list +val initial_goals : entry -> (constr * types) list + + + +(** {6 Focusing commands} *) + +(** A [focus_context] represents the part of the proof view which has + been removed by a focusing action, it can be used to unfocus later + on. *) +type focus_context + +(** Returns a stylised view of a focus_context for use by, for + instance, ide-s. *) +(* spiwack: the type of [focus_context] will change as we push more + refined functions to ide-s. This would be better than spawning a + new nearly identical function everytime. Hence the generic name. *) +(* In this version: the goals in the context, as a "zipper" (the first + list is in reversed order). *) +val focus_context : focus_context -> Goal.goal list * Goal.goal list + +(** [focus i j] focuses a proofview on the goals from index [i] to + index [j] (inclusive, goals are indexed from [1]). I.e. goals + number [i] to [j] become the only focused goals of the returned + proofview. It returns the focused proofview, and a context for + the focus stack. *) +val focus : int -> int -> proofview -> proofview * focus_context + +(** Unfocuses a proofview with respect to a context. *) +val unfocus : focus_context -> proofview -> proofview + + +(** {6 The tactic monad} *) + +(** - Tactics are objects which apply a transformation to all the + subgoals of the current view at the same time. By opposition to + the old vision of applying it to a single goal. It allows tactics + such as [shelve_unifiable], tactics to reorder the focused goals, + or global automation tactic for dependent subgoals (instantiating + an evar has influences on the other goals of the proof in + progress, not being able to take that into account causes the + current eauto tactic to fail on some instances where it could + succeed). Another benefit is that it is possible to write tactics + that can be executed even if there are no focused goals. + - Tactics form a monad ['a tactic], in a sense a tactic can be + seen as a function (without argument) which returns a value of + type 'a and modifies the environment (in our case: the view). + Tactics of course have arguments, but these are given at the + meta-level as OCaml functions. Most tactics in the sense we are + used to return [()], that is no really interesting values. But + some might pass information around. The tactics seen in Coq's + Ltac are (for now at least) only [unit tactic], the return values + are kept for the OCaml toolkit. The operation or the monad are + [Proofview.tclUNIT] (which is the "return" of the tactic monad) + [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] + (which is a specialized bind on unit-returning tactics). + - Tactics have support for full-backtracking. Tactics can be seen + having multiple success: if after returning the first success a + failure is encountered, the tactic can backtrack and use a second + success if available. The state is backtracked to its previous + value, except the non-logical state defined in the {!NonLogical} + module below. +*) + + +(** The abstract type of tactics *) +type +'a tactic + +(** Applies a tactic to the current proofview. Returns a tuple + [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv] + is the updated proofview, [b] a boolean which is [true] if the + tactic has not done any action considered unsafe (such as + admitting a lemma), [sh] is the list of goals which have been + shelved by the tactic, and [gu] the list of goals on which the + tactic has given up. In case of multiple success the first one is + selected. If there is no success, fails with + {!Logic_monad.TacticFailure}*) +val apply : Environ.env -> 'a tactic -> proofview -> 'a + * proofview + * (bool*Goal.goal list*Goal.goal list) + * Proofview_monad.Info.tree + +(** {7 Monadic primitives} *) + +(** Unit of the tactic monad. *) +val tclUNIT : 'a -> 'a tactic + +(** Bind operation of the tactic monad. *) +val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + +(** Interprets the ";" (semicolon) of Ltac. As a monadic operation, + it's a specialized "bind". *) +val tclTHEN : unit tactic -> 'a tactic -> 'a tactic + +(** [tclIGNORE t] has the same operational content as [t], but drops + the returned value. *) +val tclIGNORE : 'a tactic -> unit tactic + +(** Generic monadic combinators for tactics. *) +module Monad : Monad.S with type +'a t = 'a tactic + +(** {7 Failure and backtracking} *) + +(** [tclZERO e] fails with exception [e]. It has no success. *) +val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic + +(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever + the successes of [t1] have been depleted and it failed with [e], + then it behaves as [t2 e]. In other words, [tclOR] inserts a + backtracking point. *) +val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic + +(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one + success or [t2 e] if [t1] fails with [e]. It is analogous to + [try/with] handler of exception in that it is not a backtracking + point. *) +val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic + +(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] + succeeds at least once then it behaves as [tclBIND a s] otherwise, + if [a] fails with [e], then it behaves as [f e]. *) +val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic + +(** [tclONCE t] behave like [t] except it has at most one success: + [tclONCE t] stops after the first success of [t]. If [t] fails + with [e], [tclONCE t] also fails with [e]. *) +val tclONCE : 'a tactic -> 'a tactic + +(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one + success. Otherwise it fails. The tactic [t] is run until its first + success, then a failure with exception [e] is simulated. It [t] + yields another success, then [tclEXACTLY_ONCE e t] fails with + [MoreThanOneSuccess] (it is a user error). Otherwise, + [tclEXACTLY_ONCE e t] succeeds with the first success of + [t]. Notice that the choice of [e] is relevant, as the presence of + further successes may depend on [e] (see {!tclOR}). *) +exception MoreThanOneSuccess +val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic + +(** [tclCASE t] splits [t] into its first success and a + continuation. It is the most general primitive to control + backtracking. *) +type 'a case = + | Fail of iexn + | Next of 'a * (iexn -> 'a tactic) +val tclCASE : 'a tactic -> 'a case tactic + +(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of + stopping after the first success, it succeeds like [t] until a + failure with an exception [e] such that [p e = Some e'] is raised. At + which point it drops the remaining successes, failing with [e']. + [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *) +val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic + + +(** {7 Focusing tactics} *) + +(** [tclFOCUS i j t] applies [t] after focusing on the goals number + [i] to [j] (see {!focus}). The rest of the goals is restored after + the tactic action. If the specified range doesn't correspond to + existing goals, fails with [NoSuchGoals] (a user error). this + exception is caught at toplevel with a default message + a hook + message that can be customized by [set_nosuchgoals_hook] below. + This hook is used to add a suggestion about bullets when + applicable. *) +exception NoSuchGoals of int +val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit + +val tclFOCUS : int -> int -> 'a tactic -> 'a tactic + +(** [tclFOCUSID x t] applies [t] on a (single) focused goal like + {!tclFOCUS}. The goal is found by its name rather than its + number.*) +val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic + +(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the + specified range doesn't correspond to existing goals, behaves like + [tclUNIT ()] instead of failing. *) +val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic + + +(** {7 Dispatching on goals} *) + +(** Dispatch tacticals are used to apply a different tactic to each + goal under focus. They come in two flavours: [tclDISPATCH] takes a + list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] + takes a list of ['a tactic] and returns an ['a list tactic]. + + They both work by applying each of the tactic in a focus + restricted to the corresponding goal (starting with the first + goal). In the case of [tclDISPATCHL], the tactic returns a list of + the same size as the argument list (of tactics), each element + being the result of the tactic executed in the corresponding goal. + + When the length of the tactic list is not the number of goal, + raises [SizeMismatch (g,t)] where [g] is the number of available + goals, and [t] the number of tactics passed. *) +exception SizeMismatch of int*int +val tclDISPATCH : unit tactic list -> unit tactic +val tclDISPATCHL : 'a tactic list -> 'a list tactic + +(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] + tactic is "repeated" enough time such that every goal has a tactic + assigned to it ([b] is the list of tactics applied to the first + goals, [e] to the last goals, and [r] is applied to every goal in + between). *) +val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic + +(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from + the first one to the last one. Backtracking in one goal is + independent of backtracking in another. It is equivalent to + [tclEXTEND [] tac []]. *) +val tclINDEPENDENT : unit tactic -> unit tactic + + +(** {7 Goal manipulation} *) + +(** Shelves all the goals under focus. The goals are placed on the + shelf for later use (or being solved by side-effects). *) +val shelve : unit tactic + +(** Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +val shelve_unifiable : unit tactic + +(** [guard_no_unifiable] returns the list of unifiable goals if some + goals are unifiable (see {!shelve_unifiable}) in the current focus. *) +val guard_no_unifiable : Names.Name.t list option tactic + +(** [unshelve l p] adds all the goals in [l] at the end of the focused + goals of p *) +val unshelve : Goal.goal list -> proofview -> proofview + +(** [with_shelf tac] executes [tac] and returns its result together with the set + of goals shelved by [tac]. The current shelf is unchanged. *) +val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic + +(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] + is negative, then it puts the [n] last goals first.*) +val cycle : int -> unit tactic + +(** [swap i j] swaps the position of goals number [i] and [j] + (negative numbers can be used to address goals from the end. Goals + are indexed from [1]. For simplicity index [0] corresponds to goal + [1] as well, rather than raising an error. *) +val swap : int -> int -> unit tactic + +(** [revgoals] reverses the list of focused goals. *) +val revgoals : unit tactic + +(** [numgoals] returns the number of goals under focus. *) +val numgoals : int tactic + + +(** {7 Access primitives} *) + +(** [tclEVARMAP] doesn't affect the proof, it returns the current + [evar_map]. *) +val tclEVARMAP : Evd.evar_map tactic + +(** [tclENV] doesn't affect the proof, it returns the current + environment. It is not the environment of a particular goal, + rather the "global" environment of the proof. The goal-wise + environment is obtained via {!Proofview.Goal.env}. *) +val tclENV : Environ.env tactic + + +(** {7 Put-like primitives} *) + +(** [tclEFFECTS eff] add the effects [eff] to the current state. *) +val tclEFFECTS : Safe_typing.private_constants -> unit tactic + +(** [mark_as_unsafe] declares the current tactic is unsafe. *) +val mark_as_unsafe : unit tactic + +(** Gives up on the goal under focus. Reports an unsafe status. Proofs + with given up goals cannot be closed. *) +val give_up : unit tactic + + +(** {7 Control primitives} *) + +(** [tclPROGRESS t] checks the state of the proof after [t]. It it is + identical to the state before, then [tclePROGRESS t] fails, otherwise + it succeeds like [t]. *) +val tclPROGRESS : 'a tactic -> 'a tactic + +(** Checks for interrupts *) +val tclCHECKINTERRUPT : unit tactic + +exception Timeout +(** [tclTIMEOUT n t] can have only one success. + In case of timeout if fails with [tclZERO Timeout]. *) +val tclTIMEOUT : int -> 'a tactic -> 'a tactic + +(** [tclTIME s t] displays time for each atomic call to t, using s as an + identifying annotation if present *) +val tclTIME : string option -> 'a tactic -> 'a tactic + +(** {7 Unsafe primitives} *) + +(** The primitives in the [Unsafe] module should be avoided as much as + possible, since they can make the proof state inconsistent. They are + nevertheless helpful, in particular when interfacing the pretyping and + the proof engine. *) +module Unsafe : sig + + (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If + [sigma] has new unresolved [evar]-s they will not appear as + goal. If goals have been solved in [sigma] they will still + appear as unsolved goals. *) + val tclEVARS : Evd.evar_map -> unit tactic + + (** Like {!tclEVARS} but also checks whether goals have been solved. *) + val tclEVARSADVANCE : Evd.evar_map -> unit tactic + + (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently + being proved, appending them to the list of focused goals. If a + goal is already solved, it is not added. *) + val tclNEWGOALS : Goal.goal list -> unit tactic + + (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a + goal is already solved, it is not set. *) + val tclSETGOALS : Goal.goal list -> unit tactic + + (** [tclGETGOALS] returns the list of goals under focus. *) + val tclGETGOALS : Goal.goal list tactic + + (** Sets the evar universe context. *) + val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic + + (** Clears the future goals store in the proof view. *) + val reset_future_goals : proofview -> proofview + + (** Give an evar the status of a goal (changes its source location + and makes it unresolvable for type classes. *) + val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map + + (** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) + val advance : Evd.evar_map -> Evar.t -> Evar.t option +end + +(** This module gives access to the innards of the monad. Its use is + restricted to very specific cases. *) +module UnsafeRepr : +sig + type state = Proofview_monad.Logical.Unsafe.state + val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t + val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic +end + +(** {6 Goal-dependent tactics} *) + +module Goal : sig + + (** Type of goals. + + The first parameter type is a phantom argument indicating whether the data + contained in the goal has been normalized w.r.t. the current sigma. If it + is the case, it is flagged [ `NF ]. You may still access the un-normalized + data using {!assume} if you known you do not rely on the assumption of + being normalized, at your own risk. + + The second parameter is a stage indicating where the goal belongs. See + module {!Sigma}. + *) + type ('a, 'r) t + + (** Assume that you do not need the goal to be normalized. *) + val assume : ('a, 'r) t -> ([ `NF ], 'r) t + + (** Normalises the argument goal. *) + val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic + + (** [concl], [hyps], [env] and [sigma] given a goal [gl] return + respectively the conclusion of [gl], the hypotheses of [gl], the + environment of [gl] (i.e. the global environment and the + hypotheses) and the current evar map. *) + val concl : ([ `NF ], 'r) t -> Term.constr + val hyps : ([ `NF ], 'r) t -> Context.Named.t + val env : ('a, 'r) t -> Environ.env + val sigma : ('a, 'r) t -> 'r Sigma.t + val extra : ('a, 'r) t -> Evd.Store.t + + (** Returns the goal's conclusion even if the goal is not + normalised. *) + val raw_concl : ('a, 'r) t -> Term.constr + + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } + + (** [nf_enter t] applies the goal-dependent tactic [t] in each goal + independently, in the manner of {!tclINDEPENDENT} except that + the current goal is also given as an argument to [t]. The goal + is normalised with respect to evars. *) + val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic + + (** Like {!nf_enter}, but does not normalize the goal beforehand. *) + val enter : ([ `LZ ], unit tactic) enter -> unit tactic + + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } + + (** A variant of {!enter} allows to work with a monotonic state. The evarmap + returned by the argument is put back into the current state before firing + the returned tactic. *) + val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic + + (** Like {!s_enter}, but normalizes the goal beforehand. *) + val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic + + (** Recover the list of current goals under focus, without evar-normalization. + FIXME: encapsulate the level in an existential type. *) + val goals : ([ `LZ ], 'r) t tactic list tactic + + (** Compatibility: avoid if possible *) + val goal : ([ `NF ], 'r) t -> Evar.t + + (** Every goal is valid at a later stage. FIXME: take a later evarmap *) + val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t + +end + + +(** {6 Trace} *) + +module Trace : sig + + (** [record_info_trace t] behaves like [t] except the [info] trace + is stored. *) + val record_info_trace : 'a tactic -> 'a tactic + + val log : Proofview_monad.lazy_msg -> unit tactic + val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic + + val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds + +end + + +(** {6 Non-logical state} *) + +(** The [NonLogical] module allows the execution of effects (including + I/O) in tactics (non-logical side-effects are not discarded at + failures). *) +module NonLogical : module type of Logic_monad.NonLogical + +(** [tclLIFT c] is a tactic which behaves exactly as [c]. *) +val tclLIFT : 'a NonLogical.t -> 'a tactic + + +(**/**) + +(*** Compatibility layer with <= 8.2 tactics ***) +module V82 : sig + type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma + val tactic : tac -> unit tactic + + (* normalises the evars in the goals, and stores the result in + solution. *) + val nf_evar_goals : unit tactic + + val has_unresolved_evar : proofview -> bool + + (* Main function in the implementation of Grab Existential Variables. + Resets the proofview's goals so that it contains all unresolved evars + (in chronological order of insertion). *) + val grab : proofview -> proofview + + (* Returns the open goals of the proofview together with the evar_map to + interpret them. *) + val goals : proofview -> Evar.t list Evd.sigma + + val top_goals : entry -> proofview -> Evar.t list Evd.sigma + + (* returns the existential variable used to start the proof *) + val top_evars : entry -> Evd.evar list + + (* Caution: this function loses quite a bit of information. It + should be avoided as much as possible. It should work as + expected for a tactic obtained from {!V82.tactic} though. *) + val of_tactic : 'a tactic -> tac + + (* marks as unsafe if the argument is [false] *) + val put_status : bool -> unit tactic + + (* exception for which it is deemed to be safe to transmute into + tactic failure. *) + val catchable_exception : exn -> bool + + (* transforms every Ocaml (catchable) exception into a failure in + the monad. *) + val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic +end + +(** {7 Notations} *) + +module Notations : sig + + (** {!tclBIND} *) + val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + (** {!tclTHEN} *) + val (<*>) : unit tactic -> 'a tactic -> 'a tactic + (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) + val (<+>) : 'a tactic -> 'a tactic -> 'a tactic + + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } +end diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 236d479320..9130a186ba 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -4,7 +4,6 @@ Evar_refiner Proof_using Proof_errors Logic -Proofview Refine Proof Proof_global diff --git a/proofs/proofview.ml b/proofs/proofview.ml deleted file mode 100644 index 20be02e76d..0000000000 --- a/proofs/proofview.ml +++ /dev/null @@ -1,1204 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* i+1) solution 0 in - let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in - let pruned_solution = Evd.drop_all_defined solution in - let apply_subst_einfo _ ei = - Evd.({ ei with - evar_concl = nf ei.evar_concl; - evar_hyps = Environ.map_named_val nf ei.evar_hyps; - evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in - let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in - let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in - msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); - new_el, { pv with solution = new_solution; } - - -(** {6 Starting and querying a proof view} *) - -type telescope = - | TNil of Evd.evar_map - | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) - -let dependent_init = - (* Goals are created with a store which marks them as unresolvable - for type classes. *) - let store = Typeclasses.set_resolvable Evd.Store.empty false in - (* Goals don't have a source location. *) - let src = (Loc.ghost,Evar_kinds.GoalEvar) in - (* Main routine *) - let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } - | TCons (env, sigma, typ, t) -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in - let sigma = Sigma.to_evar_map sigma in - let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in - let (gl, _) = Term.destEvar econstr in - let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = gl :: comb; shelf = [] } - in - fun t -> - let entry, v = aux t in - (* The created goal are not to be shelved. *) - let solution = Evd.reset_future_goals v.solution in - entry, { v with solution } - -let init = - let rec aux sigma = function - | [] -> TNil sigma - | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l)) - in - fun sigma l -> dependent_init (aux sigma l) - -let initial_goals initial = initial - -let finished = function - | {comb = []} -> true - | _ -> false - -let return { solution=defs } = defs - -let return_constr { solution = defs } c = Evarutil.nf_evar defs c - -let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry) - - -(** {6 Focusing commands} *) - -(** A [focus_context] represents the part of the proof view which has - been removed by a focusing action, it can be used to unfocus later - on. *) -(* First component is a reverse list of the goals which come before - and second component is the list of the goals which go after (in - the expected order). *) -type focus_context = Evar.t list * Evar.t list - - -(** Returns a stylised view of a focus_context for use by, for - instance, ide-s. *) -(* spiwack: the type of [focus_context] will change as we push more - refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) -(* In this version: the goals in the context, as a "zipper" (the first - list is in reversed order). *) -let focus_context f = f - -(** This (internal) function extracts a sublist between two indices, - and returns this sublist together with its context: if it returns - [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the - original list. The focused list has lenght [j-i-1] and contains - the goals from number [i] to number [j] (both included) the first - goal of the list being numbered [1]. [focus_sublist i j l] raises - [IndexOutOfRange] if [i > length l], or [j > length l] or [j < - i]. *) -let focus_sublist i j l = - let (left,sub_right) = CList.goto (i-1) l in - let (sub, right) = - try CList.chop (j-i+1) sub_right - with Failure _ -> raise CList.IndexOutOfRange - in - (sub, (left,right)) - -(** Inverse operation to the previous one. *) -let unfocus_sublist (left,right) s = - CList.rev_append left (s@right) - - -(** [focus i j] focuses a proofview on the goals from index [i] to - index [j] (inclusive, goals are indexed from [1]). I.e. goals - number [i] to [j] become the only focused goals of the returned - proofview. It returns the focused proofview, and a context for - the focus stack. *) -let focus i j sp = - let (new_comb, context) = focus_sublist i j sp.comb in - ( { sp with comb = new_comb } , context ) - - -(** [advance sigma g] returns [Some g'] if [g'] is undefined and is - the current avatar of [g] (for instance [g] was changed by [clear] - into [g']). It returns [None] if [g] has been (partially) - solved. *) -(* spiwack: [advance] is probably performance critical, and the good - behaviour of its definition may depend sensitively to the actual - definition of [Evd.find]. Currently, [Evd.find] starts looking for - a value in the heap of undefined variable, which is small. Hence in - the most common case, where [advance] is applied to an unsolved - goal ([advance] is used to figure if a side effect has modified the - goal) it terminates quickly. *) -let rec advance sigma g = - let open Evd in - let evi = Evd.find sigma g in - match evi.evar_body with - | Evar_empty -> Some g - | Evar_defined v -> - if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then - let (e,_) = Term.destEvar v in - advance sigma e - else - None - -(** [undefined defs l] is the list of goals in [l] which are still - unsolved (after advancing cleared goals). *) -let undefined defs l = CList.map_filter (advance defs) l - -(** Unfocuses a proofview with respect to a context. *) -let unfocus c sp = - { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } - - -(** {6 The tactic monad} *) - -(** - Tactics are objects which apply a transformation to all the - subgoals of the current view at the same time. By opposition to - the old vision of applying it to a single goal. It allows tactics - such as [shelve_unifiable], tactics to reorder the focused goals, - or global automation tactic for dependent subgoals (instantiating - an evar has influences on the other goals of the proof in - progress, not being able to take that into account causes the - current eauto tactic to fail on some instances where it could - succeed). Another benefit is that it is possible to write tactics - that can be executed even if there are no focused goals. - - Tactics form a monad ['a tactic], in a sense a tactic can be - seen as a function (without argument) which returns a value of - type 'a and modifies the environment (in our case: the view). - Tactics of course have arguments, but these are given at the - meta-level as OCaml functions. Most tactics in the sense we are - used to return [()], that is no really interesting values. But - some might pass information around. The tactics seen in Coq's - Ltac are (for now at least) only [unit tactic], the return values - are kept for the OCaml toolkit. The operation or the monad are - [Proofview.tclUNIT] (which is the "return" of the tactic monad) - [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] - (which is a specialized bind on unit-returning tactics). - - Tactics have support for full-backtracking. Tactics can be seen - having multiple success: if after returning the first success a - failure is encountered, the tactic can backtrack and use a second - success if available. The state is backtracked to its previous - value, except the non-logical state defined in the {!NonLogical} - module below. -*) -(* spiwack: as far as I'm aware this doesn't really relate to - F. Kirchner and C. Muñoz. *) - -module Proof = Logical - -(** type of tactics: - - tactics can - - access the environment, - - report unsafe status, shelved goals and given up goals - - access and change the current [proofview] - - backtrack on previous changes of the proofview *) -type +'a tactic = 'a Proof.t - -(** Applies a tactic to the current proofview. *) -let apply env t sp = - let open Logic_monad in - let ans = Proof.repr (Proof.run t false (sp,env)) in - let ans = Logic_monad.NonLogical.run ans in - match ans with - | Nil (e, info) -> iraise (TacticFailure e, info) - | Cons ((r, (state, _), status, info), _) -> - let (status, gaveup) = status in - let status = (status, state.shelf, gaveup) in - let state = { state with shelf = [] } in - r, state, status, Trace.to_tree info - - - -(** {7 Monadic primitives} *) - -(** Unit of the tactic monad. *) -let tclUNIT = Proof.return - -(** Bind operation of the tactic monad. *) -let tclBIND = Proof.(>>=) - -(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, - it's a specialized "bind". *) -let tclTHEN = Proof.(>>) - -(** [tclIGNORE t] has the same operational content as [t], but drops - the returned value. *) -let tclIGNORE = Proof.ignore - -module Monad = Proof - - - -(** {7 Failure and backtracking} *) - - -(** [tclZERO e] fails with exception [e]. It has no success. *) -let tclZERO ?info e = - let info = match info with - | None -> Exninfo.null - | Some info -> info - in - Proof.zero (e, info) - -(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever - the successes of [t1] have been depleted and it failed with [e], - then it behaves as [t2 e]. In other words, [tclOR] inserts a - backtracking point. *) -let tclOR = Proof.plus - -(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one - success or [t2 e] if [t1] fails with [e]. It is analogous to - [try/with] handler of exception in that it is not a backtracking - point. *) -let tclORELSE t1 t2 = - let open Logic_monad in - let open Proof in - split t1 >>= function - | Nil e -> t2 e - | Cons (a,t1') -> plus (return a) t1' - -(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] - succeeds at least once then it behaves as [tclBIND a s] otherwise, - if [a] fails with [e], then it behaves as [f e]. *) -let tclIFCATCH a s f = - let open Logic_monad in - let open Proof in - split a >>= function - | Nil e -> f e - | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x')) - -(** [tclONCE t] behave like [t] except it has at most one success: - [tclONCE t] stops after the first success of [t]. If [t] fails - with [e], [tclONCE t] also fails with [e]. *) -let tclONCE = Proof.once - -exception MoreThanOneSuccess -let _ = Errors.register_handler begin function - | MoreThanOneSuccess -> Errors.error "This tactic has more than one success." - | _ -> raise Errors.Unhandled -end - -(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one - success. Otherwise it fails. The tactic [t] is run until its first - success, then a failure with exception [e] is simulated. It [t] - yields another success, then [tclEXACTLY_ONCE e t] fails with - [MoreThanOneSuccess] (it is a user error). Otherwise, - [tclEXACTLY_ONCE e t] succeeds with the first success of - [t]. Notice that the choice of [e] is relevant, as the presence of - further successes may depend on [e] (see {!tclOR}). *) -let tclEXACTLY_ONCE e t = - let open Logic_monad in - let open Proof in - split t >>= function - | Nil (e, info) -> tclZERO ~info e - | Cons (x,k) -> - Proof.split (k (e, Exninfo.null)) >>= function - | Nil _ -> tclUNIT x - | _ -> tclZERO MoreThanOneSuccess - - -(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) -type 'a case = -| Fail of iexn -| Next of 'a * (iexn -> 'a tactic) -let tclCASE t = - let open Logic_monad in - let map = function - | Nil e -> Fail e - | Cons (x, t) -> Next (x, t) - in - Proof.map map (Proof.split t) - -let tclBREAK = Proof.break - - - -(** {7 Focusing tactics} *) - -exception NoSuchGoals of int - -(* This hook returns a string to be appended to the usual message. - Primarily used to add a suggestion about the right bullet to use to - focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) -let set_nosuchgoals_hook f = nosuchgoals_hook := f - - - -(* This uses the hook above *) -let _ = Errors.register_handler begin function - | NoSuchGoals n -> - let suffix = !nosuchgoals_hook n in - Errors.errorlabstrm "" - (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) - | _ -> raise Errors.Unhandled -end - -(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where - only the goals numbered [i] to [j] are focused (the rest of the goals - is restored at the end of the tactic). If the range [i]-[j] is not - valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) -let tclFOCUS_gen nosuchgoal i j t = - let open Proof in - Pv.get >>= fun initial -> - try - let (focused,context) = focus i j initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - with CList.IndexOutOfRange -> nosuchgoal - -let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t -let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t - -(** Like {!tclFOCUS} but selects a single goal by name. *) -let tclFOCUSID id t = - let open Proof in - Pv.get >>= fun initial -> - try - let ev = Evd.evar_key id initial.solution in - try - let n = CList.index Evar.equal ev initial.comb in - (* goal is already under focus *) - let (focused,context) = focus n n initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - with Not_found -> - (* otherwise, save current focus and work purely on the shelve *) - Comb.set [ev] >> - t >>= fun result -> - Comb.set initial.comb >> - return result - with Not_found -> tclZERO (NoSuchGoals 1) - -(** {7 Dispatching on goals} *) - -exception SizeMismatch of int*int -let _ = Errors.register_handler begin function - | SizeMismatch (i,_) -> - let open Pp in - let errmsg = - str"Incorrect number of goals" ++ spc() ++ - str"(expected "++int i++str(String.plural i " tactic") ++ str")." - in - Errors.errorlabstrm "" errmsg - | _ -> raise Errors.Unhandled -end - -(** A variant of [Monad.List.iter] where we iter over the focused list - of goals. The argument tactic is executed in a focus comprising - only of the current goal, a goal which has been solved by side - effect is skipped. The generated subgoals are concatenated in - order. *) -let iter_goal i = - let open Proof in - Comb.get >>= fun initial -> - Proof.List.fold_left begin fun (subgoals as cur) goal -> - Solution.get >>= fun step -> - match advance step goal with - | None -> return cur - | Some goal -> - Comb.set [goal] >> - i goal >> - Proof.map (fun comb -> comb :: subgoals) Comb.get - end [] initial >>= fun subgoals -> - Solution.get >>= fun evd -> - Comb.set CList.(undefined evd (flatten (rev subgoals))) - -(** A variant of [Monad.List.fold_left2] where the first list is the - list of focused goals. The argument tactic is executed in a focus - comprising only of the current goal, a goal which has been solved - by side effect is skipped. The generated subgoals are concatenated - in order. *) -let fold_left2_goal i s l = - let open Proof in - Pv.get >>= fun initial -> - let err = - return () >>= fun () -> (* Delay the computation of list lengths. *) - tclZERO (SizeMismatch (CList.length initial.comb,CList.length l)) - in - Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> - Solution.get >>= fun step -> - match advance step goal with - | None -> return cur - | Some goal -> - Comb.set [goal] >> - i goal a r >>= fun r -> - Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get - end (s,[]) initial.comb l >>= fun (r,subgoals) -> - Solution.get >>= fun evd -> - Comb.set CList.(undefined evd (flatten (rev subgoals))) >> - return r - -(** Dispatch tacticals are used to apply a different tactic to each - goal under focus. They come in two flavours: [tclDISPATCH] takes a - list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] - takes a list of ['a tactic] and returns an ['a list tactic]. - - They both work by applying each of the tactic in a focus - restricted to the corresponding goal (starting with the first - goal). In the case of [tclDISPATCHL], the tactic returns a list of - the same size as the argument list (of tactics), each element - being the result of the tactic executed in the corresponding goal. - - When the length of the tactic list is not the number of goal, - raises [SizeMismatch (g,t)] where [g] is the number of available - goals, and [t] the number of tactics passed. - - [tclDISPATCHGEN join tacs] generalises both functions as the - successive results of [tacs] are stored in reverse order in a - list, and [join] is used to convert the result into the expected - form. *) -let tclDISPATCHGEN0 join tacs = - match tacs with - | [] -> - begin - let open Proof in - Comb.get >>= function - | [] -> tclUNIT (join []) - | comb -> tclZERO (SizeMismatch (CList.length comb,0)) - end - | [tac] -> - begin - let open Proof in - Pv.get >>= function - | { comb=[goal] ; solution } -> - begin match advance solution goal with - | None -> tclUNIT (join []) - | Some _ -> Proof.map (fun res -> join [res]) tac - end - | {comb} -> tclZERO (SizeMismatch(CList.length comb,1)) - end - | _ -> - let iter _ t cur = Proof.map (fun y -> y :: cur) t in - let ans = fold_left2_goal iter [] tacs in - Proof.map join ans - -let tclDISPATCHGEN join tacs = - let branch t = InfoL.tag (Info.DBranch) t in - let tacs = CList.map branch tacs in - InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs) - -let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs - -let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs - - -(** [extend_to_list startxs rx endxs l] builds a list - [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises - [SizeMismatch] if [startxs@endxs] is already longer than [l]. *) -let extend_to_list startxs rx endxs l = - (* spiwack: I use [l] essentially as a natural number *) - let rec duplicate acc = function - | [] -> acc - | _::rest -> duplicate (rx::acc) rest - in - let rec tail to_match rest = - match rest, to_match with - | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) - | _::rest , _::to_match -> tail to_match rest - | _ , [] -> duplicate endxs rest - in - let rec copy pref rest = - match rest,pref with - | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) - | _::rest, a::pref -> a::(copy pref rest) - | _ , [] -> tail endxs rest - in - copy startxs l - -(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] - tactic is "repeated" enough time such that every goal has a tactic - assigned to it ([b] is the list of tactics applied to the first - goals, [e] to the last goals, and [r] is applied to every goal in - between). *) -let tclEXTEND tacs1 rtac tacs2 = - let open Proof in - Comb.get >>= fun comb -> - try - let tacs = extend_to_list tacs1 rtac tacs2 comb in - tclDISPATCH tacs - with SizeMismatch _ -> - tclZERO (SizeMismatch( - CList.length comb, - (CList.length tacs1)+(CList.length tacs2))) -(* spiwack: failure occurs only when the number of goals is too - small. Hence we can assume that [rtac] is replicated 0 times for - any error message. *) - -(** [tclEXTEND [] tac []]. *) -let tclINDEPENDENT tac = - let open Proof in - Pv.get >>= fun initial -> - match initial.comb with - | [] -> tclUNIT () - | [_] -> tac - | _ -> - let tac = InfoL.tag (Info.DBranch) tac in - InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac)) - - - -(** {7 Goal manipulation} *) - -(** Shelves all the goals under focus. *) -let shelve = - let open Proof in - Comb.get >>= fun initial -> - Comb.set [] >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> - Shelf.modify (fun gls -> gls @ initial) - - -(** [contained_in_info e evi] checks whether the evar [e] appears in - the hypotheses, the conclusion or the body of the evar_info - [evi]. Note: since we want to use it on goals, the body is actually - supposed to be empty. *) -let contained_in_info sigma e evi = - Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) - -(** [depends_on sigma src tgt] checks whether the goal [src] appears - as an existential variable in the definition of the goal [tgt] in - [sigma]. *) -let depends_on sigma src tgt = - let evi = Evd.find sigma tgt in - contained_in_info sigma src evi - -(** [unifiable sigma g l] checks whether [g] appears in another - subgoal of [l]. The list [l] may contain [g], but it does not - affect the result. *) -let unifiable sigma g l = - CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l - -(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] - where [u] is composed of the unifiable goals, i.e. the goals on - whose definition other goals of [l] depend, and [n] are the - non-unifiable goals. *) -let partition_unifiable sigma l = - CList.partition (fun g -> unifiable sigma g l) l - -(** Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -let shelve_unifiable = - let open Proof in - Pv.get >>= fun initial -> - let (u,n) = partition_unifiable initial.solution initial.comb in - Comb.set n >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> - Shelf.modify (fun gls -> gls @ u) - -(** [guard_no_unifiable] returns the list of unifiable goals if some - goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -let guard_no_unifiable = - let open Proof in - Pv.get >>= fun initial -> - let (u,n) = partition_unifiable initial.solution initial.comb in - match u with - | [] -> tclUNIT None - | gls -> - let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in - let l = CList.map (fun id -> Names.Name id) l in - tclUNIT (Some l) - -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) -let unshelve l p = - (* advance the goals in case of clear *) - let l = undefined p.solution l in - { p with comb = p.comb@l } - -let with_shelf tac = - let open Proof in - Pv.get >>= fun pv -> - let { shelf; solution } = pv in - Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> - tac >>= fun ans -> - Pv.get >>= fun npv -> - let { shelf = gls; solution = sigma } = npv in - let gls' = Evd.future_goals sigma in - let fgoals = Evd.future_goals solution in - let pgoal = Evd.principal_future_goal solution in - let sigma = Evd.restore_future_goals sigma fgoals pgoal in - Pv.set { npv with shelf; solution = sigma } >> - tclUNIT (CList.rev_append gls' gls, ans) - -(** [goodmod p m] computes the representative of [p] modulo [m] in the - interval [[0,m-1]].*) -let goodmod p m = - let p' = p mod m in - (* if [n] is negative [n mod l] is negative of absolute value less - than [l], so [(n mod l)+l] is the representative of [n] in the - interval [[0,l-1]].*) - if p' < 0 then p'+m else p' - -let cycle n = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> - Comb.modify begin fun initial -> - let l = CList.length initial in - let n' = goodmod n l in - let (front,rear) = CList.chop n' initial in - rear@front - end - -let swap i j = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> - Comb.modify begin fun initial -> - let l = CList.length initial in - let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in - let i = goodmod i l and j = goodmod j l in - CList.map_i begin fun k x -> - match k with - | k when Int.equal k i -> CList.nth initial j - | k when Int.equal k j -> CList.nth initial i - | _ -> x - end 0 initial - end - -let revgoals = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> - Comb.modify CList.rev - -let numgoals = - let open Proof in - Comb.get >>= fun comb -> - return (CList.length comb) - - - -(** {7 Access primitives} *) - -let tclEVARMAP = Solution.get - -let tclENV = Env.get - - - -(** {7 Put-like primitives} *) - - -let emit_side_effects eff x = - { x with solution = Evd.emit_side_effects eff x.solution } - -let tclEFFECTS eff = - let open Proof in - return () >>= fun () -> (* The Global.env should be taken at exec time *) - Env.set (Global.env ()) >> - Pv.modify (fun initial -> emit_side_effects eff initial) - -let mark_as_unsafe = Status.put false - -(** Gives up on the goal under focus. Reports an unsafe status. Proofs - with given up goals cannot be closed. *) -let give_up = - let open Proof in - Comb.get >>= fun initial -> - Comb.set [] >> - mark_as_unsafe >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> - Giveup.put initial - - - -(** {7 Control primitives} *) - - -module Progress = struct - - let eq_constr = Evarutil.eq_constr_univs_test - - (** equality function on hypothesis contexts *) - let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = - let open Environ in - let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in - let eq_named_declaration d1 d2 = - match d1, d2 with - | LocalAssum (i1,t1), LocalAssum (i2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 - | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 - && eq_constr sigma1 sigma2 t1 t2 - | _ -> - false - in List.equal eq_named_declaration c1 c2 - - let eq_evar_body sigma1 sigma2 b1 b2 = - let open Evd in - match b1, b2 with - | Evar_empty, Evar_empty -> true - | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2 - | _ -> false - - let eq_evar_info sigma1 sigma2 ei1 ei2 = - let open Evd in - eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl && - eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) && - eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body - - (** Equality function on goals *) - let goal_equal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 gl1 in - let evi2 = Evd.find evars2 gl2 in - eq_evar_info evars1 evars2 evi1 evi2 - -end - -let tclPROGRESS t = - let open Proof in - Pv.get >>= fun initial -> - t >>= fun res -> - Pv.get >>= fun final -> - (* [*_test] test absence of progress. [quick_test] is approximate - whereas [exhaustive_test] is complete. *) - let quick_test = - initial.solution == final.solution && initial.comb == final.comb - in - let exhaustive_test = - Util.List.for_all2eq begin fun i f -> - Progress.goal_equal initial.solution i final.solution f - end initial.comb final.comb - in - let test = - quick_test || exhaustive_test - in - if not test then - tclUNIT res - else - tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) - -exception Timeout -let _ = Errors.register_handler begin function - | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") - | _ -> Pervasives.raise Errors.Unhandled -end - -let tclTIMEOUT n t = - let open Proof in - (* spiwack: as one of the monad is a continuation passing monad, it - doesn't force the computation to be threaded inside the underlying - (IO) monad. Hence I force it myself by asking for the evaluation of - a dummy value first, lest [timeout] be called when everything has - already been computed. *) - let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in - Proof.get >>= fun initial -> - Proof.current >>= fun envvar -> - Proof.lift begin - Logic_monad.NonLogical.catch - begin - let open Logic_monad.NonLogical in - timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> - match r with - | Logic_monad.Nil e -> return (Util.Inr e) - | Logic_monad.Cons (r, _) -> return (Util.Inl r) - end - begin let open Logic_monad.NonLogical in function (e, info) -> - match e with - | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) - | Logic_monad.TacticFailure e -> - return (Util.Inr (e, info)) - | e -> Logic_monad.NonLogical.raise ~info e - end - end >>= function - | Util.Inl (res,s,m,i) -> - Proof.set s >> - Proof.put m >> - Proof.update (fun _ -> i) >> - return res - | Util.Inr (e, info) -> tclZERO ~info e - -let tclTIME s t = - let pr_time t1 t2 n msg = - let msg = - if n = 0 then - str msg - else - str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking") - in - msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ - System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in - let rec aux n t = - let open Proof in - tclUNIT () >>= fun () -> - let tstart = System.get_time() in - Proof.split t >>= let open Logic_monad in function - | Nil (e, info) -> - begin - let tend = System.get_time() in - pr_time tstart tend n "failure"; - tclZERO ~info e - end - | Cons (x,k) -> - let tend = System.get_time() in - pr_time tstart tend n "success"; - tclOR (tclUNIT x) (fun e -> aux (n+1) (k e)) - in aux 0 t - - - -(** {7 Unsafe primitives} *) - -module Unsafe = struct - - let tclEVARS evd = - Pv.modify (fun ps -> { ps with solution = evd }) - - let tclNEWGOALS gls = - Pv.modify begin fun step -> - let gls = undefined step.solution gls in - { step with comb = step.comb @ gls } - end - - let tclGETGOALS = Comb.get - - let tclSETGOALS = Comb.set - - let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) - - let tclEVARUNIVCONTEXT ctx = - Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) - - let reset_future_goals p = - { p with solution = Evd.reset_future_goals p.solution } - - let mark_as_goal evd content = - let info = Evd.find evd content in - let info = - { info with Evd.evar_source = match info.Evd.evar_source with - | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x - | loc,_ -> loc,Evar_kinds.GoalEvar } - in - let info = Typeclasses.mark_unresolvable info in - Evd.add evd content info - - let advance = advance - -end - -module UnsafeRepr = Proof.Unsafe - -let (>>=) = tclBIND -let (<*>) = tclTHEN -let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - -(** {6 Goal-dependent tactics} *) - -let goal_env evars gl = - let evi = Evd.find evars gl in - Evd.evar_filtered_env evi - -let goal_nf_evar sigma gl = - let evi = Evd.find sigma gl in - let evi = Evarutil.nf_evar_info sigma evi in - let sigma = Evd.add sigma gl evi in - (gl, sigma) - -let goal_extra evars gl = - let evi = Evd.find evars gl in - evi.Evd.evar_extra - - -let catchable_exception = function - | Logic_monad.Exception _ -> false - | e -> Errors.noncritical e - - -module Goal = struct - - type ('a, 'r) t = { - env : Environ.env; - sigma : Evd.evar_map; - concl : Term.constr ; - self : Evar.t ; (* for compatibility with old-style definitions *) - } - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } - - let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) - - let env { env=env } = env - let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma - let hyps { env=env } = Environ.named_context env - let concl { concl=concl } = concl - let extra { sigma=sigma; self=self } = goal_extra sigma self - - let raw_concl { concl=concl } = concl - - - let gmake_with info env sigma goal = - { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ; - sigma = sigma ; - concl = Evd.evar_concl info ; - self = goal } - - let nf_gmake env sigma goal = - let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in - let sigma = Evd.add sigma goal info in - gmake_with info env sigma goal , sigma - - let nf_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let (gl, sigma) = nf_gmake env sigma goal in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let normalize { self } = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - let (gl,sigma) = nf_gmake env sigma self in - tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) - - let gmake env sigma goal = - let info = Evd.find sigma goal in - gmake_with info env sigma goal - - let enter f = - let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try f (gmake env sigma goal) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - let s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let gl = gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let nf_s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let (gl, sigma) = nf_gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let goals = - Pv.get >>= fun step -> - let sigma = step.solution in - let map goal = - match advance sigma goal with - | None -> None (** ppedrot: Is this check really necessary? *) - | Some goal -> - let gl = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - tclUNIT (gmake env sigma goal) - in - Some gl - in - tclUNIT (CList.map_filter map step.comb) - - (* compatibility *) - let goal { self=self } = self - - let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) - -end - - - -(** {6 Trace} *) - -module Trace = struct - - let record_info_trace = InfoL.record_trace - - let log m = InfoL.leaf (Info.Msg m) - let name_tactic m t = InfoL.tag (Info.Tactic m) t - - let pr_info ?(lvl=0) info = - assert (lvl >= 0); - Info.(print (collapse lvl info)) - -end - - - -(** {6 Non-logical state} *) - -module NonLogical = Logic_monad.NonLogical - -let tclLIFT = Proof.lift - -let tclCHECKINTERRUPT = - tclLIFT (NonLogical.make Control.check_for_interrupt) - - - - - -(*** Compatibility layer with <= 8.2 tactics ***) -module V82 = struct - type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma - - let tactic tac = - (* spiwack: we ignore the dependencies between goals here, - expectingly preserving the semantics of <= 8.2 tactics *) - (* spiwack: convenience notations, waiting for ocaml 3.12 *) - let open Proof in - Pv.get >>= fun ps -> - try - let tac gl evd = - let glsigma = - tac { Evd.it = gl ; sigma = evd; } in - let sigma = glsigma.Evd.sigma in - let g = glsigma.Evd.it in - ( g, sigma ) - in - (* Old style tactics expect the goals normalized with respect to evars. *) - let (initgoals,initevd) = - Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution - in - let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in - let sgs = CList.flatten goalss in - let sgs = undefined evd sgs in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> - Pv.set { ps with solution = evd; comb = sgs; } - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - - - (* normalises the evars in the goals, and stores the result in - solution. *) - let nf_evar_goals = - Pv.modify begin fun ps -> - let map g s = goal_nf_evar s g in - let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in - { ps with solution = evd; comb = goals; } - end - - let has_unresolved_evar pv = - Evd.has_undefined pv.solution - - (* Main function in the implementation of Grab Existential Variables.*) - let grab pv = - let undef = Evd.undefined_map pv.solution in - let goals = CList.rev_map fst (Evar.Map.bindings undef) in - { pv with comb = goals } - - - - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - let goals { comb = comb ; solution = solution; } = - { Evd.it = comb ; sigma = solution } - - let top_goals initial { solution=solution; } = - let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in - { Evd.it = goals ; sigma=solution; } - - let top_evars initial = - let evars_of_initial (c,_) = - Evar.Set.elements (Evd.evars_of_term c) - in - CList.flatten (CList.map evars_of_initial initial) - - let of_tactic t gls = - try - let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in - let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in - { Evd.sigma = final.solution ; it = final.comb } - with Logic_monad.TacticFailure e as src -> - let (_, info) = Errors.push src in - iraise (e, info) - - let put_status = Status.put - - let catchable_exception = catchable_exception - - let wrap_exceptions f = - try f () - with e when catchable_exception e -> - let (e, info) = Errors.push e in tclZERO ~info e - -end - -(** {7 Notations} *) - -module Notations = struct - let (>>=) = tclBIND - let (<*>) = tclTHEN - let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } -end diff --git a/proofs/proofview.mli b/proofs/proofview.mli deleted file mode 100644 index 6bc2e9a0ed..0000000000 --- a/proofs/proofview.mli +++ /dev/null @@ -1,586 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Goal.goal list * Evd.evar_map - - -(** {6 Starting and querying a proof view} *) - -(** Abstract representation of the initial goals of a proof. *) -type entry - -(** Optimize memory consumption *) -val compact : entry -> proofview -> entry * proofview - -(** Initialises a proofview, the main argument is a list of - environments (including a [named_context] which are used as - hypotheses) pair with conclusion types, creating accordingly many - initial goals. Because a proof does not necessarily starts in an - empty [evar_map] (indeed a proof can be triggered by an incomplete - pretyping), [init] takes an additional argument to represent the - initial [evar_map]. *) -val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview - -(** A [telescope] is a list of environment and conclusion like in - {!init}, except that each element may depend on the previous - goals. The telescope passes the goals in the form of a - [Term.constr] which represents the goal as an [evar]. The - [evar_map] is threaded in state passing style. *) -type telescope = - | TNil of Evd.evar_map - | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) - -(** Like {!init}, but goals are allowed to be dependent on one - another. Dependencies between goals is represented with the type - [telescope] instead of [list]. Note that the first [evar_map] of - the telescope plays the role of the [evar_map] argument in - [init]. *) -val dependent_init : telescope -> entry * proofview - -(** [finished pv] is [true] if and only if [pv] is complete. That is, - if it has an empty list of focused goals. There could still be - unsolved subgoaled, but they would then be out of focus. *) -val finished : proofview -> bool - -(** Returns the current [evar] state. *) -val return : proofview -> Evd.evar_map - -val partial_proof : entry -> proofview -> constr list -val initial_goals : entry -> (constr * types) list - - - -(** {6 Focusing commands} *) - -(** A [focus_context] represents the part of the proof view which has - been removed by a focusing action, it can be used to unfocus later - on. *) -type focus_context - -(** Returns a stylised view of a focus_context for use by, for - instance, ide-s. *) -(* spiwack: the type of [focus_context] will change as we push more - refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) -(* In this version: the goals in the context, as a "zipper" (the first - list is in reversed order). *) -val focus_context : focus_context -> Goal.goal list * Goal.goal list - -(** [focus i j] focuses a proofview on the goals from index [i] to - index [j] (inclusive, goals are indexed from [1]). I.e. goals - number [i] to [j] become the only focused goals of the returned - proofview. It returns the focused proofview, and a context for - the focus stack. *) -val focus : int -> int -> proofview -> proofview * focus_context - -(** Unfocuses a proofview with respect to a context. *) -val unfocus : focus_context -> proofview -> proofview - - -(** {6 The tactic monad} *) - -(** - Tactics are objects which apply a transformation to all the - subgoals of the current view at the same time. By opposition to - the old vision of applying it to a single goal. It allows tactics - such as [shelve_unifiable], tactics to reorder the focused goals, - or global automation tactic for dependent subgoals (instantiating - an evar has influences on the other goals of the proof in - progress, not being able to take that into account causes the - current eauto tactic to fail on some instances where it could - succeed). Another benefit is that it is possible to write tactics - that can be executed even if there are no focused goals. - - Tactics form a monad ['a tactic], in a sense a tactic can be - seen as a function (without argument) which returns a value of - type 'a and modifies the environment (in our case: the view). - Tactics of course have arguments, but these are given at the - meta-level as OCaml functions. Most tactics in the sense we are - used to return [()], that is no really interesting values. But - some might pass information around. The tactics seen in Coq's - Ltac are (for now at least) only [unit tactic], the return values - are kept for the OCaml toolkit. The operation or the monad are - [Proofview.tclUNIT] (which is the "return" of the tactic monad) - [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] - (which is a specialized bind on unit-returning tactics). - - Tactics have support for full-backtracking. Tactics can be seen - having multiple success: if after returning the first success a - failure is encountered, the tactic can backtrack and use a second - success if available. The state is backtracked to its previous - value, except the non-logical state defined in the {!NonLogical} - module below. -*) - - -(** The abstract type of tactics *) -type +'a tactic - -(** Applies a tactic to the current proofview. Returns a tuple - [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv] - is the updated proofview, [b] a boolean which is [true] if the - tactic has not done any action considered unsafe (such as - admitting a lemma), [sh] is the list of goals which have been - shelved by the tactic, and [gu] the list of goals on which the - tactic has given up. In case of multiple success the first one is - selected. If there is no success, fails with - {!Logic_monad.TacticFailure}*) -val apply : Environ.env -> 'a tactic -> proofview -> 'a - * proofview - * (bool*Goal.goal list*Goal.goal list) - * Proofview_monad.Info.tree - -(** {7 Monadic primitives} *) - -(** Unit of the tactic monad. *) -val tclUNIT : 'a -> 'a tactic - -(** Bind operation of the tactic monad. *) -val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - -(** Interprets the ";" (semicolon) of Ltac. As a monadic operation, - it's a specialized "bind". *) -val tclTHEN : unit tactic -> 'a tactic -> 'a tactic - -(** [tclIGNORE t] has the same operational content as [t], but drops - the returned value. *) -val tclIGNORE : 'a tactic -> unit tactic - -(** Generic monadic combinators for tactics. *) -module Monad : Monad.S with type +'a t = 'a tactic - -(** {7 Failure and backtracking} *) - -(** [tclZERO e] fails with exception [e]. It has no success. *) -val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic - -(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever - the successes of [t1] have been depleted and it failed with [e], - then it behaves as [t2 e]. In other words, [tclOR] inserts a - backtracking point. *) -val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic - -(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one - success or [t2 e] if [t1] fails with [e]. It is analogous to - [try/with] handler of exception in that it is not a backtracking - point. *) -val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic - -(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] - succeeds at least once then it behaves as [tclBIND a s] otherwise, - if [a] fails with [e], then it behaves as [f e]. *) -val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic - -(** [tclONCE t] behave like [t] except it has at most one success: - [tclONCE t] stops after the first success of [t]. If [t] fails - with [e], [tclONCE t] also fails with [e]. *) -val tclONCE : 'a tactic -> 'a tactic - -(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one - success. Otherwise it fails. The tactic [t] is run until its first - success, then a failure with exception [e] is simulated. It [t] - yields another success, then [tclEXACTLY_ONCE e t] fails with - [MoreThanOneSuccess] (it is a user error). Otherwise, - [tclEXACTLY_ONCE e t] succeeds with the first success of - [t]. Notice that the choice of [e] is relevant, as the presence of - further successes may depend on [e] (see {!tclOR}). *) -exception MoreThanOneSuccess -val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic - -(** [tclCASE t] splits [t] into its first success and a - continuation. It is the most general primitive to control - backtracking. *) -type 'a case = - | Fail of iexn - | Next of 'a * (iexn -> 'a tactic) -val tclCASE : 'a tactic -> 'a case tactic - -(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of - stopping after the first success, it succeeds like [t] until a - failure with an exception [e] such that [p e = Some e'] is raised. At - which point it drops the remaining successes, failing with [e']. - [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *) -val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic - - -(** {7 Focusing tactics} *) - -(** [tclFOCUS i j t] applies [t] after focusing on the goals number - [i] to [j] (see {!focus}). The rest of the goals is restored after - the tactic action. If the specified range doesn't correspond to - existing goals, fails with [NoSuchGoals] (a user error). this - exception is caught at toplevel with a default message + a hook - message that can be customized by [set_nosuchgoals_hook] below. - This hook is used to add a suggestion about bullets when - applicable. *) -exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit - -val tclFOCUS : int -> int -> 'a tactic -> 'a tactic - -(** [tclFOCUSID x t] applies [t] on a (single) focused goal like - {!tclFOCUS}. The goal is found by its name rather than its - number.*) -val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic - -(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the - specified range doesn't correspond to existing goals, behaves like - [tclUNIT ()] instead of failing. *) -val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic - - -(** {7 Dispatching on goals} *) - -(** Dispatch tacticals are used to apply a different tactic to each - goal under focus. They come in two flavours: [tclDISPATCH] takes a - list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] - takes a list of ['a tactic] and returns an ['a list tactic]. - - They both work by applying each of the tactic in a focus - restricted to the corresponding goal (starting with the first - goal). In the case of [tclDISPATCHL], the tactic returns a list of - the same size as the argument list (of tactics), each element - being the result of the tactic executed in the corresponding goal. - - When the length of the tactic list is not the number of goal, - raises [SizeMismatch (g,t)] where [g] is the number of available - goals, and [t] the number of tactics passed. *) -exception SizeMismatch of int*int -val tclDISPATCH : unit tactic list -> unit tactic -val tclDISPATCHL : 'a tactic list -> 'a list tactic - -(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] - tactic is "repeated" enough time such that every goal has a tactic - assigned to it ([b] is the list of tactics applied to the first - goals, [e] to the last goals, and [r] is applied to every goal in - between). *) -val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic - -(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from - the first one to the last one. Backtracking in one goal is - independent of backtracking in another. It is equivalent to - [tclEXTEND [] tac []]. *) -val tclINDEPENDENT : unit tactic -> unit tactic - - -(** {7 Goal manipulation} *) - -(** Shelves all the goals under focus. The goals are placed on the - shelf for later use (or being solved by side-effects). *) -val shelve : unit tactic - -(** Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -val shelve_unifiable : unit tactic - -(** [guard_no_unifiable] returns the list of unifiable goals if some - goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -val guard_no_unifiable : Names.Name.t list option tactic - -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) -val unshelve : Goal.goal list -> proofview -> proofview - -(** [with_shelf tac] executes [tac] and returns its result together with the set - of goals shelved by [tac]. The current shelf is unchanged. *) -val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic - -(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] - is negative, then it puts the [n] last goals first.*) -val cycle : int -> unit tactic - -(** [swap i j] swaps the position of goals number [i] and [j] - (negative numbers can be used to address goals from the end. Goals - are indexed from [1]. For simplicity index [0] corresponds to goal - [1] as well, rather than raising an error. *) -val swap : int -> int -> unit tactic - -(** [revgoals] reverses the list of focused goals. *) -val revgoals : unit tactic - -(** [numgoals] returns the number of goals under focus. *) -val numgoals : int tactic - - -(** {7 Access primitives} *) - -(** [tclEVARMAP] doesn't affect the proof, it returns the current - [evar_map]. *) -val tclEVARMAP : Evd.evar_map tactic - -(** [tclENV] doesn't affect the proof, it returns the current - environment. It is not the environment of a particular goal, - rather the "global" environment of the proof. The goal-wise - environment is obtained via {!Proofview.Goal.env}. *) -val tclENV : Environ.env tactic - - -(** {7 Put-like primitives} *) - -(** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Safe_typing.private_constants -> unit tactic - -(** [mark_as_unsafe] declares the current tactic is unsafe. *) -val mark_as_unsafe : unit tactic - -(** Gives up on the goal under focus. Reports an unsafe status. Proofs - with given up goals cannot be closed. *) -val give_up : unit tactic - - -(** {7 Control primitives} *) - -(** [tclPROGRESS t] checks the state of the proof after [t]. It it is - identical to the state before, then [tclePROGRESS t] fails, otherwise - it succeeds like [t]. *) -val tclPROGRESS : 'a tactic -> 'a tactic - -(** Checks for interrupts *) -val tclCHECKINTERRUPT : unit tactic - -exception Timeout -(** [tclTIMEOUT n t] can have only one success. - In case of timeout if fails with [tclZERO Timeout]. *) -val tclTIMEOUT : int -> 'a tactic -> 'a tactic - -(** [tclTIME s t] displays time for each atomic call to t, using s as an - identifying annotation if present *) -val tclTIME : string option -> 'a tactic -> 'a tactic - -(** {7 Unsafe primitives} *) - -(** The primitives in the [Unsafe] module should be avoided as much as - possible, since they can make the proof state inconsistent. They are - nevertheless helpful, in particular when interfacing the pretyping and - the proof engine. *) -module Unsafe : sig - - (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If - [sigma] has new unresolved [evar]-s they will not appear as - goal. If goals have been solved in [sigma] they will still - appear as unsolved goals. *) - val tclEVARS : Evd.evar_map -> unit tactic - - (** Like {!tclEVARS} but also checks whether goals have been solved. *) - val tclEVARSADVANCE : Evd.evar_map -> unit tactic - - (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently - being proved, appending them to the list of focused goals. If a - goal is already solved, it is not added. *) - val tclNEWGOALS : Goal.goal list -> unit tactic - - (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a - goal is already solved, it is not set. *) - val tclSETGOALS : Goal.goal list -> unit tactic - - (** [tclGETGOALS] returns the list of goals under focus. *) - val tclGETGOALS : Goal.goal list tactic - - (** Sets the evar universe context. *) - val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic - - (** Clears the future goals store in the proof view. *) - val reset_future_goals : proofview -> proofview - - (** Give an evar the status of a goal (changes its source location - and makes it unresolvable for type classes. *) - val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map - - (** [advance sigma g] returns [Some g'] if [g'] is undefined and is - the current avatar of [g] (for instance [g] was changed by [clear] - into [g']). It returns [None] if [g] has been (partially) - solved. *) - val advance : Evd.evar_map -> Evar.t -> Evar.t option -end - -(** This module gives access to the innards of the monad. Its use is - restricted to very specific cases. *) -module UnsafeRepr : -sig - type state = Proofview_monad.Logical.Unsafe.state - val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t - val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic -end - -(** {6 Goal-dependent tactics} *) - -module Goal : sig - - (** Type of goals. - - The first parameter type is a phantom argument indicating whether the data - contained in the goal has been normalized w.r.t. the current sigma. If it - is the case, it is flagged [ `NF ]. You may still access the un-normalized - data using {!assume} if you known you do not rely on the assumption of - being normalized, at your own risk. - - The second parameter is a stage indicating where the goal belongs. See - module {!Sigma}. - *) - type ('a, 'r) t - - (** Assume that you do not need the goal to be normalized. *) - val assume : ('a, 'r) t -> ([ `NF ], 'r) t - - (** Normalises the argument goal. *) - val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic - - (** [concl], [hyps], [env] and [sigma] given a goal [gl] return - respectively the conclusion of [gl], the hypotheses of [gl], the - environment of [gl] (i.e. the global environment and the - hypotheses) and the current evar map. *) - val concl : ([ `NF ], 'r) t -> Term.constr - val hyps : ([ `NF ], 'r) t -> Context.Named.t - val env : ('a, 'r) t -> Environ.env - val sigma : ('a, 'r) t -> 'r Sigma.t - val extra : ('a, 'r) t -> Evd.Store.t - - (** Returns the goal's conclusion even if the goal is not - normalised. *) - val raw_concl : ('a, 'r) t -> Term.constr - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } - - (** [nf_enter t] applies the goal-dependent tactic [t] in each goal - independently, in the manner of {!tclINDEPENDENT} except that - the current goal is also given as an argument to [t]. The goal - is normalised with respect to evars. *) - val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic - - (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ], unit tactic) enter -> unit tactic - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - (** A variant of {!enter} allows to work with a monotonic state. The evarmap - returned by the argument is put back into the current state before firing - the returned tactic. *) - val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic - - (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic - - (** Recover the list of current goals under focus, without evar-normalization. - FIXME: encapsulate the level in an existential type. *) - val goals : ([ `LZ ], 'r) t tactic list tactic - - (** Compatibility: avoid if possible *) - val goal : ([ `NF ], 'r) t -> Evar.t - - (** Every goal is valid at a later stage. FIXME: take a later evarmap *) - val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t - -end - - -(** {6 Trace} *) - -module Trace : sig - - (** [record_info_trace t] behaves like [t] except the [info] trace - is stored. *) - val record_info_trace : 'a tactic -> 'a tactic - - val log : Proofview_monad.lazy_msg -> unit tactic - val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - - val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds - -end - - -(** {6 Non-logical state} *) - -(** The [NonLogical] module allows the execution of effects (including - I/O) in tactics (non-logical side-effects are not discarded at - failures). *) -module NonLogical : module type of Logic_monad.NonLogical - -(** [tclLIFT c] is a tactic which behaves exactly as [c]. *) -val tclLIFT : 'a NonLogical.t -> 'a tactic - - -(**/**) - -(*** Compatibility layer with <= 8.2 tactics ***) -module V82 : sig - type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma - val tactic : tac -> unit tactic - - (* normalises the evars in the goals, and stores the result in - solution. *) - val nf_evar_goals : unit tactic - - val has_unresolved_evar : proofview -> bool - - (* Main function in the implementation of Grab Existential Variables. - Resets the proofview's goals so that it contains all unresolved evars - (in chronological order of insertion). *) - val grab : proofview -> proofview - - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - val goals : proofview -> Evar.t list Evd.sigma - - val top_goals : entry -> proofview -> Evar.t list Evd.sigma - - (* returns the existential variable used to start the proof *) - val top_evars : entry -> Evd.evar list - - (* Caution: this function loses quite a bit of information. It - should be avoided as much as possible. It should work as - expected for a tactic obtained from {!V82.tactic} though. *) - val of_tactic : 'a tactic -> tac - - (* marks as unsafe if the argument is [false] *) - val put_status : bool -> unit tactic - - (* exception for which it is deemed to be safe to transmute into - tactic failure. *) - val catchable_exception : exn -> bool - - (* transforms every Ocaml (catchable) exception into a failure in - the monad. *) - val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic -end - -(** {7 Notations} *) - -module Notations : sig - - (** {!tclBIND} *) - val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - (** {!tclTHEN} *) - val (<*>) : unit tactic -> 'a tactic -> 'a tactic - (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) - val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } -end -- cgit v1.2.3 From 08c31f46aa05098e1a97d9144599c1e5072b7fc3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 19:52:54 +0100 Subject: Pushing Proofview further down the dependency alley. --- dev/printers.mllib | 6 +++--- pretyping/pretyping.mllib | 2 +- pretyping/proofview.ml | 11 +++++++++-- pretyping/proofview.mli | 3 +++ pretyping/typeclasses.ml | 2 +- 5 files changed, 17 insertions(+), 7 deletions(-) diff --git a/dev/printers.mllib b/dev/printers.mllib index c46f6b72a4..db86bb5edd 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -141,6 +141,9 @@ Find_subterm Tacred Classops Typeclasses_errors +Logic_monad +Proofview_monad +Proofview Typeclasses Detyping Indrec @@ -181,9 +184,6 @@ Refiner Clenv Evar_refiner Proof_errors -Logic_monad -Proofview_monad -Proofview Refine Proof Proof_global diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 5dfdd0379a..b0d5a1df6a 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -20,8 +20,8 @@ Patternops Constr_matching Tacred Typeclasses_errors -Typeclasses Proofview +Typeclasses Classops Program Coercion diff --git a/pretyping/proofview.ml b/pretyping/proofview.ml index 20be02e76d..ba664cafaf 100644 --- a/pretyping/proofview.ml +++ b/pretyping/proofview.ml @@ -56,10 +56,12 @@ type telescope = | TNil of Evd.evar_map | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) +let typeclass_resolvable = Evd.Store.field () + let dependent_init = (* Goals are created with a store which marks them as unresolvable for type classes. *) - let store = Typeclasses.set_resolvable Evd.Store.empty false in + let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in (* Goals don't have a source location. *) let src = (Loc.ghost,Evar_kinds.GoalEvar) in (* Main routine *) @@ -908,11 +910,16 @@ module Unsafe = struct | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x | loc,_ -> loc,Evar_kinds.GoalEvar } in - let info = Typeclasses.mark_unresolvable info in + let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with + | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } + | Some () -> info + in Evd.add evd content info let advance = advance + let typeclass_resolvable = typeclass_resolvable + end module UnsafeRepr = Proof.Unsafe diff --git a/pretyping/proofview.mli b/pretyping/proofview.mli index 6bc2e9a0ed..7996b7969c 100644 --- a/pretyping/proofview.mli +++ b/pretyping/proofview.mli @@ -413,6 +413,9 @@ module Unsafe : sig into [g']). It returns [None] if [g] has been (partially) solved. *) val advance : Evd.evar_map -> Evar.t -> Evar.t option + + val typeclass_resolvable : unit Evd.Store.field + end (** This module gives access to the innards of the monad. Its use is diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 0faa35c875..3a5796fe1b 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -490,7 +490,7 @@ let is_instance = function Nota: we will only check the resolvability status of undefined evars. *) -let resolvable = Store.field () +let resolvable = Proofview.Unsafe.typeclass_resolvable let set_resolvable s b = if b then Store.remove s resolvable -- cgit v1.2.3 From e98d7276f52c4b67bf05a80a6b44f334966f82fd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 20:11:50 +0100 Subject: Splitting Evarutil in two distinct files. Some parts of Evarutils were related to the management of evars under constraints. We put them in the Evardefine file. --- dev/printers.mllib | 1 + pretyping/cases.ml | 1 + pretyping/coercion.ml | 6 +- pretyping/evarconv.ml | 1 + pretyping/evardefine.ml | 209 ++++++++++++++++++++++++++++++++++++++++++++++ pretyping/evardefine.mli | 46 ++++++++++ pretyping/evarutil.ml | 191 ++---------------------------------------- pretyping/evarutil.mli | 39 ++------- pretyping/pretyping.ml | 1 + pretyping/pretyping.mllib | 1 + pretyping/typing.ml | 4 +- pretyping/unification.ml | 1 + toplevel/himsg.ml | 2 +- 13 files changed, 277 insertions(+), 226 deletions(-) create mode 100644 pretyping/evardefine.ml create mode 100644 pretyping/evardefine.mli diff --git a/dev/printers.mllib b/dev/printers.mllib index db86bb5edd..4830b36ab5 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -131,6 +131,7 @@ Retyping Cbv Pretype_errors Evarutil +Evardefine Evarsolve Recordops Evarconv diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 8a55a7aaa5..c3968f8963 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -25,6 +25,7 @@ open Glob_ops open Retyping open Pretype_errors open Evarutil +open Evardefine open Evarsolve open Evarconv open Evd diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 57b273d0d5..9d0f391e43 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -245,7 +245,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | Lambda (n, t, t') -> c, t' (*| Prod (n, t, t') -> t'*) | Evar (k, args) -> - let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in + let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in evdref := evs; let (n, dom, rng) = destLambda t in let dom = whd_evar !evdref dom in @@ -375,7 +375,7 @@ let inh_app_fun_core env evd j = match kind_of_term t with | Prod (_,_,_) -> (evd,j) | Evar ev -> - let (evd',t) = define_evar_as_product evd ev in + let (evd',t) = Evardefine.define_evar_as_product evd ev in (evd',{ uj_val = j.uj_val; uj_type = t }) | _ -> try let t,p = @@ -416,7 +416,7 @@ let inh_coerce_to_sort loc env evd j = match kind_of_term typ with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) | Evar ev when not (is_defined evd (fst ev)) -> - let (evd',s) = define_evar_as_sort env evd ev in + let (evd',s) = Evardefine.define_evar_as_sort env evd ev in (evd',{ utj_val = j.uj_val; utj_type = s }) | _ -> inh_tosort_force loc env evd j diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 489a8a729d..08973a05c4 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -18,6 +18,7 @@ open Termops open Environ open Recordops open Evarutil +open Evardefine open Evarsolve open Globnames open Evd diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml new file mode 100644 index 0000000000..ef3a3f5255 --- /dev/null +++ b/pretyping/evardefine.ml @@ -0,0 +1,209 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* push_rel (map_constr (nf_evar sigma) d) e) env + +let env_nf_betaiotaevar sigma env = + let open Context.Rel.Declaration in + process_rel_context + (fun d e -> + push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env + +(****************************************) +(* Operations on value/type constraints *) +(****************************************) + +type type_constraint = types option + +type val_constraint = constr option + +(* Old comment... + * Basically, we have the following kind of constraints (in increasing + * strength order): + * (false,(None,None)) -> no constraint at all + * (true,(None,None)) -> we must build a judgement which _TYPE is a kind + * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty + * (_,(Some v,_)) -> we must build a judgement which _VAL is v + * Maybe a concrete datatype would be easier to understand. + * We differentiate (true,(None,None)) from (_,(None,Some Type)) + * because otherwise Case(s) would be misled, as in + * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead + * of Set. + *) + +(* The empty type constraint *) +let empty_tycon = None + +(* Builds a type constraint *) +let mk_tycon ty = Some ty + +(* Constrains the value of a type *) +let empty_valcon = None + +(* Builds a value constraint *) +let mk_valcon c = Some c + +let idx = Namegen.default_dependent_ident + +(* Refining an evar to a product *) + +let define_pure_evar_as_product evd evk = + let open Context.Named.Declaration in + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in + let concl = Reductionops.whd_betadeltaiota evenv evd evi.evar_concl in + let s = destSort concl in + let evd1,(dom,u1) = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in + (Sigma.to_evar_map evd1, e) + in + let evd2,rng = + let newenv = push_named (LocalAssum (id, dom)) evenv in + let src = evar_source evk evd1 in + let filter = Filter.extend 1 (evar_filter evi) in + if is_prop_sort s then + (* Impredicative product, conclusion must fall in [Prop]. *) + new_evar_unsafe newenv evd1 concl ~src ~filter + else + let status = univ_flexible_alg in + let evd3, (rng, srng) = + let evd1 = Sigma.Unsafe.of_evar_map evd1 in + let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in + (Sigma.to_evar_map evd3, e) + in + let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in + let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in + evd3, rng + in + let prod = mkProd (Name id, dom, subst_var id rng) in + let evd3 = Evd.define evk prod evd2 in + evd3,prod + +(* Refine an applied evar to a product and returns its instantiation *) + +let define_evar_as_product evd (evk,args) = + let evd,prod = define_pure_evar_as_product evd evk in + (* Quick way to compute the instantiation of evk with args *) + let na,dom,rng = destProd prod in + let evdom = mkEvar (fst (destEvar dom), args) in + let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evrng = mkEvar (fst (destEvar rng), evrngargs) in + evd,mkProd (na, evdom, evrng) + +(* Refine an evar with an abstraction + + I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where: + - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y) + or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B + with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type + - x1..xq,y:A |- ?e':B +*) + +let define_pure_evar_as_lambda env evd evk = + let open Context.Named.Declaration in + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let typ = Reductionops.whd_betadeltaiota evenv evd (evar_concl evi) in + let evd1,(na,dom,rng) = match kind_of_term typ with + | Prod (na,dom,rng) -> (evd,(na,dom,rng)) + | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ + | _ -> error_not_product_loc Loc.ghost env evd typ in + let avoid = ids_of_named_context (evar_context evi) in + let id = + next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in + let newenv = push_named (LocalAssum (id, dom)) evenv in + let filter = Filter.extend 1 (evar_filter evi) in + let src = evar_source evk evd1 in + let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in + let lam = mkLambda (Name id, dom, subst_var id body) in + Evd.define evk lam evd2, lam + +let define_evar_as_lambda env evd (evk,args) = + let evd,lam = define_pure_evar_as_lambda env evd evk in + (* Quick way to compute the instantiation of evk with args *) + let na,dom,body = destLambda lam in + let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evbody = mkEvar (fst (destEvar body), evbodyargs) in + evd,mkLambda (na, dom, evbody) + +let rec evar_absorb_arguments env evd (evk,args as ev) = function + | [] -> evd,ev + | a::l -> + (* TODO: optimize and avoid introducing intermediate evars *) + let evd,lam = define_pure_evar_as_lambda env evd evk in + let _,_,body = destLambda lam in + let evk = fst (destEvar body) in + evar_absorb_arguments env evd (evk, Array.cons a args) l + +(* Refining an evar to a sort *) + +let define_evar_as_sort env evd (ev,args) = + let evd, u = new_univ_variable univ_rigid evd in + let evi = Evd.find_undefined evd ev in + let s = Type u in + let concl = Reductionops.whd_betadeltaiota (evar_env evi) evd evi.evar_concl in + let sort = destSort concl in + let evd' = Evd.define ev (mkSort s) evd in + Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s + +(* Propagation of constraints through application and abstraction: + Given a type constraint on a functional term, returns the type + constraint on its domain and codomain. If the input constraint is + an evar instantiate it with the product of 2 new evars. *) + +let split_tycon loc env evd tycon = + let rec real_split evd c = + let t = Reductionops.whd_betadeltaiota env evd c in + match kind_of_term t with + | Prod (na,dom,rng) -> evd, (na, dom, rng) + | Evar ev (* ev is undefined because of whd_betadeltaiota *) -> + let (evd',prod) = define_evar_as_product evd ev in + let (_,dom,rng) = destProd prod in + evd',(Anonymous, dom, rng) + | App (c,args) when isEvar c -> + let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in + real_split evd' (mkApp (lam,args)) + | _ -> error_not_product_loc loc env evd c + in + match tycon with + | None -> evd,(Anonymous,None,None) + | Some c -> + let evd', (n, dom, rng) = real_split evd c in + evd', (n, mk_tycon dom, mk_tycon rng) + +let valcon_of_tycon x = x +let lift_tycon n = Option.map (lift n) + +let pr_tycon env = function + None -> str "None" + | Some t -> Termops.print_constr_env env t diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli new file mode 100644 index 0000000000..07b0e69d9f --- /dev/null +++ b/pretyping/evardefine.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* env -> env +val env_nf_betaiotaevar : evar_map -> env -> env + +type type_constraint = types option +type val_constraint = constr option + +val empty_tycon : type_constraint +val mk_tycon : constr -> type_constraint +val empty_valcon : val_constraint +val mk_valcon : constr -> val_constraint + +(** Instantiate an evar by as many lambda's as needed so that its arguments + are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into + [?y[vars1:=args1,vars:=args]] with + [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) +val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> + evar_map * existential + +val split_tycon : + Loc.t -> env -> evar_map -> type_constraint -> + evar_map * (Name.t * type_constraint * type_constraint) + +val valcon_of_tycon : type_constraint -> val_constraint +val lift_tycon : int -> type_constraint -> type_constraint + +val define_evar_as_product : evar_map -> existential -> evar_map * types +val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types +val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts + +(** {6 debug pretty-printer:} *) + +val pr_tycon : env -> type_constraint -> Pp.std_ppcmds + diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index ab70de0578..35b66918cb 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -17,7 +17,6 @@ open Namegen open Pre_env open Environ open Evd -open Reductionops open Pretype_errors open Sigma.Notations @@ -76,17 +75,6 @@ let jv_nf_evar sigma = Array.map (j_nf_evar sigma) let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=nf_evar sigma v;utj_type=t} -let env_nf_evar sigma env = - let open Context.Rel.Declaration in - process_rel_context - (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env - -let env_nf_betaiotaevar sigma env = - let open Context.Rel.Declaration in - process_rel_context - (fun d e -> - push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env - let nf_evars_universes evm = Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) (Evd.universe_subst evm) @@ -481,7 +469,7 @@ let rec check_and_clear_in_constr env evdref err ids c = | Evar (evk,l as ev) -> if Evd.is_defined !evdref evk then (* If evk is already defined we replace it by its definition *) - let nc = whd_evar !evdref c in + let nc = Reductionops.whd_evar !evdref c in (check_and_clear_in_constr env evdref err ids nc) else (* We check for dependencies to elements of ids in the @@ -536,7 +524,7 @@ let rec check_and_clear_in_constr env evdref err ids c = let evi' = { evi with evar_extra = extra' } in evdref := Evd.add !evdref evk evi' ; (* spiwack: /hacking session *) - whd_evar !evdref c + Reductionops.whd_evar !evdref c | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c @@ -688,146 +676,6 @@ let occur_evar_upto sigma n c = in try occur_rec c; false with Occur -> true - -(****************************************) -(* Operations on value/type constraints *) -(****************************************) - -type type_constraint = types option - -type val_constraint = constr option - -(* Old comment... - * Basically, we have the following kind of constraints (in increasing - * strength order): - * (false,(None,None)) -> no constraint at all - * (true,(None,None)) -> we must build a judgement which _TYPE is a kind - * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty - * (_,(Some v,_)) -> we must build a judgement which _VAL is v - * Maybe a concrete datatype would be easier to understand. - * We differentiate (true,(None,None)) from (_,(None,Some Type)) - * because otherwise Case(s) would be misled, as in - * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead - * of Set. - *) - -(* The empty type constraint *) -let empty_tycon = None - -(* Builds a type constraint *) -let mk_tycon ty = Some ty - -(* Constrains the value of a type *) -let empty_valcon = None - -(* Builds a value constraint *) -let mk_valcon c = Some c - -let idx = Namegen.default_dependent_ident - -(* Refining an evar to a product *) - -let define_pure_evar_as_product evd evk = - let open Context.Named.Declaration in - let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in - let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in - let concl = whd_betadeltaiota evenv evd evi.evar_concl in - let s = destSort concl in - let evd1,(dom,u1) = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in - (Sigma.to_evar_map evd1, e) - in - let evd2,rng = - let newenv = push_named (LocalAssum (id, dom)) evenv in - let src = evar_source evk evd1 in - let filter = Filter.extend 1 (evar_filter evi) in - if is_prop_sort s then - (* Impredicative product, conclusion must fall in [Prop]. *) - new_evar_unsafe newenv evd1 concl ~src ~filter - else - let status = univ_flexible_alg in - let evd3, (rng, srng) = - let evd1 = Sigma.Unsafe.of_evar_map evd1 in - let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in - (Sigma.to_evar_map evd3, e) - in - let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in - let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in - evd3, rng - in - let prod = mkProd (Name id, dom, subst_var id rng) in - let evd3 = Evd.define evk prod evd2 in - evd3,prod - -(* Refine an applied evar to a product and returns its instantiation *) - -let define_evar_as_product evd (evk,args) = - let evd,prod = define_pure_evar_as_product evd evk in - (* Quick way to compute the instantiation of evk with args *) - let na,dom,rng = destProd prod in - let evdom = mkEvar (fst (destEvar dom), args) in - let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in - let evrng = mkEvar (fst (destEvar rng), evrngargs) in - evd,mkProd (na, evdom, evrng) - -(* Refine an evar with an abstraction - - I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where: - - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y) - or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B - with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type - - x1..xq,y:A |- ?e':B -*) - -let define_pure_evar_as_lambda env evd evk = - let open Context.Named.Declaration in - let evi = Evd.find_undefined evd evk in - let evenv = evar_env evi in - let typ = whd_betadeltaiota evenv evd (evar_concl evi) in - let evd1,(na,dom,rng) = match kind_of_term typ with - | Prod (na,dom,rng) -> (evd,(na,dom,rng)) - | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ - | _ -> error_not_product_loc Loc.ghost env evd typ in - let avoid = ids_of_named_context (evar_context evi) in - let id = - next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in - let newenv = push_named (LocalAssum (id, dom)) evenv in - let filter = Filter.extend 1 (evar_filter evi) in - let src = evar_source evk evd1 in - let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in - let lam = mkLambda (Name id, dom, subst_var id body) in - Evd.define evk lam evd2, lam - -let define_evar_as_lambda env evd (evk,args) = - let evd,lam = define_pure_evar_as_lambda env evd evk in - (* Quick way to compute the instantiation of evk with args *) - let na,dom,body = destLambda lam in - let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in - let evbody = mkEvar (fst (destEvar body), evbodyargs) in - evd,mkLambda (na, dom, evbody) - -let rec evar_absorb_arguments env evd (evk,args as ev) = function - | [] -> evd,ev - | a::l -> - (* TODO: optimize and avoid introducing intermediate evars *) - let evd,lam = define_pure_evar_as_lambda env evd evk in - let _,_,body = destLambda lam in - let evk = fst (destEvar body) in - evar_absorb_arguments env evd (evk, Array.cons a args) l - -(* Refining an evar to a sort *) - -let define_evar_as_sort env evd (ev,args) = - let evd, u = new_univ_variable univ_rigid evd in - let evi = Evd.find_undefined evd ev in - let s = Type u in - let concl = whd_betadeltaiota (evar_env evi) evd evi.evar_concl in - let sort = destSort concl in - let evd' = Evd.define ev (mkSort s) evd in - Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s - (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) @@ -835,38 +683,6 @@ let judge_of_new_Type evd = let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) -(* Propagation of constraints through application and abstraction: - Given a type constraint on a functional term, returns the type - constraint on its domain and codomain. If the input constraint is - an evar instantiate it with the product of 2 new evars. *) - -let split_tycon loc env evd tycon = - let rec real_split evd c = - let t = whd_betadeltaiota env evd c in - match kind_of_term t with - | Prod (na,dom,rng) -> evd, (na, dom, rng) - | Evar ev (* ev is undefined because of whd_betadeltaiota *) -> - let (evd',prod) = define_evar_as_product evd ev in - let (_,dom,rng) = destProd prod in - evd',(Anonymous, dom, rng) - | App (c,args) when isEvar c -> - let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in - real_split evd' (mkApp (lam,args)) - | _ -> error_not_product_loc loc env evd c - in - match tycon with - | None -> evd,(Anonymous,None,None) - | Some c -> - let evd', (n, dom, rng) = real_split evd c in - evd', (n, mk_tycon dom, mk_tycon rng) - -let valcon_of_tycon x = x -let lift_tycon n = Option.map (lift n) - -let pr_tycon env = function - None -> str "None" - | Some t -> Termops.print_constr_env env t - let subterm_source evk (loc,k) = let evk = match k with | Evar_kinds.SubEvar (evk) -> evk @@ -897,3 +713,6 @@ let eq_constr_univs_test sigma1 sigma2 t u = (universes sigma2) fold t u sigma2 in match ans with None -> false | Some _ -> true + +type type_constraint = types option +type val_constraint = constr option diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index bc4c37a918..a4f8527652 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -100,17 +100,6 @@ val is_ground_env : evar_map -> env -> bool new unresolved evar remains in [c] *) val check_evars : env -> evar_map -> evar_map -> constr -> unit -val define_evar_as_product : evar_map -> existential -> evar_map * types -val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types -val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts - -(** Instantiate an evar by as many lambda's as needed so that its arguments - are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into - [?y[vars1:=args1,vars:=args]] with - [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) -val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> - evar_map * existential - (** [gather_dependent_evars evm seeds] classifies the evars in [evm] as dependent_evars and goals (these may overlap). A goal is an evar in [seeds] or an evar appearing in the (partial) definition @@ -140,21 +129,6 @@ val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma -type type_constraint = types option -type val_constraint = constr option - -val empty_tycon : type_constraint -val mk_tycon : constr -> type_constraint -val empty_valcon : val_constraint -val mk_valcon : constr -> val_constraint - -val split_tycon : - Loc.t -> env -> evar_map -> type_constraint -> - evar_map * (Name.t * type_constraint * type_constraint) - -val valcon_of_tycon : type_constraint -> val_constraint -val lift_tycon : int -> type_constraint -> type_constraint - (***********************************************************) (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains @@ -177,9 +151,6 @@ val nf_evar_info : evar_map -> evar_info -> evar_info val nf_evar_map : evar_map -> evar_map val nf_evar_map_undefined : evar_map -> evar_map -val env_nf_evar : evar_map -> env -> env -val env_nf_betaiotaevar : evar_map -> env -> env - val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment val jv_nf_betaiotaevar : evar_map -> unsafe_judgment array -> unsafe_judgment array @@ -212,11 +183,6 @@ val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term assumed to be an extention of those in [sigma1]. *) val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool -(** {6 debug pretty-printer:} *) - -val pr_tycon : env -> type_constraint -> Pp.std_ppcmds - - (** {6 Removing hyps in evars'context} raise OccurHypInSimpleClause if the removal breaks dependencies *) @@ -251,3 +217,8 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located val meta_counter_summary_name : string + +(** Deprecater *) + +type type_constraint = types option +type val_constraint = constr option diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 8329de2ee4..30e26c6f89 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -36,6 +36,7 @@ open Typeops open Globnames open Nameops open Evarutil +open Evardefine open Pretype_errors open Glob_term open Glob_ops diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index b0d5a1df6a..e8c0bbbf90 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -9,6 +9,7 @@ Cbv Pretype_errors Find_subterm Evarutil +Evardefine Evarsolve Recordops Evarconv diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 5347d965b5..52afa7f83a 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -39,7 +39,7 @@ let e_type_judgment env evdref j = match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | Evar ev -> - let (evd,s) = Evarutil.define_evar_as_sort env !evdref ev in + let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in evdref := evd; { utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j @@ -61,7 +61,7 @@ let e_judge_of_apply env evdref funj argjv = else error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv | Evar ev -> - let (evd',t) = Evarutil.define_evar_as_product !evdref ev in + let (evd',t) = Evardefine.define_evar_as_product !evdref ev in evdref := evd'; let (_,_,c2) = destProd t in apply_rec (n+1) (subst1 hj.uj_val c2) restjl diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a7b415552a..a4a386530d 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -19,6 +19,7 @@ open Evd open Reduction open Reductionops open Evarutil +open Evardefine open Evarsolve open Pretype_errors open Retyping diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 4ee1537c20..31730865ff 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -779,7 +779,7 @@ let explain_unsatisfiable_constraints env sigma constr comp = explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr let explain_pretype_error env sigma err = - let env = Evarutil.env_nf_betaiotaevar sigma env in + let env = Evardefine.env_nf_betaiotaevar sigma env in let env = make_all_name_different env in match err with | CantFindCaseType c -> explain_cant_find_case_type env sigma c -- cgit v1.2.3 From c3de822e711fa3f10817432b7023fc2f88c0aeeb Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 20:41:17 +0100 Subject: Making Evarutil independent from Reductionops. --- dev/printers.mllib | 5 ++-- pretyping/evarutil.ml | 61 +++++++++++++++++++++++++---------------------- pretyping/evarutil.mli | 9 +++---- pretyping/pretyping.ml | 17 +++++++++++++ pretyping/pretyping.mli | 4 ++++ pretyping/pretyping.mllib | 4 ++-- pretyping/reductionops.ml | 30 +++-------------------- tactics/hints.ml | 2 +- tactics/rewrite.ml | 2 +- toplevel/classes.ml | 6 ++--- toplevel/himsg.ml | 13 ++++++++-- toplevel/record.ml | 2 +- 12 files changed, 82 insertions(+), 73 deletions(-) diff --git a/dev/printers.mllib b/dev/printers.mllib index 4830b36ab5..a3ba42ba78 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -123,14 +123,15 @@ Evd Sigma Glob_ops Redops +Pretype_errors +Evarutil Reductionops Inductiveops Arguments_renaming Nativenorm Retyping Cbv -Pretype_errors -Evarutil + Evardefine Evarsolve Recordops diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 35b66918cb..2bd67dcdc8 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -17,9 +17,12 @@ open Namegen open Pre_env open Environ open Evd -open Pretype_errors open Sigma.Notations +let safe_evar_value sigma ev = + try Some (Evd.existential_value sigma ev) + with NotInstantiatedEvar | Not_found -> None + (** Combinators *) let evd_comb0 f evdref = @@ -61,22 +64,41 @@ let rec flush_and_check_evars sigma c = (* let nf_evar_key = Profile.declare_profile "nf_evar" *) (* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) -let nf_evar = Reductionops.nf_evar + +let rec whd_evar sigma c = + match kind_of_term c with + | Evar ev -> + let (evk, args) = ev in + let args = Array.map (fun c -> whd_evar sigma c) args in + (match safe_evar_value sigma (evk, args) with + Some c -> whd_evar sigma c + | None -> c) + | Sort (Type u) -> + let u' = Evd.normalize_universe sigma u in + if u' == u then c else mkSort (Sorts.sort_of_univ u') + | Const (c', u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstU (c', u') + | Ind (i, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkIndU (i, u') + | Construct (co, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstructU (co, u') + | _ -> c + +let rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t) + let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; uj_type = nf_evar sigma j.uj_type } -let j_nf_betaiotaevar sigma j = - { uj_val = nf_evar sigma j.uj_val; - uj_type = Reductionops.nf_betaiota sigma j.uj_type } let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl -let jv_nf_betaiotaevar sigma jl = - Array.map (j_nf_betaiotaevar sigma) jl let jv_nf_evar sigma = Array.map (j_nf_evar sigma) let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=nf_evar sigma v;utj_type=t} let nf_evars_universes evm = - Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) + Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) (Evd.universe_subst evm) let nf_evars_and_universes evm = @@ -469,7 +491,7 @@ let rec check_and_clear_in_constr env evdref err ids c = | Evar (evk,l as ev) -> if Evd.is_defined !evdref evk then (* If evk is already defined we replace it by its definition *) - let nc = Reductionops.whd_evar !evdref c in + let nc = whd_evar !evdref c in (check_and_clear_in_constr env evdref err ids nc) else (* We check for dependencies to elements of ids in the @@ -524,7 +546,7 @@ let rec check_and_clear_in_constr env evdref err ids c = let evi' = { evi with evar_extra = extra' } in evdref := Evd.add !evdref evk evi' ; (* spiwack: /hacking session *) - Reductionops.whd_evar !evdref c + whd_evar !evdref c | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c @@ -647,23 +669,6 @@ let undefined_evars_of_evar_info evd evi = (undefined_evars_of_named_context evd (named_context_of_val evi.evar_hyps))) -(* [check_evars] fails if some unresolved evar remains *) - -let check_evars env initial_sigma sigma c = - let rec proc_rec c = - match kind_of_term c with - | Evar (evk,_ as ev) -> - (match existential_opt_value sigma ev with - | Some c -> proc_rec c - | None -> - if not (Evd.mem initial_sigma evk) then - let (loc,k) = evar_source evk sigma in - match k with - | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> error_unsolvable_implicit loc env sigma evk None) - | _ -> iter_constr proc_rec c - in proc_rec c - (* spiwack: this is a more complete version of {!Termops.occur_evar}. The latter does not look recursively into an [evar_map]. If unification only need to check superficially, tactics @@ -692,7 +697,7 @@ let subterm_source evk (loc,k) = (** Term exploration up to instantiation. *) let kind_of_term_upto sigma t = - Constr.kind (Reductionops.whd_evar sigma t) + Constr.kind (whd_evar sigma t) (** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and [u] up to existential variable instantiation and equalisable diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index a4f8527652..ffff2c5dd9 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -78,6 +78,8 @@ val new_evar_instance : val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list +val safe_evar_value : evar_map -> existential -> constr option + (** {6 Evars/Metas switching...} *) val non_instantiated : evar_map -> evar_info Evar.Map.t @@ -96,9 +98,6 @@ val has_undefined_evars : evar_map -> constr -> bool val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool -(** [check_evars env initial_sigma extended_sigma c] fails if some - new unresolved evar remains in [c] *) -val check_evars : env -> evar_map -> evar_map -> constr -> unit (** [gather_dependent_evars evm seeds] classifies the evars in [evm] as dependent_evars and goals (these may overlap). A goal is an @@ -134,6 +133,7 @@ val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains uninstantiated; [nf_evar] leaves uninstantiated evars as is *) +val whd_evar : evar_map -> constr -> constr val nf_evar : evar_map -> constr -> constr val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment val jl_nf_evar : @@ -151,9 +151,6 @@ val nf_evar_info : evar_map -> evar_info -> evar_info val nf_evar_map : evar_map -> evar_map val nf_evar_map_undefined : evar_map -> evar_map -val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment -val jv_nf_betaiotaevar : - evar_map -> unsafe_judgment array -> unsafe_judgment array (** Presenting terms without solved evars *) val nf_evars_universes : evar_map -> constr -> constr diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 30e26c6f89..a765d30913 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -235,6 +235,23 @@ let check_extra_evars_are_solved env current_sigma pending = | _ -> error_unsolvable_implicit loc env current_sigma evk None) pending +(* [check_evars] fails if some unresolved evar remains *) + +let check_evars env initial_sigma sigma c = + let rec proc_rec c = + match kind_of_term c with + | Evar (evk,_ as ev) -> + (match existential_opt_value sigma ev with + | Some c -> proc_rec c + | None -> + if not (Evd.mem initial_sigma evk) then + let (loc,k) = evar_source evk sigma in + match k with + | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () + | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None) + | _ -> Constr.iter proc_rec c + in proc_rec c + let check_evars_are_solved env current_sigma frozen pending = check_typeclasses_instances_are_solved env current_sigma frozen; check_problems_are_solved env current_sigma; diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 40745ed097..4c4c535d8c 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -130,6 +130,10 @@ val solve_remaining_evars : inference_flags -> val check_evars_are_solved : env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit +(** [check_evars env initial_sigma extended_sigma c] fails if some + new unresolved evar remains in [c] *) +val check_evars : env -> evar_map -> evar_map -> constr -> unit + (**/**) (** Internal of Pretyping... *) val pretype : diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index e8c0bbbf90..be517d1aa0 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,4 +1,6 @@ Locusops +Pretype_errors +Evarutil Reductionops Inductiveops Vnorm @@ -6,9 +8,7 @@ Arguments_renaming Nativenorm Retyping Cbv -Pretype_errors Find_subterm -Evarutil Evardefine Evarsolve Recordops diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 935e18d8dd..7f4249c5b6 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -594,9 +594,7 @@ let pr_state (tm,sk) = (*** Reduction Functions Operators ***) (*************************************) -let safe_evar_value sigma ev = - try Some (Evd.existential_value sigma ev) - with NotInstantiatedEvar | Not_found -> None +let safe_evar_value = Evarutil.safe_evar_value let safe_meta_value sigma ev = try Some (Evd.meta_value sigma ev) @@ -1183,30 +1181,8 @@ let whd_zeta c = Stack.zip (local_whd_state_gen zeta Evd.empty (c,Stack.empty)) (****************************************************************************) (* Replacing defined evars for error messages *) -let rec whd_evar sigma c = - match kind_of_term c with - | Evar ev -> - let (evk, args) = ev in - let args = Array.map (fun c -> whd_evar sigma c) args in - (match safe_evar_value sigma (evk, args) with - Some c -> whd_evar sigma c - | None -> c) - | Sort (Type u) -> - let u' = Evd.normalize_universe sigma u in - if u' == u then c else mkSort (Sorts.sort_of_univ u') - | Const (c', u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstU (c', u') - | Ind (i, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkIndU (i, u') - | Construct (co, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstructU (co, u') - | _ -> c - -let nf_evar = - local_strong whd_evar +let whd_evar = Evarutil.whd_evar +let nf_evar = Evarutil.nf_evar (* lazy reduction functions. The infos must be created for each term *) (* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add diff --git a/tactics/hints.ml b/tactics/hints.ml index 730da147af..e5abad6863 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1072,7 +1072,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in let c' = iter c in - if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; + if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 4c06550d44..fb04bee070 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1880,7 +1880,7 @@ let build_morphism_signature m = let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in let evd = solve_constraints env !evd in let m = Evarutil.nf_evar evd morph in - Evarutil.check_evars env Evd.empty evd m; m + Pretyping.check_evars env Evd.empty evd m; m let default_morphism sign m = let env = Global.env () in diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 4bf0450d27..2fc0f5ff19 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -191,7 +191,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in nf t in - Evarutil.check_evars env Evd.empty !evars termtype; + Pretyping.check_evars env Evd.empty !evars termtype; let pl, ctx = Evd.universe_context ?names:pl !evars in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry @@ -287,7 +287,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let evm, nf = Evarutil.nf_evar_map_universes !evars in let termtype = nf termtype in let _ = (* Check that the type is free of evars now. *) - Evarutil.check_evars env Evd.empty evm termtype + Pretyping.check_evars env Evd.empty evm termtype in let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then @@ -361,7 +361,7 @@ let context poly l = let _, ((env', fullctx), impls) = interp_context_evars env evars l in let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in let fullctx = Context.Rel.map subst fullctx in - let ce t = Evarutil.check_evars env Evd.empty !evars t in + let ce t = Pretyping.check_evars env Evd.empty !evars t in let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in let ctx = try named_of_rel_context fullctx diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 31730865ff..ad848ccfc8 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -76,6 +76,15 @@ let rec contract3' env a b c = function let y,x = contract3' env a b c x in y,CannotSolveConstraint ((pb,env,t,u),x) +(** Ad-hoc reductions *) + +let j_nf_betaiotaevar sigma j = + { uj_val = Evarutil.nf_evar sigma j.uj_val; + uj_type = Reductionops.nf_betaiota sigma j.uj_type } + +let jv_nf_betaiotaevar sigma jl = + Array.map (j_nf_betaiotaevar sigma) jl + (** Printers *) let pr_lconstr c = quote (pr_lconstr c) @@ -322,7 +331,7 @@ let explain_unification_error env sigma p1 p2 = function let explain_actual_type env sigma j t reason = let env = make_all_name_different env in - let j = Evarutil.j_nf_betaiotaevar sigma j in + let j = j_nf_betaiotaevar sigma j in let t = Reductionops.nf_betaiota sigma t in (** Actually print *) let pe = pr_ne_context_of (str "In environment") env sigma in @@ -337,7 +346,7 @@ let explain_actual_type env sigma j t reason = ppreason ++ str ".") let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = - let randl = Evarutil.jv_nf_betaiotaevar sigma randl in + let randl = jv_nf_betaiotaevar sigma randl in let exptyp = Evarutil.nf_evar sigma exptyp in let actualtyp = Reductionops.nf_betaiota sigma actualtyp in let rator = Evarutil.j_nf_evar sigma rator in diff --git a/toplevel/record.ml b/toplevel/record.ml index db82c205cb..96cafb0721 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -156,7 +156,7 @@ let typecheck_params_and_fields def id pl t ps nots fs = let evars, nf = Evarutil.nf_evars_and_universes evars in let newps = Context.Rel.map nf newps in let newfs = Context.Rel.map nf newfs in - let ce t = Evarutil.check_evars env0 Evd.empty evars t in + let ce t = Pretyping.check_evars env0 Evd.empty evars t in List.iter (iter_constr ce) (List.rev newps); List.iter (iter_constr ce) (List.rev newfs); Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs -- cgit v1.2.3 From 528bc26b7a6ee63bb35fc8ada56b021da65f9834 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 21:06:04 +0100 Subject: Moving Evarutil and Proofview to engine/ --- engine/engine.mllib | 2 + engine/evarutil.ml | 723 +++++++++++++++++++++++++++ engine/evarutil.mli | 221 +++++++++ engine/proofview.ml | 1211 +++++++++++++++++++++++++++++++++++++++++++++ engine/proofview.mli | 589 ++++++++++++++++++++++ pretyping/evarutil.ml | 723 --------------------------- pretyping/evarutil.mli | 221 --------- pretyping/pretyping.mllib | 2 - pretyping/proofview.ml | 1211 --------------------------------------------- pretyping/proofview.mli | 589 ---------------------- 10 files changed, 2746 insertions(+), 2746 deletions(-) create mode 100644 engine/evarutil.ml create mode 100644 engine/evarutil.mli create mode 100644 engine/proofview.ml create mode 100644 engine/proofview.mli delete mode 100644 pretyping/evarutil.ml delete mode 100644 pretyping/evarutil.mli delete mode 100644 pretyping/proofview.ml delete mode 100644 pretyping/proofview.mli diff --git a/engine/engine.mllib b/engine/engine.mllib index 7197a25838..70b74edca3 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -5,3 +5,5 @@ UState Evd Sigma Proofview_monad +Evarutil +Proofview diff --git a/engine/evarutil.ml b/engine/evarutil.ml new file mode 100644 index 0000000000..2bd67dcdc8 --- /dev/null +++ b/engine/evarutil.ml @@ -0,0 +1,723 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None + +(** Combinators *) + +let evd_comb0 f evdref = + let (evd',x) = f !evdref in + evdref := evd'; + x + +let evd_comb1 f evdref x = + let (evd',y) = f !evdref x in + evdref := evd'; + y + +let evd_comb2 f evdref x y = + let (evd',z) = f !evdref x y in + evdref := evd'; + z + +let e_new_global evdref x = + evd_comb1 (Evd.fresh_global (Global.env())) evdref x + +let new_global evd x = + Sigma.fresh_global (Global.env()) evd x + +(****************************************************) +(* Expanding/testing/exposing existential variables *) +(****************************************************) + +(* flush_and_check_evars fails if an existential is undefined *) + +exception Uninstantiated_evar of existential_key + +let rec flush_and_check_evars sigma c = + match kind_of_term c with + | Evar (evk,_ as ev) -> + (match existential_opt_value sigma ev with + | None -> raise (Uninstantiated_evar evk) + | Some c -> flush_and_check_evars sigma c) + | _ -> map_constr (flush_and_check_evars sigma) c + +(* let nf_evar_key = Profile.declare_profile "nf_evar" *) +(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) + +let rec whd_evar sigma c = + match kind_of_term c with + | Evar ev -> + let (evk, args) = ev in + let args = Array.map (fun c -> whd_evar sigma c) args in + (match safe_evar_value sigma (evk, args) with + Some c -> whd_evar sigma c + | None -> c) + | Sort (Type u) -> + let u' = Evd.normalize_universe sigma u in + if u' == u then c else mkSort (Sorts.sort_of_univ u') + | Const (c', u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstU (c', u') + | Ind (i, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkIndU (i, u') + | Construct (co, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstructU (co, u') + | _ -> c + +let rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t) + +let j_nf_evar sigma j = + { uj_val = nf_evar sigma j.uj_val; + uj_type = nf_evar sigma j.uj_type } +let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl +let jv_nf_evar sigma = Array.map (j_nf_evar sigma) +let tj_nf_evar sigma {utj_val=v;utj_type=t} = + {utj_val=nf_evar sigma v;utj_type=t} + +let nf_evars_universes evm = + Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) + (Evd.universe_subst evm) + +let nf_evars_and_universes evm = + let evm = Evd.nf_constraints evm in + evm, nf_evars_universes evm + +let e_nf_evars_and_universes evdref = + evdref := Evd.nf_constraints !evdref; + nf_evars_universes !evdref, Evd.universe_subst !evdref + +let nf_evar_map_universes evm = + let evm = Evd.nf_constraints evm in + let subst = Evd.universe_subst evm in + if Univ.LMap.is_empty subst then evm, nf_evar evm + else + let f = nf_evars_universes evm in + Evd.raw_map (fun _ -> map_evar_info f) evm, f + +let nf_named_context_evar sigma ctx = + Context.Named.map (nf_evar sigma) ctx + +let nf_rel_context_evar sigma ctx = + Context.Rel.map (nf_evar sigma) ctx + +let nf_env_evar sigma env = + let nc' = nf_named_context_evar sigma (Environ.named_context env) in + let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in + push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) + +let nf_evar_info evc info = map_evar_info (nf_evar evc) info + +let nf_evar_map evm = + Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm + +let nf_evar_map_undefined evm = + Evd.raw_map_undefined (fun _ evi -> nf_evar_info evm evi) evm + +(*-------------------*) +(* Auxiliary functions for the conversion algorithms modulo evars + *) + +(* A probably faster though more approximative variant of + [has_undefined (nf_evar c)]: instances are not substituted and + maybe an evar occurs in an instance and it would disappear by + instantiation *) + +let has_undefined_evars evd t = + let rec has_ev t = + match kind_of_term t with + | Evar (ev,args) -> + (match evar_body (Evd.find evd ev) with + | Evar_defined c -> + has_ev c; Array.iter has_ev args + | Evar_empty -> + raise NotInstantiatedEvar) + | _ -> iter_constr has_ev t in + try let _ = has_ev t in false + with (Not_found | NotInstantiatedEvar) -> true + +let is_ground_term evd t = + not (has_undefined_evars evd t) + +let is_ground_env evd env = + let open Context.Rel.Declaration in + let is_ground_rel_decl = function + | LocalDef (_,b,_) -> is_ground_term evd b + | _ -> true in + let open Context.Named.Declaration in + let is_ground_named_decl = function + | LocalDef (_,b,_) -> is_ground_term evd b + | _ -> true in + List.for_all is_ground_rel_decl (rel_context env) && + List.for_all is_ground_named_decl (named_context env) + +(* Memoization is safe since evar_map and environ are applicative + structures *) +let memo f = + let m = ref None in + fun x y -> match !m with + | Some (x', y', r) when x == x' && y == y' -> r + | _ -> let r = f x y in m := Some (x, y, r); r + +let is_ground_env = memo is_ground_env + +(* Return the head evar if any *) + +exception NoHeadEvar + +let head_evar = + let rec hrec c = match kind_of_term c with + | Evar (evk,_) -> evk + | Case (_,_,c,_) -> hrec c + | App (c,_) -> hrec c + | Cast (c,_,_) -> hrec c + | _ -> raise NoHeadEvar + in + hrec + +(* Expand head evar if any (currently consider only applications but I + guess it should consider Case too) *) + +let whd_head_evar_stack sigma c = + let rec whrec (c, l as s) = + match kind_of_term c with + | Evar (evk,args as ev) -> + let v = + try Some (existential_value sigma ev) + with NotInstantiatedEvar | Not_found -> None in + begin match v with + | None -> s + | Some c -> whrec (c, l) + end + | Cast (c,_,_) -> whrec (c, l) + | App (f,args) -> whrec (f, args :: l) + | _ -> s + in + whrec (c, []) + +let whd_head_evar sigma c = + let (f, args) = whd_head_evar_stack sigma c in + (** optim: don't reallocate if empty/singleton *) + match args with + | [] -> f + | [arg] -> mkApp (f, arg) + | _ -> mkApp (f, Array.concat args) + +(**********************) +(* Creating new metas *) +(**********************) + +let meta_counter_summary_name = "meta counter" + +(* Generator of metavariables *) +let new_meta = + let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in + fun () -> incr meta_ctr; !meta_ctr + +let mk_new_meta () = mkMeta(new_meta()) + +(* The list of non-instantiated existential declarations (order is important) *) + +let non_instantiated sigma = + let listev = Evd.undefined_map sigma in + Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev + +(************************) +(* Manipulating filters *) +(************************) + +let make_pure_subst evi args = + let open Context.Named.Declaration in + snd (List.fold_right + (fun decl (args,l) -> + match args with + | a::rest -> (rest, (get_id decl, a)::l) + | _ -> anomaly (Pp.str "Instance does not match its signature")) + (evar_filtered_context evi) (Array.rev_to_list args,[])) + +(*------------------------------------* + * functional operations on evar sets * + *------------------------------------*) + +(* [push_rel_context_to_named_context] builds the defining context and the + * initial instance of an evar. If the evar is to be used in context + * + * Gamma = a1 ... an xp ... x1 + * \- named part -/ \- de Bruijn part -/ + * + * then the x1...xp are turned into variables so that the evar is declared in + * context + * + * a1 ... an xp ... x1 + * \----------- named part ------------/ + * + * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)" + * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed + * in context Gamma. + * + * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first) + * Remark 2: If some of the ai or xj are definitions, we keep them in the + * instance. This is necessary so that no unfolding of local definitions + * happens when inferring implicit arguments (consider e.g. the problem + * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which + * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want + * the hole to be instantiated by x', not by x (which would have been + * the case in [invert_definition] if x' had disappeared from the instance). + * Note that at any time, if, in some context env, the instance of + * declaration x:A is t and the instance of definition x':=phi(x) is u, then + * we have the property that u and phi(t) are convertible in env. + *) + +let subst2 subst vsubst c = + substl subst (replace_vars vsubst c) + +let push_rel_context_to_named_context env typ = + (* compute the instances relative to the named context and rel_context *) + let open Context.Named.Declaration in + let ids = List.map get_id (named_context env) in + let inst_vars = List.map mkVar ids in + let inst_rels = List.rev (rel_list 0 (nb_rel env)) in + let replace_var_named_declaration id0 id decl = + let id' = get_id decl in + let id' = if Id.equal id0 id' then id else id' in + let vsubst = [id0 , mkVar id] in + decl |> set_id id' |> map_constr (replace_vars vsubst) + in + let replace_var_named_context id0 id env = + let nc = Environ.named_context env in + let nc' = List.map (replace_var_named_declaration id0 id) nc in + Environ.reset_with_named_context (val_of_named_context nc') env + in + let extract_if_neq id = function + | Anonymous -> None + | Name id' when id_ord id id' = 0 -> None + | Name id' -> Some id' + in + (* move the rel context to a named context and extend the named instance *) + (* with vars of the rel context *) + (* We do keep the instances corresponding to local definition (see above) *) + let (subst, vsubst, _, env) = + Context.Rel.fold_outside + (fun decl (subst, vsubst, avoid, env) -> + let open Context.Rel.Declaration in + let na = get_name decl in + let c = get_value decl in + let t = get_type decl in + let open Context.Named.Declaration in + let id = + (* ppedrot: we want to infer nicer names for the refine tactic, but + keeping at the same time backward compatibility in other code + using this function. For now, we only attempt to preserve the + old behaviour of Program, but ultimately, one should do something + about this whole name generation problem. *) + if Flags.is_program_mode () then next_name_away na avoid + else next_ident_away (id_of_name_using_hdchar env t na) avoid + in + match extract_if_neq id na with + | Some id0 when not (is_section_variable id0) -> + (* spiwack: if [id<>id0], rather than introducing a new + binding named [id], we will keep [id0] (the name given + by the user) and rename [id0] into [id] in the named + context. Unless [id] is a section variable. *) + let subst = List.map (replace_vars [id0,mkVar id]) subst in + let vsubst = (id0,mkVar id)::vsubst in + let d = match c with + | None -> LocalAssum (id0, subst2 subst vsubst t) + | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t) + in + let env = replace_var_named_context id0 id env in + (mkVar id0 :: subst, vsubst, id::avoid, push_named d env) + | _ -> + (* spiwack: if [id0] is a section variable renaming it is + incorrect. We revert to a less robust behaviour where + the new binder has name [id]. Which amounts to the same + behaviour than when [id=id0]. *) + let d = match c with + | None -> LocalAssum (id, subst2 subst vsubst t) + | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t) + in + (mkVar id :: subst, vsubst, id::avoid, push_named d env) + ) + (rel_context env) ~init:([], [], ids, env) in + (named_context_val env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst) + +(*------------------------------------* + * Entry points to define new evars * + *------------------------------------*) + +let default_source = (Loc.ghost,Evar_kinds.InternalHole) + +let restrict_evar evd evk filter candidates = + let evd = Sigma.to_evar_map evd in + let evd, evk' = Evd.restrict evk filter ?candidates evd in + Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) + +let new_pure_evar_full evd evi = + let evd = Sigma.to_evar_map evd in + let (evd, evk) = Evd.new_evar evd evi in + let evd = Evd.declare_future_goal evk evd in + Sigma.Unsafe.of_pair (evk, evd) + +let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = + let evd = Sigma.to_evar_map evd in + let default_naming = Misctypes.IntroAnonymous in + let naming = Option.default default_naming naming in + let evi = { + evar_hyps = sign; + evar_concl = typ; + evar_body = Evar_empty; + evar_filter = filter; + evar_source = src; + evar_candidates = candidates; + evar_extra = store; } + in + let (evd, newevk) = Evd.new_evar evd ~naming evi in + let evd = + if principal then Evd.declare_principal_goal newevk evd + else Evd.declare_future_goal newevk evd + in + Sigma.Unsafe.of_pair (newevk, evd) + +let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = + assert (not !Flags.debug || + List.distinct (ids_of_named_context (named_context_of_val sign))); + let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in + Sigma (mkEvar (newevk,Array.of_list instance), evd, p) + +(* [new_evar] declares a new existential in an env env with type typ *) +(* Converting the env into the sign of the evar to define *) +let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = + let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in + let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in + let instance = + match filter with + | None -> instance + | Some filter -> Filter.filter_list filter instance in + new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance + +let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in + (Sigma.to_evar_map evd, evk) + +let new_type_evar env evd ?src ?filter ?naming ?principal rigid = + let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in + let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in + Sigma ((e, s), evd', p +> q) + +let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in + let sigma = Sigma.to_evar_map sigma in + evdref := sigma; + c + +let new_Type ?(rigid=Evd.univ_flexible) env evd = + let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in + Sigma (mkSort s, sigma, p) + +let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = + let evd', s = new_sort_variable rigid !evdref in + evdref := evd'; mkSort s + + (* The same using side-effect *) +let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty = + let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in + evdref := evd'; + ev + +(* This assumes an evar with identity instance and generalizes it over only + the De Bruijn part of the context *) +let generalize_evar_over_rels sigma (ev,args) = + let evi = Evd.find sigma ev in + let sign = named_context_of_val evi.evar_hyps in + List.fold_left2 + (fun (c,inst as x) a d -> + if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x) + (evi.evar_concl,[]) (Array.to_list args) sign + +(************************************) +(* Removing a dependency in an evar *) +(************************************) + +type clear_dependency_error = +| OccurHypInSimpleClause of Id.t option +| EvarTypingBreak of existential + +exception ClearDependencyError of Id.t * clear_dependency_error + +let cleared = Store.field () + +exception Depends of Id.t + +let rec check_and_clear_in_constr env evdref err ids c = + (* returns a new constr where all the evars have been 'cleaned' + (ie the hypotheses ids have been removed from the contexts of + evars) *) + let check id' = + if Id.Set.mem id' ids then + raise (ClearDependencyError (id',err)) + in + match kind_of_term c with + | Var id' -> + check id'; c + + | ( Const _ | Ind _ | Construct _ ) -> + let vars = Environ.vars_of_global env c in + Id.Set.iter check vars; c + + | Evar (evk,l as ev) -> + if Evd.is_defined !evdref evk then + (* If evk is already defined we replace it by its definition *) + let nc = whd_evar !evdref c in + (check_and_clear_in_constr env evdref err ids nc) + else + (* We check for dependencies to elements of ids in the + evar_info corresponding to e and in the instance of + arguments. Concurrently, we build a new evar + corresponding to e where hypotheses of ids have been + removed *) + let evi = Evd.find_undefined !evdref evk in + let ctxt = Evd.evar_filtered_context evi in + let (rids,filter) = + List.fold_right2 + (fun h a (ri,filter) -> + try + (* Check if some id to clear occurs in the instance + a of rid in ev and remember the dependency *) + let check id = if Id.Set.mem id ids then raise (Depends id) in + let () = Id.Set.iter check (collect_vars a) in + (* Check if some rid to clear in the context of ev + has dependencies in another hyp of the context of ev + and transitively remember the dependency *) + let check id _ = + if occur_var_in_decl (Global.env ()) id h + then raise (Depends id) + in + let () = Id.Map.iter check ri in + (* No dependency at all, we can keep this ev's context hyp *) + (ri, true::filter) + with Depends id -> let open Context.Named.Declaration in + (Id.Map.add (get_id h) id ri, false::filter)) + ctxt (Array.to_list l) (Id.Map.empty,[]) in + (* Check if some rid to clear in the context of ev has dependencies + in the type of ev and adjust the source of the dependency *) + let _nconcl = + try + let nids = Id.Map.domain rids in + check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids (evar_concl evi) + with ClearDependencyError (rid,err) -> + raise (ClearDependencyError (Id.Map.find rid rids,err)) in + + if Id.Map.is_empty rids then c + else + let origfilter = Evd.evar_filter evi in + let filter = Evd.Filter.apply_subfilter origfilter filter in + let evd = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (_, evd, _) = restrict_evar evd evk filter None in + let evd = Sigma.to_evar_map evd in + evdref := evd; + (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) + let evi = Evd.find !evdref evk in + let extra = evi.evar_extra in + let extra' = Store.set extra cleared true in + let evi' = { evi with evar_extra = extra' } in + evdref := Evd.add !evdref evk evi' ; + (* spiwack: /hacking session *) + whd_evar !evdref c + + | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c + +let clear_hyps_in_evi_main env evdref hyps terms ids = + (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some + hypothesis does not depend on a element of ids, and erases ids in + the contexts of the evars occurring in evi *) + let terms = + List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in + let nhyps = + let open Context.Named.Declaration in + let check_context decl = + let err = OccurHypInSimpleClause (Some (get_id decl)) in + map_constr (check_and_clear_in_constr env evdref err ids) decl + in + let check_value vk = match force_lazy_val vk with + | None -> vk + | Some (_, d) -> + if (Id.Set.for_all (fun e -> not (Id.Set.mem e d)) ids) then + (* v does depend on any of ids, it's ok *) + vk + else + (* v depends on one of the cleared hyps: + we forget the computed value *) + dummy_lazy_val () + in + remove_hyps ids check_context check_value hyps + in + (nhyps,terms) + +let clear_hyps_in_evi env evdref hyps concl ids = + match clear_hyps_in_evi_main env evdref hyps [concl] ids with + | (nhyps,[nconcl]) -> (nhyps,nconcl) + | _ -> assert false + +let clear_hyps2_in_evi env evdref hyps t concl ids = + match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with + | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl) + | _ -> assert false + +(* spiwack: a few functions to gather evars on which goals depend. *) +let queue_set q is_dependent set = + Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set +let queue_term q is_dependent c = + queue_set q is_dependent (evars_of_term c) + +let process_dependent_evar q acc evm is_dependent e = + let evi = Evd.find evm e in + (* Queues evars appearing in the types of the goal (conclusion, then + hypotheses), they are all dependent. *) + queue_term q true evi.evar_concl; + List.iter begin fun decl -> + let open Context.Named.Declaration in + queue_term q true (get_type decl); + match decl with + | LocalAssum _ -> () + | LocalDef (_,b,_) -> queue_term q true b + end (Environ.named_context_of_val evi.evar_hyps); + match evi.evar_body with + | Evar_empty -> + if is_dependent then Evar.Map.add e None acc else acc + | Evar_defined b -> + let subevars = evars_of_term b in + (* evars appearing in the definition of an evar [e] are marked + as dependent when [e] is dependent itself: if [e] is a + non-dependent goal, then, unless they are reach from another + path, these evars are just other non-dependent goals. *) + queue_set q is_dependent subevars; + if is_dependent then Evar.Map.add e (Some subevars) acc else acc + +let gather_dependent_evars q evm = + let acc = ref Evar.Map.empty in + while not (Queue.is_empty q) do + let (is_dependent,e) = Queue.pop q in + (* checks if [e] has already been added to [!acc] *) + begin if not (Evar.Map.mem e !acc) then + acc := process_dependent_evar q !acc evm is_dependent e + end + done; + !acc + +let gather_dependent_evars evm l = + let q = Queue.create () in + List.iter (fun a -> Queue.add (false,a) q) l; + gather_dependent_evars q evm + +(* /spiwack *) + +(** The following functions return the set of undefined evars + contained in the object, the defined evars being traversed. + This is roughly a combination of the previous functions and + [nf_evar]. *) + +let undefined_evars_of_term evd t = + let rec evrec acc c = + match kind_of_term c with + | Evar (n, l) -> + let acc = Array.fold_left evrec acc l in + (try match (Evd.find evd n).evar_body with + | Evar_empty -> Evar.Set.add n acc + | Evar_defined c -> evrec acc c + with Not_found -> anomaly ~label:"undefined_evars_of_term" (Pp.str "evar not found")) + | _ -> fold_constr evrec acc c + in + evrec Evar.Set.empty t + +let undefined_evars_of_named_context evd nc = + let open Context.Named.Declaration in + Context.Named.fold_outside + (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) + nc + ~init:Evar.Set.empty + +let undefined_evars_of_evar_info evd evi = + Evar.Set.union (undefined_evars_of_term evd evi.evar_concl) + (Evar.Set.union + (match evi.evar_body with + | Evar_empty -> Evar.Set.empty + | Evar_defined b -> undefined_evars_of_term evd b) + (undefined_evars_of_named_context evd + (named_context_of_val evi.evar_hyps))) + +(* spiwack: this is a more complete version of + {!Termops.occur_evar}. The latter does not look recursively into an + [evar_map]. If unification only need to check superficially, tactics + do not have this luxury, and need the more complete version. *) +let occur_evar_upto sigma n c = + let rec occur_rec c = match kind_of_term c with + | Evar (sp,_) when Evar.equal sp n -> raise Occur + | Evar e -> Option.iter occur_rec (existential_opt_value sigma e) + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + +(* We don't try to guess in which sort the type should be defined, since + any type has type Type. May cause some trouble, but not so far... *) + +let judge_of_new_Type evd = + let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in + Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) + +let subterm_source evk (loc,k) = + let evk = match k with + | Evar_kinds.SubEvar (evk) -> evk + | _ -> evk in + (loc,Evar_kinds.SubEvar evk) + + +(** Term exploration up to instantiation. *) +let kind_of_term_upto sigma t = + Constr.kind (whd_evar sigma t) + +(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and + [u] up to existential variable instantiation and equalisable + universes. The term [t] is interpreted in [sigma1] while [u] is + interpreted in [sigma2]. The universe constraints in [sigma2] are + assumed to be an extention of those in [sigma1]. *) +let eq_constr_univs_test sigma1 sigma2 t u = + (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) + let open Evd in + let fold cstr sigma = + try Some (add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | UniversesDiffer -> None + in + let ans = + Universes.eq_constr_univs_infer_with + (fun t -> kind_of_term_upto sigma1 t) + (fun u -> kind_of_term_upto sigma2 u) + (universes sigma2) fold t u sigma2 + in + match ans with None -> false | Some _ -> true + +type type_constraint = types option +type val_constraint = constr option diff --git a/engine/evarutil.mli b/engine/evarutil.mli new file mode 100644 index 0000000000..ffff2c5dd9 --- /dev/null +++ b/engine/evarutil.mli @@ -0,0 +1,221 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* metavariable +val mk_new_meta : unit -> constr + +(** {6 Creating a fresh evar given their type and context} *) +val new_evar : + env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + ?candidates:constr list -> ?store:Store.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> types -> (constr, 'r) Sigma.sigma + +val new_pure_evar : + named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + ?candidates:constr list -> ?store:Store.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> types -> (evar, 'r) Sigma.sigma + +val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma + +(** the same with side-effects *) +val e_new_evar : + env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + ?candidates:constr list -> ?store:Store.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> types -> constr + +(** Create a new Type existential variable, as we keep track of + them during type-checking and unification. *) +val new_type_evar : + env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> + (constr * sorts, 'r) Sigma.sigma + +val e_new_type_evar : env -> evar_map ref -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts + +val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma +val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr + +val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> + constr list option -> (existential_key, 'r) Sigma.sigma + +(** Polymorphic constants *) + +val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma +val e_new_global : evar_map ref -> Globnames.global_reference -> constr + +(** Create a fresh evar in a context different from its definition context: + [new_evar_instance sign evd ty inst] creates a new evar of context + [sign] and type [ty], [inst] is a mapping of the evar context to + the context where the evar should occur. This means that the terms + of [inst] are typed in the occurrence context and their type (seen + as a telescope) is [sign] *) +val new_evar_instance : + named_context_val -> 'r Sigma.t -> types -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> + ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> + constr list -> (constr, 'r) Sigma.sigma + +val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list + +val safe_evar_value : evar_map -> existential -> constr option + +(** {6 Evars/Metas switching...} *) + +val non_instantiated : evar_map -> evar_info Evar.Map.t + +(** {6 Unification utils} *) + +(** [head_evar c] returns the head evar of [c] if any *) +exception NoHeadEvar +val head_evar : constr -> existential_key (** may raise NoHeadEvar *) + +(* Expand head evar if any *) +val whd_head_evar : evar_map -> constr -> constr + +(* An over-approximation of [has_undefined (nf_evars evd c)] *) +val has_undefined_evars : evar_map -> constr -> bool + +val is_ground_term : evar_map -> constr -> bool +val is_ground_env : evar_map -> env -> bool + +(** [gather_dependent_evars evm seeds] classifies the evars in [evm] + as dependent_evars and goals (these may overlap). A goal is an + evar in [seeds] or an evar appearing in the (partial) definition + of a goal. A dependent evar is an evar appearing in the type + (hypotheses and conclusion) of a goal, or in the type or (partial) + definition of a dependent evar. The value return is a map + associating to each dependent evar [None] if it has no (partial) + definition or [Some s] if [s] is the list of evars appearing in + its (partial) definition. *) +val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t + +(** The following functions return the set of undefined evars + contained in the object, the defined evars being traversed. + This is roughly a combination of the previous functions and + [nf_evar]. *) + +val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t +val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t +val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t + +(** [occur_evar_upto sigma k c] returns [true] if [k] appears in + [c]. It looks up recursively in [sigma] for the value of existential + variables. *) +val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool + +(** {6 Value/Type constraints} *) + +val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma + +(***********************************************************) + +(** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains + uninstantiated; [nf_evar] leaves uninstantiated evars as is *) + +val whd_evar : evar_map -> constr -> constr +val nf_evar : evar_map -> constr -> constr +val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment +val jl_nf_evar : + evar_map -> unsafe_judgment list -> unsafe_judgment list +val jv_nf_evar : + evar_map -> unsafe_judgment array -> unsafe_judgment array +val tj_nf_evar : + evar_map -> unsafe_type_judgment -> unsafe_type_judgment + +val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t +val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t +val nf_env_evar : evar_map -> env -> env + +val nf_evar_info : evar_map -> evar_info -> evar_info +val nf_evar_map : evar_map -> evar_map +val nf_evar_map_undefined : evar_map -> evar_map + +(** Presenting terms without solved evars *) + +val nf_evars_universes : evar_map -> constr -> constr + +val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr) +val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst + +(** Normalize the evar map w.r.t. universes, after simplification of constraints. + Return the substitution function for constrs as well. *) +val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) + +(** Replacing all evars, possibly raising [Uninstantiated_evar] *) +exception Uninstantiated_evar of existential_key +val flush_and_check_evars : evar_map -> constr -> constr + +(** {6 Term manipulation up to instantiation} *) + +(** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t] + as an evar [e] only if [e] is uninstantiated in [sigma]. Otherwise the + value of [e] in [sigma] is (recursively) used. *) +val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term + +(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and + [u] up to existential variable instantiation and equalisable + universes. The term [t] is interpreted in [sigma1] while [u] is + interpreted in [sigma2]. The universe constraints in [sigma2] are + assumed to be an extention of those in [sigma1]. *) +val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool + +(** {6 Removing hyps in evars'context} +raise OccurHypInSimpleClause if the removal breaks dependencies *) + +type clear_dependency_error = +| OccurHypInSimpleClause of Id.t option +| EvarTypingBreak of existential + +exception ClearDependencyError of Id.t * clear_dependency_error + +(* spiwack: marks an evar that has been "defined" by clear. + used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) +val cleared : bool Store.field + +val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types -> + Id.Set.t -> named_context_val * types + +val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types -> + Id.Set.t -> named_context_val * types * types + +val push_rel_context_to_named_context : Environ.env -> types -> + named_context_val * types * constr list * constr list * (identifier*constr) list + +val generalize_evar_over_rels : evar_map -> existential -> types * constr list + +(** Evar combinators *) + +val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a +val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a +val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a + +val subterm_source : existential_key -> Evar_kinds.t Loc.located -> + Evar_kinds.t Loc.located + +val meta_counter_summary_name : string + +(** Deprecater *) + +type type_constraint = types option +type val_constraint = constr option diff --git a/engine/proofview.ml b/engine/proofview.ml new file mode 100644 index 0000000000..ba664cafaf --- /dev/null +++ b/engine/proofview.ml @@ -0,0 +1,1211 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* i+1) solution 0 in + let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in + let pruned_solution = Evd.drop_all_defined solution in + let apply_subst_einfo _ ei = + Evd.({ ei with + evar_concl = nf ei.evar_concl; + evar_hyps = Environ.map_named_val nf ei.evar_hyps; + evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in + let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in + let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in + msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); + new_el, { pv with solution = new_solution; } + + +(** {6 Starting and querying a proof view} *) + +type telescope = + | TNil of Evd.evar_map + | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) + +let typeclass_resolvable = Evd.Store.field () + +let dependent_init = + (* Goals are created with a store which marks them as unresolvable + for type classes. *) + let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in + (* Goals don't have a source location. *) + let src = (Loc.ghost,Evar_kinds.GoalEvar) in + (* Main routine *) + let rec aux = function + | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } + | TCons (env, sigma, typ, t) -> + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in + let sigma = Sigma.to_evar_map sigma in + let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in + let (gl, _) = Term.destEvar econstr in + let entry = (econstr, typ) :: ret in + entry, { solution = sol; comb = gl :: comb; shelf = [] } + in + fun t -> + let entry, v = aux t in + (* The created goal are not to be shelved. *) + let solution = Evd.reset_future_goals v.solution in + entry, { v with solution } + +let init = + let rec aux sigma = function + | [] -> TNil sigma + | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l)) + in + fun sigma l -> dependent_init (aux sigma l) + +let initial_goals initial = initial + +let finished = function + | {comb = []} -> true + | _ -> false + +let return { solution=defs } = defs + +let return_constr { solution = defs } c = Evarutil.nf_evar defs c + +let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry) + + +(** {6 Focusing commands} *) + +(** A [focus_context] represents the part of the proof view which has + been removed by a focusing action, it can be used to unfocus later + on. *) +(* First component is a reverse list of the goals which come before + and second component is the list of the goals which go after (in + the expected order). *) +type focus_context = Evar.t list * Evar.t list + + +(** Returns a stylised view of a focus_context for use by, for + instance, ide-s. *) +(* spiwack: the type of [focus_context] will change as we push more + refined functions to ide-s. This would be better than spawning a + new nearly identical function everytime. Hence the generic name. *) +(* In this version: the goals in the context, as a "zipper" (the first + list is in reversed order). *) +let focus_context f = f + +(** This (internal) function extracts a sublist between two indices, + and returns this sublist together with its context: if it returns + [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the + original list. The focused list has lenght [j-i-1] and contains + the goals from number [i] to number [j] (both included) the first + goal of the list being numbered [1]. [focus_sublist i j l] raises + [IndexOutOfRange] if [i > length l], or [j > length l] or [j < + i]. *) +let focus_sublist i j l = + let (left,sub_right) = CList.goto (i-1) l in + let (sub, right) = + try CList.chop (j-i+1) sub_right + with Failure _ -> raise CList.IndexOutOfRange + in + (sub, (left,right)) + +(** Inverse operation to the previous one. *) +let unfocus_sublist (left,right) s = + CList.rev_append left (s@right) + + +(** [focus i j] focuses a proofview on the goals from index [i] to + index [j] (inclusive, goals are indexed from [1]). I.e. goals + number [i] to [j] become the only focused goals of the returned + proofview. It returns the focused proofview, and a context for + the focus stack. *) +let focus i j sp = + let (new_comb, context) = focus_sublist i j sp.comb in + ( { sp with comb = new_comb } , context ) + + +(** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) +(* spiwack: [advance] is probably performance critical, and the good + behaviour of its definition may depend sensitively to the actual + definition of [Evd.find]. Currently, [Evd.find] starts looking for + a value in the heap of undefined variable, which is small. Hence in + the most common case, where [advance] is applied to an unsolved + goal ([advance] is used to figure if a side effect has modified the + goal) it terminates quickly. *) +let rec advance sigma g = + let open Evd in + let evi = Evd.find sigma g in + match evi.evar_body with + | Evar_empty -> Some g + | Evar_defined v -> + if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then + let (e,_) = Term.destEvar v in + advance sigma e + else + None + +(** [undefined defs l] is the list of goals in [l] which are still + unsolved (after advancing cleared goals). *) +let undefined defs l = CList.map_filter (advance defs) l + +(** Unfocuses a proofview with respect to a context. *) +let unfocus c sp = + { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } + + +(** {6 The tactic monad} *) + +(** - Tactics are objects which apply a transformation to all the + subgoals of the current view at the same time. By opposition to + the old vision of applying it to a single goal. It allows tactics + such as [shelve_unifiable], tactics to reorder the focused goals, + or global automation tactic for dependent subgoals (instantiating + an evar has influences on the other goals of the proof in + progress, not being able to take that into account causes the + current eauto tactic to fail on some instances where it could + succeed). Another benefit is that it is possible to write tactics + that can be executed even if there are no focused goals. + - Tactics form a monad ['a tactic], in a sense a tactic can be + seen as a function (without argument) which returns a value of + type 'a and modifies the environment (in our case: the view). + Tactics of course have arguments, but these are given at the + meta-level as OCaml functions. Most tactics in the sense we are + used to return [()], that is no really interesting values. But + some might pass information around. The tactics seen in Coq's + Ltac are (for now at least) only [unit tactic], the return values + are kept for the OCaml toolkit. The operation or the monad are + [Proofview.tclUNIT] (which is the "return" of the tactic monad) + [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] + (which is a specialized bind on unit-returning tactics). + - Tactics have support for full-backtracking. Tactics can be seen + having multiple success: if after returning the first success a + failure is encountered, the tactic can backtrack and use a second + success if available. The state is backtracked to its previous + value, except the non-logical state defined in the {!NonLogical} + module below. +*) +(* spiwack: as far as I'm aware this doesn't really relate to + F. Kirchner and C. Muñoz. *) + +module Proof = Logical + +(** type of tactics: + + tactics can + - access the environment, + - report unsafe status, shelved goals and given up goals + - access and change the current [proofview] + - backtrack on previous changes of the proofview *) +type +'a tactic = 'a Proof.t + +(** Applies a tactic to the current proofview. *) +let apply env t sp = + let open Logic_monad in + let ans = Proof.repr (Proof.run t false (sp,env)) in + let ans = Logic_monad.NonLogical.run ans in + match ans with + | Nil (e, info) -> iraise (TacticFailure e, info) + | Cons ((r, (state, _), status, info), _) -> + let (status, gaveup) = status in + let status = (status, state.shelf, gaveup) in + let state = { state with shelf = [] } in + r, state, status, Trace.to_tree info + + + +(** {7 Monadic primitives} *) + +(** Unit of the tactic monad. *) +let tclUNIT = Proof.return + +(** Bind operation of the tactic monad. *) +let tclBIND = Proof.(>>=) + +(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, + it's a specialized "bind". *) +let tclTHEN = Proof.(>>) + +(** [tclIGNORE t] has the same operational content as [t], but drops + the returned value. *) +let tclIGNORE = Proof.ignore + +module Monad = Proof + + + +(** {7 Failure and backtracking} *) + + +(** [tclZERO e] fails with exception [e]. It has no success. *) +let tclZERO ?info e = + let info = match info with + | None -> Exninfo.null + | Some info -> info + in + Proof.zero (e, info) + +(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever + the successes of [t1] have been depleted and it failed with [e], + then it behaves as [t2 e]. In other words, [tclOR] inserts a + backtracking point. *) +let tclOR = Proof.plus + +(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one + success or [t2 e] if [t1] fails with [e]. It is analogous to + [try/with] handler of exception in that it is not a backtracking + point. *) +let tclORELSE t1 t2 = + let open Logic_monad in + let open Proof in + split t1 >>= function + | Nil e -> t2 e + | Cons (a,t1') -> plus (return a) t1' + +(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] + succeeds at least once then it behaves as [tclBIND a s] otherwise, + if [a] fails with [e], then it behaves as [f e]. *) +let tclIFCATCH a s f = + let open Logic_monad in + let open Proof in + split a >>= function + | Nil e -> f e + | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x')) + +(** [tclONCE t] behave like [t] except it has at most one success: + [tclONCE t] stops after the first success of [t]. If [t] fails + with [e], [tclONCE t] also fails with [e]. *) +let tclONCE = Proof.once + +exception MoreThanOneSuccess +let _ = Errors.register_handler begin function + | MoreThanOneSuccess -> Errors.error "This tactic has more than one success." + | _ -> raise Errors.Unhandled +end + +(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one + success. Otherwise it fails. The tactic [t] is run until its first + success, then a failure with exception [e] is simulated. It [t] + yields another success, then [tclEXACTLY_ONCE e t] fails with + [MoreThanOneSuccess] (it is a user error). Otherwise, + [tclEXACTLY_ONCE e t] succeeds with the first success of + [t]. Notice that the choice of [e] is relevant, as the presence of + further successes may depend on [e] (see {!tclOR}). *) +let tclEXACTLY_ONCE e t = + let open Logic_monad in + let open Proof in + split t >>= function + | Nil (e, info) -> tclZERO ~info e + | Cons (x,k) -> + Proof.split (k (e, Exninfo.null)) >>= function + | Nil _ -> tclUNIT x + | _ -> tclZERO MoreThanOneSuccess + + +(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) +type 'a case = +| Fail of iexn +| Next of 'a * (iexn -> 'a tactic) +let tclCASE t = + let open Logic_monad in + let map = function + | Nil e -> Fail e + | Cons (x, t) -> Next (x, t) + in + Proof.map map (Proof.split t) + +let tclBREAK = Proof.break + + + +(** {7 Focusing tactics} *) + +exception NoSuchGoals of int + +(* This hook returns a string to be appended to the usual message. + Primarily used to add a suggestion about the right bullet to use to + focus the next goal, if applicable. *) +let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) +let set_nosuchgoals_hook f = nosuchgoals_hook := f + + + +(* This uses the hook above *) +let _ = Errors.register_handler begin function + | NoSuchGoals n -> + let suffix = !nosuchgoals_hook n in + Errors.errorlabstrm "" + (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) + | _ -> raise Errors.Unhandled +end + +(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where + only the goals numbered [i] to [j] are focused (the rest of the goals + is restored at the end of the tactic). If the range [i]-[j] is not + valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) +let tclFOCUS_gen nosuchgoal i j t = + let open Proof in + Pv.get >>= fun initial -> + try + let (focused,context) = focus i j initial in + Pv.set focused >> + t >>= fun result -> + Pv.modify (fun next -> unfocus context next) >> + return result + with CList.IndexOutOfRange -> nosuchgoal + +let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t +let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t + +(** Like {!tclFOCUS} but selects a single goal by name. *) +let tclFOCUSID id t = + let open Proof in + Pv.get >>= fun initial -> + try + let ev = Evd.evar_key id initial.solution in + try + let n = CList.index Evar.equal ev initial.comb in + (* goal is already under focus *) + let (focused,context) = focus n n initial in + Pv.set focused >> + t >>= fun result -> + Pv.modify (fun next -> unfocus context next) >> + return result + with Not_found -> + (* otherwise, save current focus and work purely on the shelve *) + Comb.set [ev] >> + t >>= fun result -> + Comb.set initial.comb >> + return result + with Not_found -> tclZERO (NoSuchGoals 1) + +(** {7 Dispatching on goals} *) + +exception SizeMismatch of int*int +let _ = Errors.register_handler begin function + | SizeMismatch (i,_) -> + let open Pp in + let errmsg = + str"Incorrect number of goals" ++ spc() ++ + str"(expected "++int i++str(String.plural i " tactic") ++ str")." + in + Errors.errorlabstrm "" errmsg + | _ -> raise Errors.Unhandled +end + +(** A variant of [Monad.List.iter] where we iter over the focused list + of goals. The argument tactic is executed in a focus comprising + only of the current goal, a goal which has been solved by side + effect is skipped. The generated subgoals are concatenated in + order. *) +let iter_goal i = + let open Proof in + Comb.get >>= fun initial -> + Proof.List.fold_left begin fun (subgoals as cur) goal -> + Solution.get >>= fun step -> + match advance step goal with + | None -> return cur + | Some goal -> + Comb.set [goal] >> + i goal >> + Proof.map (fun comb -> comb :: subgoals) Comb.get + end [] initial >>= fun subgoals -> + Solution.get >>= fun evd -> + Comb.set CList.(undefined evd (flatten (rev subgoals))) + +(** A variant of [Monad.List.fold_left2] where the first list is the + list of focused goals. The argument tactic is executed in a focus + comprising only of the current goal, a goal which has been solved + by side effect is skipped. The generated subgoals are concatenated + in order. *) +let fold_left2_goal i s l = + let open Proof in + Pv.get >>= fun initial -> + let err = + return () >>= fun () -> (* Delay the computation of list lengths. *) + tclZERO (SizeMismatch (CList.length initial.comb,CList.length l)) + in + Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> + Solution.get >>= fun step -> + match advance step goal with + | None -> return cur + | Some goal -> + Comb.set [goal] >> + i goal a r >>= fun r -> + Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get + end (s,[]) initial.comb l >>= fun (r,subgoals) -> + Solution.get >>= fun evd -> + Comb.set CList.(undefined evd (flatten (rev subgoals))) >> + return r + +(** Dispatch tacticals are used to apply a different tactic to each + goal under focus. They come in two flavours: [tclDISPATCH] takes a + list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] + takes a list of ['a tactic] and returns an ['a list tactic]. + + They both work by applying each of the tactic in a focus + restricted to the corresponding goal (starting with the first + goal). In the case of [tclDISPATCHL], the tactic returns a list of + the same size as the argument list (of tactics), each element + being the result of the tactic executed in the corresponding goal. + + When the length of the tactic list is not the number of goal, + raises [SizeMismatch (g,t)] where [g] is the number of available + goals, and [t] the number of tactics passed. + + [tclDISPATCHGEN join tacs] generalises both functions as the + successive results of [tacs] are stored in reverse order in a + list, and [join] is used to convert the result into the expected + form. *) +let tclDISPATCHGEN0 join tacs = + match tacs with + | [] -> + begin + let open Proof in + Comb.get >>= function + | [] -> tclUNIT (join []) + | comb -> tclZERO (SizeMismatch (CList.length comb,0)) + end + | [tac] -> + begin + let open Proof in + Pv.get >>= function + | { comb=[goal] ; solution } -> + begin match advance solution goal with + | None -> tclUNIT (join []) + | Some _ -> Proof.map (fun res -> join [res]) tac + end + | {comb} -> tclZERO (SizeMismatch(CList.length comb,1)) + end + | _ -> + let iter _ t cur = Proof.map (fun y -> y :: cur) t in + let ans = fold_left2_goal iter [] tacs in + Proof.map join ans + +let tclDISPATCHGEN join tacs = + let branch t = InfoL.tag (Info.DBranch) t in + let tacs = CList.map branch tacs in + InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs) + +let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs + +let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs + + +(** [extend_to_list startxs rx endxs l] builds a list + [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises + [SizeMismatch] if [startxs@endxs] is already longer than [l]. *) +let extend_to_list startxs rx endxs l = + (* spiwack: I use [l] essentially as a natural number *) + let rec duplicate acc = function + | [] -> acc + | _::rest -> duplicate (rx::acc) rest + in + let rec tail to_match rest = + match rest, to_match with + | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) + | _::rest , _::to_match -> tail to_match rest + | _ , [] -> duplicate endxs rest + in + let rec copy pref rest = + match rest,pref with + | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) + | _::rest, a::pref -> a::(copy pref rest) + | _ , [] -> tail endxs rest + in + copy startxs l + +(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] + tactic is "repeated" enough time such that every goal has a tactic + assigned to it ([b] is the list of tactics applied to the first + goals, [e] to the last goals, and [r] is applied to every goal in + between). *) +let tclEXTEND tacs1 rtac tacs2 = + let open Proof in + Comb.get >>= fun comb -> + try + let tacs = extend_to_list tacs1 rtac tacs2 comb in + tclDISPATCH tacs + with SizeMismatch _ -> + tclZERO (SizeMismatch( + CList.length comb, + (CList.length tacs1)+(CList.length tacs2))) +(* spiwack: failure occurs only when the number of goals is too + small. Hence we can assume that [rtac] is replicated 0 times for + any error message. *) + +(** [tclEXTEND [] tac []]. *) +let tclINDEPENDENT tac = + let open Proof in + Pv.get >>= fun initial -> + match initial.comb with + | [] -> tclUNIT () + | [_] -> tac + | _ -> + let tac = InfoL.tag (Info.DBranch) tac in + InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac)) + + + +(** {7 Goal manipulation} *) + +(** Shelves all the goals under focus. *) +let shelve = + let open Proof in + Comb.get >>= fun initial -> + Comb.set [] >> + InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> + Shelf.modify (fun gls -> gls @ initial) + + +(** [contained_in_info e evi] checks whether the evar [e] appears in + the hypotheses, the conclusion or the body of the evar_info + [evi]. Note: since we want to use it on goals, the body is actually + supposed to be empty. *) +let contained_in_info sigma e evi = + Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) + +(** [depends_on sigma src tgt] checks whether the goal [src] appears + as an existential variable in the definition of the goal [tgt] in + [sigma]. *) +let depends_on sigma src tgt = + let evi = Evd.find sigma tgt in + contained_in_info sigma src evi + +(** [unifiable sigma g l] checks whether [g] appears in another + subgoal of [l]. The list [l] may contain [g], but it does not + affect the result. *) +let unifiable sigma g l = + CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l + +(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] + where [u] is composed of the unifiable goals, i.e. the goals on + whose definition other goals of [l] depend, and [n] are the + non-unifiable goals. *) +let partition_unifiable sigma l = + CList.partition (fun g -> unifiable sigma g l) l + +(** Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +let shelve_unifiable = + let open Proof in + Pv.get >>= fun initial -> + let (u,n) = partition_unifiable initial.solution initial.comb in + Comb.set n >> + InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> + Shelf.modify (fun gls -> gls @ u) + +(** [guard_no_unifiable] returns the list of unifiable goals if some + goals are unifiable (see {!shelve_unifiable}) in the current focus. *) +let guard_no_unifiable = + let open Proof in + Pv.get >>= fun initial -> + let (u,n) = partition_unifiable initial.solution initial.comb in + match u with + | [] -> tclUNIT None + | gls -> + let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in + let l = CList.map (fun id -> Names.Name id) l in + tclUNIT (Some l) + +(** [unshelve l p] adds all the goals in [l] at the end of the focused + goals of p *) +let unshelve l p = + (* advance the goals in case of clear *) + let l = undefined p.solution l in + { p with comb = p.comb@l } + +let with_shelf tac = + let open Proof in + Pv.get >>= fun pv -> + let { shelf; solution } = pv in + Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> + tac >>= fun ans -> + Pv.get >>= fun npv -> + let { shelf = gls; solution = sigma } = npv in + let gls' = Evd.future_goals sigma in + let fgoals = Evd.future_goals solution in + let pgoal = Evd.principal_future_goal solution in + let sigma = Evd.restore_future_goals sigma fgoals pgoal in + Pv.set { npv with shelf; solution = sigma } >> + tclUNIT (CList.rev_append gls' gls, ans) + +(** [goodmod p m] computes the representative of [p] modulo [m] in the + interval [[0,m-1]].*) +let goodmod p m = + let p' = p mod m in + (* if [n] is negative [n mod l] is negative of absolute value less + than [l], so [(n mod l)+l] is the representative of [n] in the + interval [[0,l-1]].*) + if p' < 0 then p'+m else p' + +let cycle n = + let open Proof in + InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> + Comb.modify begin fun initial -> + let l = CList.length initial in + let n' = goodmod n l in + let (front,rear) = CList.chop n' initial in + rear@front + end + +let swap i j = + let open Proof in + InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> + Comb.modify begin fun initial -> + let l = CList.length initial in + let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in + let i = goodmod i l and j = goodmod j l in + CList.map_i begin fun k x -> + match k with + | k when Int.equal k i -> CList.nth initial j + | k when Int.equal k j -> CList.nth initial i + | _ -> x + end 0 initial + end + +let revgoals = + let open Proof in + InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> + Comb.modify CList.rev + +let numgoals = + let open Proof in + Comb.get >>= fun comb -> + return (CList.length comb) + + + +(** {7 Access primitives} *) + +let tclEVARMAP = Solution.get + +let tclENV = Env.get + + + +(** {7 Put-like primitives} *) + + +let emit_side_effects eff x = + { x with solution = Evd.emit_side_effects eff x.solution } + +let tclEFFECTS eff = + let open Proof in + return () >>= fun () -> (* The Global.env should be taken at exec time *) + Env.set (Global.env ()) >> + Pv.modify (fun initial -> emit_side_effects eff initial) + +let mark_as_unsafe = Status.put false + +(** Gives up on the goal under focus. Reports an unsafe status. Proofs + with given up goals cannot be closed. *) +let give_up = + let open Proof in + Comb.get >>= fun initial -> + Comb.set [] >> + mark_as_unsafe >> + InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> + Giveup.put initial + + + +(** {7 Control primitives} *) + + +module Progress = struct + + let eq_constr = Evarutil.eq_constr_univs_test + + (** equality function on hypothesis contexts *) + let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = + let open Environ in + let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in + let eq_named_declaration d1 d2 = + match d1, d2 with + | LocalAssum (i1,t1), LocalAssum (i2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 + | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 + && eq_constr sigma1 sigma2 t1 t2 + | _ -> + false + in List.equal eq_named_declaration c1 c2 + + let eq_evar_body sigma1 sigma2 b1 b2 = + let open Evd in + match b1, b2 with + | Evar_empty, Evar_empty -> true + | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2 + | _ -> false + + let eq_evar_info sigma1 sigma2 ei1 ei2 = + let open Evd in + eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl && + eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) && + eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body + + (** Equality function on goals *) + let goal_equal evars1 gl1 evars2 gl2 = + let evi1 = Evd.find evars1 gl1 in + let evi2 = Evd.find evars2 gl2 in + eq_evar_info evars1 evars2 evi1 evi2 + +end + +let tclPROGRESS t = + let open Proof in + Pv.get >>= fun initial -> + t >>= fun res -> + Pv.get >>= fun final -> + (* [*_test] test absence of progress. [quick_test] is approximate + whereas [exhaustive_test] is complete. *) + let quick_test = + initial.solution == final.solution && initial.comb == final.comb + in + let exhaustive_test = + Util.List.for_all2eq begin fun i f -> + Progress.goal_equal initial.solution i final.solution f + end initial.comb final.comb + in + let test = + quick_test || exhaustive_test + in + if not test then + tclUNIT res + else + tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) + +exception Timeout +let _ = Errors.register_handler begin function + | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | _ -> Pervasives.raise Errors.Unhandled +end + +let tclTIMEOUT n t = + let open Proof in + (* spiwack: as one of the monad is a continuation passing monad, it + doesn't force the computation to be threaded inside the underlying + (IO) monad. Hence I force it myself by asking for the evaluation of + a dummy value first, lest [timeout] be called when everything has + already been computed. *) + let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in + Proof.get >>= fun initial -> + Proof.current >>= fun envvar -> + Proof.lift begin + Logic_monad.NonLogical.catch + begin + let open Logic_monad.NonLogical in + timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> + match r with + | Logic_monad.Nil e -> return (Util.Inr e) + | Logic_monad.Cons (r, _) -> return (Util.Inl r) + end + begin let open Logic_monad.NonLogical in function (e, info) -> + match e with + | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) + | Logic_monad.TacticFailure e -> + return (Util.Inr (e, info)) + | e -> Logic_monad.NonLogical.raise ~info e + end + end >>= function + | Util.Inl (res,s,m,i) -> + Proof.set s >> + Proof.put m >> + Proof.update (fun _ -> i) >> + return res + | Util.Inr (e, info) -> tclZERO ~info e + +let tclTIME s t = + let pr_time t1 t2 n msg = + let msg = + if n = 0 then + str msg + else + str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking") + in + msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ + System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in + let rec aux n t = + let open Proof in + tclUNIT () >>= fun () -> + let tstart = System.get_time() in + Proof.split t >>= let open Logic_monad in function + | Nil (e, info) -> + begin + let tend = System.get_time() in + pr_time tstart tend n "failure"; + tclZERO ~info e + end + | Cons (x,k) -> + let tend = System.get_time() in + pr_time tstart tend n "success"; + tclOR (tclUNIT x) (fun e -> aux (n+1) (k e)) + in aux 0 t + + + +(** {7 Unsafe primitives} *) + +module Unsafe = struct + + let tclEVARS evd = + Pv.modify (fun ps -> { ps with solution = evd }) + + let tclNEWGOALS gls = + Pv.modify begin fun step -> + let gls = undefined step.solution gls in + { step with comb = step.comb @ gls } + end + + let tclGETGOALS = Comb.get + + let tclSETGOALS = Comb.set + + let tclEVARSADVANCE evd = + Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) + + let tclEVARUNIVCONTEXT ctx = + Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) + + let reset_future_goals p = + { p with solution = Evd.reset_future_goals p.solution } + + let mark_as_goal evd content = + let info = Evd.find evd content in + let info = + { info with Evd.evar_source = match info.Evd.evar_source with + | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x + | loc,_ -> loc,Evar_kinds.GoalEvar } + in + let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with + | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } + | Some () -> info + in + Evd.add evd content info + + let advance = advance + + let typeclass_resolvable = typeclass_resolvable + +end + +module UnsafeRepr = Proof.Unsafe + +let (>>=) = tclBIND +let (<*>) = tclTHEN +let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + +(** {6 Goal-dependent tactics} *) + +let goal_env evars gl = + let evi = Evd.find evars gl in + Evd.evar_filtered_env evi + +let goal_nf_evar sigma gl = + let evi = Evd.find sigma gl in + let evi = Evarutil.nf_evar_info sigma evi in + let sigma = Evd.add sigma gl evi in + (gl, sigma) + +let goal_extra evars gl = + let evi = Evd.find evars gl in + evi.Evd.evar_extra + + +let catchable_exception = function + | Logic_monad.Exception _ -> false + | e -> Errors.noncritical e + + +module Goal = struct + + type ('a, 'r) t = { + env : Environ.env; + sigma : Evd.evar_map; + concl : Term.constr ; + self : Evar.t ; (* for compatibility with old-style definitions *) + } + + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } + + let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) + + let env { env=env } = env + let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma + let hyps { env=env } = Environ.named_context env + let concl { concl=concl } = concl + let extra { sigma=sigma; self=self } = goal_extra sigma self + + let raw_concl { concl=concl } = concl + + + let gmake_with info env sigma goal = + { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ; + sigma = sigma ; + concl = Evd.evar_concl info ; + self = goal } + + let nf_gmake env sigma goal = + let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in + let sigma = Evd.add sigma goal info in + gmake_with info env sigma goal , sigma + + let nf_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let (gl, sigma) = nf_gmake env sigma goal in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let normalize { self } = + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + let (gl,sigma) = nf_gmake env sigma self in + tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) + + let gmake env sigma goal = + let info = Evd.find sigma goal in + gmake_with info env sigma goal + + let enter f = + let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try f (gmake env sigma goal) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } + + let s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let gl = gmake env sigma goal in + let Sigma (tac, sigma, _) = f.s_enter gl in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let nf_s_enter f = + InfoL.tag (Info.Dispatch) begin + iter_goal begin fun goal -> + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + try + let (gl, sigma) = nf_gmake env sigma goal in + let Sigma (tac, sigma, _) = f.s_enter gl in + let sigma = Sigma.to_evar_map sigma in + tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + end + end + + let goals = + Pv.get >>= fun step -> + let sigma = step.solution in + let map goal = + match advance sigma goal with + | None -> None (** ppedrot: Is this check really necessary? *) + | Some goal -> + let gl = + Env.get >>= fun env -> + tclEVARMAP >>= fun sigma -> + tclUNIT (gmake env sigma goal) + in + Some gl + in + tclUNIT (CList.map_filter map step.comb) + + (* compatibility *) + let goal { self=self } = self + + let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) + +end + + + +(** {6 Trace} *) + +module Trace = struct + + let record_info_trace = InfoL.record_trace + + let log m = InfoL.leaf (Info.Msg m) + let name_tactic m t = InfoL.tag (Info.Tactic m) t + + let pr_info ?(lvl=0) info = + assert (lvl >= 0); + Info.(print (collapse lvl info)) + +end + + + +(** {6 Non-logical state} *) + +module NonLogical = Logic_monad.NonLogical + +let tclLIFT = Proof.lift + +let tclCHECKINTERRUPT = + tclLIFT (NonLogical.make Control.check_for_interrupt) + + + + + +(*** Compatibility layer with <= 8.2 tactics ***) +module V82 = struct + type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma + + let tactic tac = + (* spiwack: we ignore the dependencies between goals here, + expectingly preserving the semantics of <= 8.2 tactics *) + (* spiwack: convenience notations, waiting for ocaml 3.12 *) + let open Proof in + Pv.get >>= fun ps -> + try + let tac gl evd = + let glsigma = + tac { Evd.it = gl ; sigma = evd; } in + let sigma = glsigma.Evd.sigma in + let g = glsigma.Evd.it in + ( g, sigma ) + in + (* Old style tactics expect the goals normalized with respect to evars. *) + let (initgoals,initevd) = + Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution + in + let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in + let sgs = CList.flatten goalss in + let sgs = undefined evd sgs in + InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> + Pv.set { ps with solution = evd; comb = sgs; } + with e when catchable_exception e -> + let (e, info) = Errors.push e in + tclZERO ~info e + + + (* normalises the evars in the goals, and stores the result in + solution. *) + let nf_evar_goals = + Pv.modify begin fun ps -> + let map g s = goal_nf_evar s g in + let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in + { ps with solution = evd; comb = goals; } + end + + let has_unresolved_evar pv = + Evd.has_undefined pv.solution + + (* Main function in the implementation of Grab Existential Variables.*) + let grab pv = + let undef = Evd.undefined_map pv.solution in + let goals = CList.rev_map fst (Evar.Map.bindings undef) in + { pv with comb = goals } + + + + (* Returns the open goals of the proofview together with the evar_map to + interpret them. *) + let goals { comb = comb ; solution = solution; } = + { Evd.it = comb ; sigma = solution } + + let top_goals initial { solution=solution; } = + let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in + { Evd.it = goals ; sigma=solution; } + + let top_evars initial = + let evars_of_initial (c,_) = + Evar.Set.elements (Evd.evars_of_term c) + in + CList.flatten (CList.map evars_of_initial initial) + + let of_tactic t gls = + try + let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in + let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in + { Evd.sigma = final.solution ; it = final.comb } + with Logic_monad.TacticFailure e as src -> + let (_, info) = Errors.push src in + iraise (e, info) + + let put_status = Status.put + + let catchable_exception = catchable_exception + + let wrap_exceptions f = + try f () + with e when catchable_exception e -> + let (e, info) = Errors.push e in tclZERO ~info e + +end + +(** {7 Notations} *) + +module Notations = struct + let (>>=) = tclBIND + let (<*>) = tclTHEN + let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } +end diff --git a/engine/proofview.mli b/engine/proofview.mli new file mode 100644 index 0000000000..7996b7969c --- /dev/null +++ b/engine/proofview.mli @@ -0,0 +1,589 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Goal.goal list * Evd.evar_map + + +(** {6 Starting and querying a proof view} *) + +(** Abstract representation of the initial goals of a proof. *) +type entry + +(** Optimize memory consumption *) +val compact : entry -> proofview -> entry * proofview + +(** Initialises a proofview, the main argument is a list of + environments (including a [named_context] which are used as + hypotheses) pair with conclusion types, creating accordingly many + initial goals. Because a proof does not necessarily starts in an + empty [evar_map] (indeed a proof can be triggered by an incomplete + pretyping), [init] takes an additional argument to represent the + initial [evar_map]. *) +val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview + +(** A [telescope] is a list of environment and conclusion like in + {!init}, except that each element may depend on the previous + goals. The telescope passes the goals in the form of a + [Term.constr] which represents the goal as an [evar]. The + [evar_map] is threaded in state passing style. *) +type telescope = + | TNil of Evd.evar_map + | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) + +(** Like {!init}, but goals are allowed to be dependent on one + another. Dependencies between goals is represented with the type + [telescope] instead of [list]. Note that the first [evar_map] of + the telescope plays the role of the [evar_map] argument in + [init]. *) +val dependent_init : telescope -> entry * proofview + +(** [finished pv] is [true] if and only if [pv] is complete. That is, + if it has an empty list of focused goals. There could still be + unsolved subgoaled, but they would then be out of focus. *) +val finished : proofview -> bool + +(** Returns the current [evar] state. *) +val return : proofview -> Evd.evar_map + +val partial_proof : entry -> proofview -> constr list +val initial_goals : entry -> (constr * types) list + + + +(** {6 Focusing commands} *) + +(** A [focus_context] represents the part of the proof view which has + been removed by a focusing action, it can be used to unfocus later + on. *) +type focus_context + +(** Returns a stylised view of a focus_context for use by, for + instance, ide-s. *) +(* spiwack: the type of [focus_context] will change as we push more + refined functions to ide-s. This would be better than spawning a + new nearly identical function everytime. Hence the generic name. *) +(* In this version: the goals in the context, as a "zipper" (the first + list is in reversed order). *) +val focus_context : focus_context -> Goal.goal list * Goal.goal list + +(** [focus i j] focuses a proofview on the goals from index [i] to + index [j] (inclusive, goals are indexed from [1]). I.e. goals + number [i] to [j] become the only focused goals of the returned + proofview. It returns the focused proofview, and a context for + the focus stack. *) +val focus : int -> int -> proofview -> proofview * focus_context + +(** Unfocuses a proofview with respect to a context. *) +val unfocus : focus_context -> proofview -> proofview + + +(** {6 The tactic monad} *) + +(** - Tactics are objects which apply a transformation to all the + subgoals of the current view at the same time. By opposition to + the old vision of applying it to a single goal. It allows tactics + such as [shelve_unifiable], tactics to reorder the focused goals, + or global automation tactic for dependent subgoals (instantiating + an evar has influences on the other goals of the proof in + progress, not being able to take that into account causes the + current eauto tactic to fail on some instances where it could + succeed). Another benefit is that it is possible to write tactics + that can be executed even if there are no focused goals. + - Tactics form a monad ['a tactic], in a sense a tactic can be + seen as a function (without argument) which returns a value of + type 'a and modifies the environment (in our case: the view). + Tactics of course have arguments, but these are given at the + meta-level as OCaml functions. Most tactics in the sense we are + used to return [()], that is no really interesting values. But + some might pass information around. The tactics seen in Coq's + Ltac are (for now at least) only [unit tactic], the return values + are kept for the OCaml toolkit. The operation or the monad are + [Proofview.tclUNIT] (which is the "return" of the tactic monad) + [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] + (which is a specialized bind on unit-returning tactics). + - Tactics have support for full-backtracking. Tactics can be seen + having multiple success: if after returning the first success a + failure is encountered, the tactic can backtrack and use a second + success if available. The state is backtracked to its previous + value, except the non-logical state defined in the {!NonLogical} + module below. +*) + + +(** The abstract type of tactics *) +type +'a tactic + +(** Applies a tactic to the current proofview. Returns a tuple + [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv] + is the updated proofview, [b] a boolean which is [true] if the + tactic has not done any action considered unsafe (such as + admitting a lemma), [sh] is the list of goals which have been + shelved by the tactic, and [gu] the list of goals on which the + tactic has given up. In case of multiple success the first one is + selected. If there is no success, fails with + {!Logic_monad.TacticFailure}*) +val apply : Environ.env -> 'a tactic -> proofview -> 'a + * proofview + * (bool*Goal.goal list*Goal.goal list) + * Proofview_monad.Info.tree + +(** {7 Monadic primitives} *) + +(** Unit of the tactic monad. *) +val tclUNIT : 'a -> 'a tactic + +(** Bind operation of the tactic monad. *) +val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + +(** Interprets the ";" (semicolon) of Ltac. As a monadic operation, + it's a specialized "bind". *) +val tclTHEN : unit tactic -> 'a tactic -> 'a tactic + +(** [tclIGNORE t] has the same operational content as [t], but drops + the returned value. *) +val tclIGNORE : 'a tactic -> unit tactic + +(** Generic monadic combinators for tactics. *) +module Monad : Monad.S with type +'a t = 'a tactic + +(** {7 Failure and backtracking} *) + +(** [tclZERO e] fails with exception [e]. It has no success. *) +val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic + +(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever + the successes of [t1] have been depleted and it failed with [e], + then it behaves as [t2 e]. In other words, [tclOR] inserts a + backtracking point. *) +val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic + +(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one + success or [t2 e] if [t1] fails with [e]. It is analogous to + [try/with] handler of exception in that it is not a backtracking + point. *) +val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic + +(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] + succeeds at least once then it behaves as [tclBIND a s] otherwise, + if [a] fails with [e], then it behaves as [f e]. *) +val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic + +(** [tclONCE t] behave like [t] except it has at most one success: + [tclONCE t] stops after the first success of [t]. If [t] fails + with [e], [tclONCE t] also fails with [e]. *) +val tclONCE : 'a tactic -> 'a tactic + +(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one + success. Otherwise it fails. The tactic [t] is run until its first + success, then a failure with exception [e] is simulated. It [t] + yields another success, then [tclEXACTLY_ONCE e t] fails with + [MoreThanOneSuccess] (it is a user error). Otherwise, + [tclEXACTLY_ONCE e t] succeeds with the first success of + [t]. Notice that the choice of [e] is relevant, as the presence of + further successes may depend on [e] (see {!tclOR}). *) +exception MoreThanOneSuccess +val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic + +(** [tclCASE t] splits [t] into its first success and a + continuation. It is the most general primitive to control + backtracking. *) +type 'a case = + | Fail of iexn + | Next of 'a * (iexn -> 'a tactic) +val tclCASE : 'a tactic -> 'a case tactic + +(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of + stopping after the first success, it succeeds like [t] until a + failure with an exception [e] such that [p e = Some e'] is raised. At + which point it drops the remaining successes, failing with [e']. + [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *) +val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic + + +(** {7 Focusing tactics} *) + +(** [tclFOCUS i j t] applies [t] after focusing on the goals number + [i] to [j] (see {!focus}). The rest of the goals is restored after + the tactic action. If the specified range doesn't correspond to + existing goals, fails with [NoSuchGoals] (a user error). this + exception is caught at toplevel with a default message + a hook + message that can be customized by [set_nosuchgoals_hook] below. + This hook is used to add a suggestion about bullets when + applicable. *) +exception NoSuchGoals of int +val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit + +val tclFOCUS : int -> int -> 'a tactic -> 'a tactic + +(** [tclFOCUSID x t] applies [t] on a (single) focused goal like + {!tclFOCUS}. The goal is found by its name rather than its + number.*) +val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic + +(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the + specified range doesn't correspond to existing goals, behaves like + [tclUNIT ()] instead of failing. *) +val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic + + +(** {7 Dispatching on goals} *) + +(** Dispatch tacticals are used to apply a different tactic to each + goal under focus. They come in two flavours: [tclDISPATCH] takes a + list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] + takes a list of ['a tactic] and returns an ['a list tactic]. + + They both work by applying each of the tactic in a focus + restricted to the corresponding goal (starting with the first + goal). In the case of [tclDISPATCHL], the tactic returns a list of + the same size as the argument list (of tactics), each element + being the result of the tactic executed in the corresponding goal. + + When the length of the tactic list is not the number of goal, + raises [SizeMismatch (g,t)] where [g] is the number of available + goals, and [t] the number of tactics passed. *) +exception SizeMismatch of int*int +val tclDISPATCH : unit tactic list -> unit tactic +val tclDISPATCHL : 'a tactic list -> 'a list tactic + +(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] + tactic is "repeated" enough time such that every goal has a tactic + assigned to it ([b] is the list of tactics applied to the first + goals, [e] to the last goals, and [r] is applied to every goal in + between). *) +val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic + +(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from + the first one to the last one. Backtracking in one goal is + independent of backtracking in another. It is equivalent to + [tclEXTEND [] tac []]. *) +val tclINDEPENDENT : unit tactic -> unit tactic + + +(** {7 Goal manipulation} *) + +(** Shelves all the goals under focus. The goals are placed on the + shelf for later use (or being solved by side-effects). *) +val shelve : unit tactic + +(** Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +val shelve_unifiable : unit tactic + +(** [guard_no_unifiable] returns the list of unifiable goals if some + goals are unifiable (see {!shelve_unifiable}) in the current focus. *) +val guard_no_unifiable : Names.Name.t list option tactic + +(** [unshelve l p] adds all the goals in [l] at the end of the focused + goals of p *) +val unshelve : Goal.goal list -> proofview -> proofview + +(** [with_shelf tac] executes [tac] and returns its result together with the set + of goals shelved by [tac]. The current shelf is unchanged. *) +val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic + +(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] + is negative, then it puts the [n] last goals first.*) +val cycle : int -> unit tactic + +(** [swap i j] swaps the position of goals number [i] and [j] + (negative numbers can be used to address goals from the end. Goals + are indexed from [1]. For simplicity index [0] corresponds to goal + [1] as well, rather than raising an error. *) +val swap : int -> int -> unit tactic + +(** [revgoals] reverses the list of focused goals. *) +val revgoals : unit tactic + +(** [numgoals] returns the number of goals under focus. *) +val numgoals : int tactic + + +(** {7 Access primitives} *) + +(** [tclEVARMAP] doesn't affect the proof, it returns the current + [evar_map]. *) +val tclEVARMAP : Evd.evar_map tactic + +(** [tclENV] doesn't affect the proof, it returns the current + environment. It is not the environment of a particular goal, + rather the "global" environment of the proof. The goal-wise + environment is obtained via {!Proofview.Goal.env}. *) +val tclENV : Environ.env tactic + + +(** {7 Put-like primitives} *) + +(** [tclEFFECTS eff] add the effects [eff] to the current state. *) +val tclEFFECTS : Safe_typing.private_constants -> unit tactic + +(** [mark_as_unsafe] declares the current tactic is unsafe. *) +val mark_as_unsafe : unit tactic + +(** Gives up on the goal under focus. Reports an unsafe status. Proofs + with given up goals cannot be closed. *) +val give_up : unit tactic + + +(** {7 Control primitives} *) + +(** [tclPROGRESS t] checks the state of the proof after [t]. It it is + identical to the state before, then [tclePROGRESS t] fails, otherwise + it succeeds like [t]. *) +val tclPROGRESS : 'a tactic -> 'a tactic + +(** Checks for interrupts *) +val tclCHECKINTERRUPT : unit tactic + +exception Timeout +(** [tclTIMEOUT n t] can have only one success. + In case of timeout if fails with [tclZERO Timeout]. *) +val tclTIMEOUT : int -> 'a tactic -> 'a tactic + +(** [tclTIME s t] displays time for each atomic call to t, using s as an + identifying annotation if present *) +val tclTIME : string option -> 'a tactic -> 'a tactic + +(** {7 Unsafe primitives} *) + +(** The primitives in the [Unsafe] module should be avoided as much as + possible, since they can make the proof state inconsistent. They are + nevertheless helpful, in particular when interfacing the pretyping and + the proof engine. *) +module Unsafe : sig + + (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If + [sigma] has new unresolved [evar]-s they will not appear as + goal. If goals have been solved in [sigma] they will still + appear as unsolved goals. *) + val tclEVARS : Evd.evar_map -> unit tactic + + (** Like {!tclEVARS} but also checks whether goals have been solved. *) + val tclEVARSADVANCE : Evd.evar_map -> unit tactic + + (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently + being proved, appending them to the list of focused goals. If a + goal is already solved, it is not added. *) + val tclNEWGOALS : Goal.goal list -> unit tactic + + (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a + goal is already solved, it is not set. *) + val tclSETGOALS : Goal.goal list -> unit tactic + + (** [tclGETGOALS] returns the list of goals under focus. *) + val tclGETGOALS : Goal.goal list tactic + + (** Sets the evar universe context. *) + val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic + + (** Clears the future goals store in the proof view. *) + val reset_future_goals : proofview -> proofview + + (** Give an evar the status of a goal (changes its source location + and makes it unresolvable for type classes. *) + val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map + + (** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) + val advance : Evd.evar_map -> Evar.t -> Evar.t option + + val typeclass_resolvable : unit Evd.Store.field + +end + +(** This module gives access to the innards of the monad. Its use is + restricted to very specific cases. *) +module UnsafeRepr : +sig + type state = Proofview_monad.Logical.Unsafe.state + val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t + val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic +end + +(** {6 Goal-dependent tactics} *) + +module Goal : sig + + (** Type of goals. + + The first parameter type is a phantom argument indicating whether the data + contained in the goal has been normalized w.r.t. the current sigma. If it + is the case, it is flagged [ `NF ]. You may still access the un-normalized + data using {!assume} if you known you do not rely on the assumption of + being normalized, at your own risk. + + The second parameter is a stage indicating where the goal belongs. See + module {!Sigma}. + *) + type ('a, 'r) t + + (** Assume that you do not need the goal to be normalized. *) + val assume : ('a, 'r) t -> ([ `NF ], 'r) t + + (** Normalises the argument goal. *) + val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic + + (** [concl], [hyps], [env] and [sigma] given a goal [gl] return + respectively the conclusion of [gl], the hypotheses of [gl], the + environment of [gl] (i.e. the global environment and the + hypotheses) and the current evar map. *) + val concl : ([ `NF ], 'r) t -> Term.constr + val hyps : ([ `NF ], 'r) t -> Context.Named.t + val env : ('a, 'r) t -> Environ.env + val sigma : ('a, 'r) t -> 'r Sigma.t + val extra : ('a, 'r) t -> Evd.Store.t + + (** Returns the goal's conclusion even if the goal is not + normalised. *) + val raw_concl : ('a, 'r) t -> Term.constr + + type ('a, 'b) enter = + { enter : 'r. ('a, 'r) t -> 'b } + + (** [nf_enter t] applies the goal-dependent tactic [t] in each goal + independently, in the manner of {!tclINDEPENDENT} except that + the current goal is also given as an argument to [t]. The goal + is normalised with respect to evars. *) + val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic + + (** Like {!nf_enter}, but does not normalize the goal beforehand. *) + val enter : ([ `LZ ], unit tactic) enter -> unit tactic + + type ('a, 'b) s_enter = + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } + + (** A variant of {!enter} allows to work with a monotonic state. The evarmap + returned by the argument is put back into the current state before firing + the returned tactic. *) + val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic + + (** Like {!s_enter}, but normalizes the goal beforehand. *) + val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic + + (** Recover the list of current goals under focus, without evar-normalization. + FIXME: encapsulate the level in an existential type. *) + val goals : ([ `LZ ], 'r) t tactic list tactic + + (** Compatibility: avoid if possible *) + val goal : ([ `NF ], 'r) t -> Evar.t + + (** Every goal is valid at a later stage. FIXME: take a later evarmap *) + val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t + +end + + +(** {6 Trace} *) + +module Trace : sig + + (** [record_info_trace t] behaves like [t] except the [info] trace + is stored. *) + val record_info_trace : 'a tactic -> 'a tactic + + val log : Proofview_monad.lazy_msg -> unit tactic + val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic + + val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds + +end + + +(** {6 Non-logical state} *) + +(** The [NonLogical] module allows the execution of effects (including + I/O) in tactics (non-logical side-effects are not discarded at + failures). *) +module NonLogical : module type of Logic_monad.NonLogical + +(** [tclLIFT c] is a tactic which behaves exactly as [c]. *) +val tclLIFT : 'a NonLogical.t -> 'a tactic + + +(**/**) + +(*** Compatibility layer with <= 8.2 tactics ***) +module V82 : sig + type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma + val tactic : tac -> unit tactic + + (* normalises the evars in the goals, and stores the result in + solution. *) + val nf_evar_goals : unit tactic + + val has_unresolved_evar : proofview -> bool + + (* Main function in the implementation of Grab Existential Variables. + Resets the proofview's goals so that it contains all unresolved evars + (in chronological order of insertion). *) + val grab : proofview -> proofview + + (* Returns the open goals of the proofview together with the evar_map to + interpret them. *) + val goals : proofview -> Evar.t list Evd.sigma + + val top_goals : entry -> proofview -> Evar.t list Evd.sigma + + (* returns the existential variable used to start the proof *) + val top_evars : entry -> Evd.evar list + + (* Caution: this function loses quite a bit of information. It + should be avoided as much as possible. It should work as + expected for a tactic obtained from {!V82.tactic} though. *) + val of_tactic : 'a tactic -> tac + + (* marks as unsafe if the argument is [false] *) + val put_status : bool -> unit tactic + + (* exception for which it is deemed to be safe to transmute into + tactic failure. *) + val catchable_exception : exn -> bool + + (* transforms every Ocaml (catchable) exception into a failure in + the monad. *) + val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic +end + +(** {7 Notations} *) + +module Notations : sig + + (** {!tclBIND} *) + val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic + (** {!tclTHEN} *) + val (<*>) : unit tactic -> 'a tactic -> 'a tactic + (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) + val (<+>) : 'a tactic -> 'a tactic -> 'a tactic + + type ('a, 'b) enter = ('a, 'b) Goal.enter = + { enter : 'r. ('a, 'r) Goal.t -> 'b } + type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } +end diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml deleted file mode 100644 index 2bd67dcdc8..0000000000 --- a/pretyping/evarutil.ml +++ /dev/null @@ -1,723 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* None - -(** Combinators *) - -let evd_comb0 f evdref = - let (evd',x) = f !evdref in - evdref := evd'; - x - -let evd_comb1 f evdref x = - let (evd',y) = f !evdref x in - evdref := evd'; - y - -let evd_comb2 f evdref x y = - let (evd',z) = f !evdref x y in - evdref := evd'; - z - -let e_new_global evdref x = - evd_comb1 (Evd.fresh_global (Global.env())) evdref x - -let new_global evd x = - Sigma.fresh_global (Global.env()) evd x - -(****************************************************) -(* Expanding/testing/exposing existential variables *) -(****************************************************) - -(* flush_and_check_evars fails if an existential is undefined *) - -exception Uninstantiated_evar of existential_key - -let rec flush_and_check_evars sigma c = - match kind_of_term c with - | Evar (evk,_ as ev) -> - (match existential_opt_value sigma ev with - | None -> raise (Uninstantiated_evar evk) - | Some c -> flush_and_check_evars sigma c) - | _ -> map_constr (flush_and_check_evars sigma) c - -(* let nf_evar_key = Profile.declare_profile "nf_evar" *) -(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) - -let rec whd_evar sigma c = - match kind_of_term c with - | Evar ev -> - let (evk, args) = ev in - let args = Array.map (fun c -> whd_evar sigma c) args in - (match safe_evar_value sigma (evk, args) with - Some c -> whd_evar sigma c - | None -> c) - | Sort (Type u) -> - let u' = Evd.normalize_universe sigma u in - if u' == u then c else mkSort (Sorts.sort_of_univ u') - | Const (c', u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstU (c', u') - | Ind (i, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkIndU (i, u') - | Construct (co, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstructU (co, u') - | _ -> c - -let rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t) - -let j_nf_evar sigma j = - { uj_val = nf_evar sigma j.uj_val; - uj_type = nf_evar sigma j.uj_type } -let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl -let jv_nf_evar sigma = Array.map (j_nf_evar sigma) -let tj_nf_evar sigma {utj_val=v;utj_type=t} = - {utj_val=nf_evar sigma v;utj_type=t} - -let nf_evars_universes evm = - Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) - (Evd.universe_subst evm) - -let nf_evars_and_universes evm = - let evm = Evd.nf_constraints evm in - evm, nf_evars_universes evm - -let e_nf_evars_and_universes evdref = - evdref := Evd.nf_constraints !evdref; - nf_evars_universes !evdref, Evd.universe_subst !evdref - -let nf_evar_map_universes evm = - let evm = Evd.nf_constraints evm in - let subst = Evd.universe_subst evm in - if Univ.LMap.is_empty subst then evm, nf_evar evm - else - let f = nf_evars_universes evm in - Evd.raw_map (fun _ -> map_evar_info f) evm, f - -let nf_named_context_evar sigma ctx = - Context.Named.map (nf_evar sigma) ctx - -let nf_rel_context_evar sigma ctx = - Context.Rel.map (nf_evar sigma) ctx - -let nf_env_evar sigma env = - let nc' = nf_named_context_evar sigma (Environ.named_context env) in - let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in - push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) - -let nf_evar_info evc info = map_evar_info (nf_evar evc) info - -let nf_evar_map evm = - Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm - -let nf_evar_map_undefined evm = - Evd.raw_map_undefined (fun _ evi -> nf_evar_info evm evi) evm - -(*-------------------*) -(* Auxiliary functions for the conversion algorithms modulo evars - *) - -(* A probably faster though more approximative variant of - [has_undefined (nf_evar c)]: instances are not substituted and - maybe an evar occurs in an instance and it would disappear by - instantiation *) - -let has_undefined_evars evd t = - let rec has_ev t = - match kind_of_term t with - | Evar (ev,args) -> - (match evar_body (Evd.find evd ev) with - | Evar_defined c -> - has_ev c; Array.iter has_ev args - | Evar_empty -> - raise NotInstantiatedEvar) - | _ -> iter_constr has_ev t in - try let _ = has_ev t in false - with (Not_found | NotInstantiatedEvar) -> true - -let is_ground_term evd t = - not (has_undefined_evars evd t) - -let is_ground_env evd env = - let open Context.Rel.Declaration in - let is_ground_rel_decl = function - | LocalDef (_,b,_) -> is_ground_term evd b - | _ -> true in - let open Context.Named.Declaration in - let is_ground_named_decl = function - | LocalDef (_,b,_) -> is_ground_term evd b - | _ -> true in - List.for_all is_ground_rel_decl (rel_context env) && - List.for_all is_ground_named_decl (named_context env) - -(* Memoization is safe since evar_map and environ are applicative - structures *) -let memo f = - let m = ref None in - fun x y -> match !m with - | Some (x', y', r) when x == x' && y == y' -> r - | _ -> let r = f x y in m := Some (x, y, r); r - -let is_ground_env = memo is_ground_env - -(* Return the head evar if any *) - -exception NoHeadEvar - -let head_evar = - let rec hrec c = match kind_of_term c with - | Evar (evk,_) -> evk - | Case (_,_,c,_) -> hrec c - | App (c,_) -> hrec c - | Cast (c,_,_) -> hrec c - | _ -> raise NoHeadEvar - in - hrec - -(* Expand head evar if any (currently consider only applications but I - guess it should consider Case too) *) - -let whd_head_evar_stack sigma c = - let rec whrec (c, l as s) = - match kind_of_term c with - | Evar (evk,args as ev) -> - let v = - try Some (existential_value sigma ev) - with NotInstantiatedEvar | Not_found -> None in - begin match v with - | None -> s - | Some c -> whrec (c, l) - end - | Cast (c,_,_) -> whrec (c, l) - | App (f,args) -> whrec (f, args :: l) - | _ -> s - in - whrec (c, []) - -let whd_head_evar sigma c = - let (f, args) = whd_head_evar_stack sigma c in - (** optim: don't reallocate if empty/singleton *) - match args with - | [] -> f - | [arg] -> mkApp (f, arg) - | _ -> mkApp (f, Array.concat args) - -(**********************) -(* Creating new metas *) -(**********************) - -let meta_counter_summary_name = "meta counter" - -(* Generator of metavariables *) -let new_meta = - let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in - fun () -> incr meta_ctr; !meta_ctr - -let mk_new_meta () = mkMeta(new_meta()) - -(* The list of non-instantiated existential declarations (order is important) *) - -let non_instantiated sigma = - let listev = Evd.undefined_map sigma in - Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev - -(************************) -(* Manipulating filters *) -(************************) - -let make_pure_subst evi args = - let open Context.Named.Declaration in - snd (List.fold_right - (fun decl (args,l) -> - match args with - | a::rest -> (rest, (get_id decl, a)::l) - | _ -> anomaly (Pp.str "Instance does not match its signature")) - (evar_filtered_context evi) (Array.rev_to_list args,[])) - -(*------------------------------------* - * functional operations on evar sets * - *------------------------------------*) - -(* [push_rel_context_to_named_context] builds the defining context and the - * initial instance of an evar. If the evar is to be used in context - * - * Gamma = a1 ... an xp ... x1 - * \- named part -/ \- de Bruijn part -/ - * - * then the x1...xp are turned into variables so that the evar is declared in - * context - * - * a1 ... an xp ... x1 - * \----------- named part ------------/ - * - * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)" - * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed - * in context Gamma. - * - * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first) - * Remark 2: If some of the ai or xj are definitions, we keep them in the - * instance. This is necessary so that no unfolding of local definitions - * happens when inferring implicit arguments (consider e.g. the problem - * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which - * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want - * the hole to be instantiated by x', not by x (which would have been - * the case in [invert_definition] if x' had disappeared from the instance). - * Note that at any time, if, in some context env, the instance of - * declaration x:A is t and the instance of definition x':=phi(x) is u, then - * we have the property that u and phi(t) are convertible in env. - *) - -let subst2 subst vsubst c = - substl subst (replace_vars vsubst c) - -let push_rel_context_to_named_context env typ = - (* compute the instances relative to the named context and rel_context *) - let open Context.Named.Declaration in - let ids = List.map get_id (named_context env) in - let inst_vars = List.map mkVar ids in - let inst_rels = List.rev (rel_list 0 (nb_rel env)) in - let replace_var_named_declaration id0 id decl = - let id' = get_id decl in - let id' = if Id.equal id0 id' then id else id' in - let vsubst = [id0 , mkVar id] in - decl |> set_id id' |> map_constr (replace_vars vsubst) - in - let replace_var_named_context id0 id env = - let nc = Environ.named_context env in - let nc' = List.map (replace_var_named_declaration id0 id) nc in - Environ.reset_with_named_context (val_of_named_context nc') env - in - let extract_if_neq id = function - | Anonymous -> None - | Name id' when id_ord id id' = 0 -> None - | Name id' -> Some id' - in - (* move the rel context to a named context and extend the named instance *) - (* with vars of the rel context *) - (* We do keep the instances corresponding to local definition (see above) *) - let (subst, vsubst, _, env) = - Context.Rel.fold_outside - (fun decl (subst, vsubst, avoid, env) -> - let open Context.Rel.Declaration in - let na = get_name decl in - let c = get_value decl in - let t = get_type decl in - let open Context.Named.Declaration in - let id = - (* ppedrot: we want to infer nicer names for the refine tactic, but - keeping at the same time backward compatibility in other code - using this function. For now, we only attempt to preserve the - old behaviour of Program, but ultimately, one should do something - about this whole name generation problem. *) - if Flags.is_program_mode () then next_name_away na avoid - else next_ident_away (id_of_name_using_hdchar env t na) avoid - in - match extract_if_neq id na with - | Some id0 when not (is_section_variable id0) -> - (* spiwack: if [id<>id0], rather than introducing a new - binding named [id], we will keep [id0] (the name given - by the user) and rename [id0] into [id] in the named - context. Unless [id] is a section variable. *) - let subst = List.map (replace_vars [id0,mkVar id]) subst in - let vsubst = (id0,mkVar id)::vsubst in - let d = match c with - | None -> LocalAssum (id0, subst2 subst vsubst t) - | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t) - in - let env = replace_var_named_context id0 id env in - (mkVar id0 :: subst, vsubst, id::avoid, push_named d env) - | _ -> - (* spiwack: if [id0] is a section variable renaming it is - incorrect. We revert to a less robust behaviour where - the new binder has name [id]. Which amounts to the same - behaviour than when [id=id0]. *) - let d = match c with - | None -> LocalAssum (id, subst2 subst vsubst t) - | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t) - in - (mkVar id :: subst, vsubst, id::avoid, push_named d env) - ) - (rel_context env) ~init:([], [], ids, env) in - (named_context_val env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst) - -(*------------------------------------* - * Entry points to define new evars * - *------------------------------------*) - -let default_source = (Loc.ghost,Evar_kinds.InternalHole) - -let restrict_evar evd evk filter candidates = - let evd = Sigma.to_evar_map evd in - let evd, evk' = Evd.restrict evk filter ?candidates evd in - Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) - -let new_pure_evar_full evd evi = - let evd = Sigma.to_evar_map evd in - let (evd, evk) = Evd.new_evar evd evi in - let evd = Evd.declare_future_goal evk evd in - Sigma.Unsafe.of_pair (evk, evd) - -let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = - let evd = Sigma.to_evar_map evd in - let default_naming = Misctypes.IntroAnonymous in - let naming = Option.default default_naming naming in - let evi = { - evar_hyps = sign; - evar_concl = typ; - evar_body = Evar_empty; - evar_filter = filter; - evar_source = src; - evar_candidates = candidates; - evar_extra = store; } - in - let (evd, newevk) = Evd.new_evar evd ~naming evi in - let evd = - if principal then Evd.declare_principal_goal newevk evd - else Evd.declare_future_goal newevk evd - in - Sigma.Unsafe.of_pair (newevk, evd) - -let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = - assert (not !Flags.debug || - List.distinct (ids_of_named_context (named_context_of_val sign))); - let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in - Sigma (mkEvar (newevk,Array.of_list instance), evd, p) - -(* [new_evar] declares a new existential in an env env with type typ *) -(* Converting the env into the sign of the evar to define *) -let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in - let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in - let instance = - match filter with - | None -> instance - | Some filter -> Filter.filter_list filter instance in - new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance - -let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in - (Sigma.to_evar_map evd, evk) - -let new_type_evar env evd ?src ?filter ?naming ?principal rigid = - let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in - let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in - Sigma ((e, s), evd', p +> q) - -let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = - let sigma = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in - let sigma = Sigma.to_evar_map sigma in - evdref := sigma; - c - -let new_Type ?(rigid=Evd.univ_flexible) env evd = - let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in - Sigma (mkSort s, sigma, p) - -let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = - let evd', s = new_sort_variable rigid !evdref in - evdref := evd'; mkSort s - - (* The same using side-effect *) -let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty = - let (evd',ev) = new_evar_unsafe env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in - evdref := evd'; - ev - -(* This assumes an evar with identity instance and generalizes it over only - the De Bruijn part of the context *) -let generalize_evar_over_rels sigma (ev,args) = - let evi = Evd.find sigma ev in - let sign = named_context_of_val evi.evar_hyps in - List.fold_left2 - (fun (c,inst as x) a d -> - if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x) - (evi.evar_concl,[]) (Array.to_list args) sign - -(************************************) -(* Removing a dependency in an evar *) -(************************************) - -type clear_dependency_error = -| OccurHypInSimpleClause of Id.t option -| EvarTypingBreak of existential - -exception ClearDependencyError of Id.t * clear_dependency_error - -let cleared = Store.field () - -exception Depends of Id.t - -let rec check_and_clear_in_constr env evdref err ids c = - (* returns a new constr where all the evars have been 'cleaned' - (ie the hypotheses ids have been removed from the contexts of - evars) *) - let check id' = - if Id.Set.mem id' ids then - raise (ClearDependencyError (id',err)) - in - match kind_of_term c with - | Var id' -> - check id'; c - - | ( Const _ | Ind _ | Construct _ ) -> - let vars = Environ.vars_of_global env c in - Id.Set.iter check vars; c - - | Evar (evk,l as ev) -> - if Evd.is_defined !evdref evk then - (* If evk is already defined we replace it by its definition *) - let nc = whd_evar !evdref c in - (check_and_clear_in_constr env evdref err ids nc) - else - (* We check for dependencies to elements of ids in the - evar_info corresponding to e and in the instance of - arguments. Concurrently, we build a new evar - corresponding to e where hypotheses of ids have been - removed *) - let evi = Evd.find_undefined !evdref evk in - let ctxt = Evd.evar_filtered_context evi in - let (rids,filter) = - List.fold_right2 - (fun h a (ri,filter) -> - try - (* Check if some id to clear occurs in the instance - a of rid in ev and remember the dependency *) - let check id = if Id.Set.mem id ids then raise (Depends id) in - let () = Id.Set.iter check (collect_vars a) in - (* Check if some rid to clear in the context of ev - has dependencies in another hyp of the context of ev - and transitively remember the dependency *) - let check id _ = - if occur_var_in_decl (Global.env ()) id h - then raise (Depends id) - in - let () = Id.Map.iter check ri in - (* No dependency at all, we can keep this ev's context hyp *) - (ri, true::filter) - with Depends id -> let open Context.Named.Declaration in - (Id.Map.add (get_id h) id ri, false::filter)) - ctxt (Array.to_list l) (Id.Map.empty,[]) in - (* Check if some rid to clear in the context of ev has dependencies - in the type of ev and adjust the source of the dependency *) - let _nconcl = - try - let nids = Id.Map.domain rids in - check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids (evar_concl evi) - with ClearDependencyError (rid,err) -> - raise (ClearDependencyError (Id.Map.find rid rids,err)) in - - if Id.Map.is_empty rids then c - else - let origfilter = Evd.evar_filter evi in - let filter = Evd.Filter.apply_subfilter origfilter filter in - let evd = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (_, evd, _) = restrict_evar evd evk filter None in - let evd = Sigma.to_evar_map evd in - evdref := evd; - (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) - let evi = Evd.find !evdref evk in - let extra = evi.evar_extra in - let extra' = Store.set extra cleared true in - let evi' = { evi with evar_extra = extra' } in - evdref := Evd.add !evdref evk evi' ; - (* spiwack: /hacking session *) - whd_evar !evdref c - - | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c - -let clear_hyps_in_evi_main env evdref hyps terms ids = - (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some - hypothesis does not depend on a element of ids, and erases ids in - the contexts of the evars occurring in evi *) - let terms = - List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in - let nhyps = - let open Context.Named.Declaration in - let check_context decl = - let err = OccurHypInSimpleClause (Some (get_id decl)) in - map_constr (check_and_clear_in_constr env evdref err ids) decl - in - let check_value vk = match force_lazy_val vk with - | None -> vk - | Some (_, d) -> - if (Id.Set.for_all (fun e -> not (Id.Set.mem e d)) ids) then - (* v does depend on any of ids, it's ok *) - vk - else - (* v depends on one of the cleared hyps: - we forget the computed value *) - dummy_lazy_val () - in - remove_hyps ids check_context check_value hyps - in - (nhyps,terms) - -let clear_hyps_in_evi env evdref hyps concl ids = - match clear_hyps_in_evi_main env evdref hyps [concl] ids with - | (nhyps,[nconcl]) -> (nhyps,nconcl) - | _ -> assert false - -let clear_hyps2_in_evi env evdref hyps t concl ids = - match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with - | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl) - | _ -> assert false - -(* spiwack: a few functions to gather evars on which goals depend. *) -let queue_set q is_dependent set = - Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set -let queue_term q is_dependent c = - queue_set q is_dependent (evars_of_term c) - -let process_dependent_evar q acc evm is_dependent e = - let evi = Evd.find evm e in - (* Queues evars appearing in the types of the goal (conclusion, then - hypotheses), they are all dependent. *) - queue_term q true evi.evar_concl; - List.iter begin fun decl -> - let open Context.Named.Declaration in - queue_term q true (get_type decl); - match decl with - | LocalAssum _ -> () - | LocalDef (_,b,_) -> queue_term q true b - end (Environ.named_context_of_val evi.evar_hyps); - match evi.evar_body with - | Evar_empty -> - if is_dependent then Evar.Map.add e None acc else acc - | Evar_defined b -> - let subevars = evars_of_term b in - (* evars appearing in the definition of an evar [e] are marked - as dependent when [e] is dependent itself: if [e] is a - non-dependent goal, then, unless they are reach from another - path, these evars are just other non-dependent goals. *) - queue_set q is_dependent subevars; - if is_dependent then Evar.Map.add e (Some subevars) acc else acc - -let gather_dependent_evars q evm = - let acc = ref Evar.Map.empty in - while not (Queue.is_empty q) do - let (is_dependent,e) = Queue.pop q in - (* checks if [e] has already been added to [!acc] *) - begin if not (Evar.Map.mem e !acc) then - acc := process_dependent_evar q !acc evm is_dependent e - end - done; - !acc - -let gather_dependent_evars evm l = - let q = Queue.create () in - List.iter (fun a -> Queue.add (false,a) q) l; - gather_dependent_evars q evm - -(* /spiwack *) - -(** The following functions return the set of undefined evars - contained in the object, the defined evars being traversed. - This is roughly a combination of the previous functions and - [nf_evar]. *) - -let undefined_evars_of_term evd t = - let rec evrec acc c = - match kind_of_term c with - | Evar (n, l) -> - let acc = Array.fold_left evrec acc l in - (try match (Evd.find evd n).evar_body with - | Evar_empty -> Evar.Set.add n acc - | Evar_defined c -> evrec acc c - with Not_found -> anomaly ~label:"undefined_evars_of_term" (Pp.str "evar not found")) - | _ -> fold_constr evrec acc c - in - evrec Evar.Set.empty t - -let undefined_evars_of_named_context evd nc = - let open Context.Named.Declaration in - Context.Named.fold_outside - (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) - nc - ~init:Evar.Set.empty - -let undefined_evars_of_evar_info evd evi = - Evar.Set.union (undefined_evars_of_term evd evi.evar_concl) - (Evar.Set.union - (match evi.evar_body with - | Evar_empty -> Evar.Set.empty - | Evar_defined b -> undefined_evars_of_term evd b) - (undefined_evars_of_named_context evd - (named_context_of_val evi.evar_hyps))) - -(* spiwack: this is a more complete version of - {!Termops.occur_evar}. The latter does not look recursively into an - [evar_map]. If unification only need to check superficially, tactics - do not have this luxury, and need the more complete version. *) -let occur_evar_upto sigma n c = - let rec occur_rec c = match kind_of_term c with - | Evar (sp,_) when Evar.equal sp n -> raise Occur - | Evar e -> Option.iter occur_rec (existential_opt_value sigma e) - | _ -> iter_constr occur_rec c - in - try occur_rec c; false with Occur -> true - -(* We don't try to guess in which sort the type should be defined, since - any type has type Type. May cause some trouble, but not so far... *) - -let judge_of_new_Type evd = - let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in - Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) - -let subterm_source evk (loc,k) = - let evk = match k with - | Evar_kinds.SubEvar (evk) -> evk - | _ -> evk in - (loc,Evar_kinds.SubEvar evk) - - -(** Term exploration up to instantiation. *) -let kind_of_term_upto sigma t = - Constr.kind (whd_evar sigma t) - -(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and - [u] up to existential variable instantiation and equalisable - universes. The term [t] is interpreted in [sigma1] while [u] is - interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extention of those in [sigma1]. *) -let eq_constr_univs_test sigma1 sigma2 t u = - (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) - let open Evd in - let fold cstr sigma = - try Some (add_universe_constraints sigma cstr) - with Univ.UniverseInconsistency _ | UniversesDiffer -> None - in - let ans = - Universes.eq_constr_univs_infer_with - (fun t -> kind_of_term_upto sigma1 t) - (fun u -> kind_of_term_upto sigma2 u) - (universes sigma2) fold t u sigma2 - in - match ans with None -> false | Some _ -> true - -type type_constraint = types option -type val_constraint = constr option diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli deleted file mode 100644 index ffff2c5dd9..0000000000 --- a/pretyping/evarutil.mli +++ /dev/null @@ -1,221 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* metavariable -val mk_new_meta : unit -> constr - -(** {6 Creating a fresh evar given their type and context} *) -val new_evar : - env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> - ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> (constr, 'r) Sigma.sigma - -val new_pure_evar : - named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> - ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> (evar, 'r) Sigma.sigma - -val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma - -(** the same with side-effects *) -val e_new_evar : - env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> - ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> constr - -(** Create a new Type existential variable, as we keep track of - them during type-checking and unification. *) -val new_type_evar : - env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> - (constr * sorts, 'r) Sigma.sigma - -val e_new_type_evar : env -> evar_map ref -> - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts - -val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma -val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr - -val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> - constr list option -> (existential_key, 'r) Sigma.sigma - -(** Polymorphic constants *) - -val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma -val e_new_global : evar_map ref -> Globnames.global_reference -> constr - -(** Create a fresh evar in a context different from its definition context: - [new_evar_instance sign evd ty inst] creates a new evar of context - [sign] and type [ty], [inst] is a mapping of the evar context to - the context where the evar should occur. This means that the terms - of [inst] are typed in the occurrence context and their type (seen - as a telescope) is [sign] *) -val new_evar_instance : - named_context_val -> 'r Sigma.t -> types -> - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> - ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> - constr list -> (constr, 'r) Sigma.sigma - -val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list - -val safe_evar_value : evar_map -> existential -> constr option - -(** {6 Evars/Metas switching...} *) - -val non_instantiated : evar_map -> evar_info Evar.Map.t - -(** {6 Unification utils} *) - -(** [head_evar c] returns the head evar of [c] if any *) -exception NoHeadEvar -val head_evar : constr -> existential_key (** may raise NoHeadEvar *) - -(* Expand head evar if any *) -val whd_head_evar : evar_map -> constr -> constr - -(* An over-approximation of [has_undefined (nf_evars evd c)] *) -val has_undefined_evars : evar_map -> constr -> bool - -val is_ground_term : evar_map -> constr -> bool -val is_ground_env : evar_map -> env -> bool - -(** [gather_dependent_evars evm seeds] classifies the evars in [evm] - as dependent_evars and goals (these may overlap). A goal is an - evar in [seeds] or an evar appearing in the (partial) definition - of a goal. A dependent evar is an evar appearing in the type - (hypotheses and conclusion) of a goal, or in the type or (partial) - definition of a dependent evar. The value return is a map - associating to each dependent evar [None] if it has no (partial) - definition or [Some s] if [s] is the list of evars appearing in - its (partial) definition. *) -val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t - -(** The following functions return the set of undefined evars - contained in the object, the defined evars being traversed. - This is roughly a combination of the previous functions and - [nf_evar]. *) - -val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t -val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t -val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t - -(** [occur_evar_upto sigma k c] returns [true] if [k] appears in - [c]. It looks up recursively in [sigma] for the value of existential - variables. *) -val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool - -(** {6 Value/Type constraints} *) - -val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma - -(***********************************************************) - -(** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains - uninstantiated; [nf_evar] leaves uninstantiated evars as is *) - -val whd_evar : evar_map -> constr -> constr -val nf_evar : evar_map -> constr -> constr -val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment -val jl_nf_evar : - evar_map -> unsafe_judgment list -> unsafe_judgment list -val jv_nf_evar : - evar_map -> unsafe_judgment array -> unsafe_judgment array -val tj_nf_evar : - evar_map -> unsafe_type_judgment -> unsafe_type_judgment - -val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t -val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t -val nf_env_evar : evar_map -> env -> env - -val nf_evar_info : evar_map -> evar_info -> evar_info -val nf_evar_map : evar_map -> evar_map -val nf_evar_map_undefined : evar_map -> evar_map - -(** Presenting terms without solved evars *) - -val nf_evars_universes : evar_map -> constr -> constr - -val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr) -val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst - -(** Normalize the evar map w.r.t. universes, after simplification of constraints. - Return the substitution function for constrs as well. *) -val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) - -(** Replacing all evars, possibly raising [Uninstantiated_evar] *) -exception Uninstantiated_evar of existential_key -val flush_and_check_evars : evar_map -> constr -> constr - -(** {6 Term manipulation up to instantiation} *) - -(** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t] - as an evar [e] only if [e] is uninstantiated in [sigma]. Otherwise the - value of [e] in [sigma] is (recursively) used. *) -val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term - -(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and - [u] up to existential variable instantiation and equalisable - universes. The term [t] is interpreted in [sigma1] while [u] is - interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extention of those in [sigma1]. *) -val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool - -(** {6 Removing hyps in evars'context} -raise OccurHypInSimpleClause if the removal breaks dependencies *) - -type clear_dependency_error = -| OccurHypInSimpleClause of Id.t option -| EvarTypingBreak of existential - -exception ClearDependencyError of Id.t * clear_dependency_error - -(* spiwack: marks an evar that has been "defined" by clear. - used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) -val cleared : bool Store.field - -val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types -> - Id.Set.t -> named_context_val * types - -val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types -> - Id.Set.t -> named_context_val * types * types - -val push_rel_context_to_named_context : Environ.env -> types -> - named_context_val * types * constr list * constr list * (identifier*constr) list - -val generalize_evar_over_rels : evar_map -> existential -> types * constr list - -(** Evar combinators *) - -val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a -val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a -val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a - -val subterm_source : existential_key -> Evar_kinds.t Loc.located -> - Evar_kinds.t Loc.located - -val meta_counter_summary_name : string - -(** Deprecater *) - -type type_constraint = types option -type val_constraint = constr option diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index be517d1aa0..c8b3307d76 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,6 +1,5 @@ Locusops Pretype_errors -Evarutil Reductionops Inductiveops Vnorm @@ -21,7 +20,6 @@ Patternops Constr_matching Tacred Typeclasses_errors -Proofview Typeclasses Classops Program diff --git a/pretyping/proofview.ml b/pretyping/proofview.ml deleted file mode 100644 index ba664cafaf..0000000000 --- a/pretyping/proofview.ml +++ /dev/null @@ -1,1211 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* i+1) solution 0 in - let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in - let pruned_solution = Evd.drop_all_defined solution in - let apply_subst_einfo _ ei = - Evd.({ ei with - evar_concl = nf ei.evar_concl; - evar_hyps = Environ.map_named_val nf ei.evar_hyps; - evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in - let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in - let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in - msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); - new_el, { pv with solution = new_solution; } - - -(** {6 Starting and querying a proof view} *) - -type telescope = - | TNil of Evd.evar_map - | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) - -let typeclass_resolvable = Evd.Store.field () - -let dependent_init = - (* Goals are created with a store which marks them as unresolvable - for type classes. *) - let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in - (* Goals don't have a source location. *) - let src = (Loc.ghost,Evar_kinds.GoalEvar) in - (* Main routine *) - let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } - | TCons (env, sigma, typ, t) -> - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in - let sigma = Sigma.to_evar_map sigma in - let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in - let (gl, _) = Term.destEvar econstr in - let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = gl :: comb; shelf = [] } - in - fun t -> - let entry, v = aux t in - (* The created goal are not to be shelved. *) - let solution = Evd.reset_future_goals v.solution in - entry, { v with solution } - -let init = - let rec aux sigma = function - | [] -> TNil sigma - | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l)) - in - fun sigma l -> dependent_init (aux sigma l) - -let initial_goals initial = initial - -let finished = function - | {comb = []} -> true - | _ -> false - -let return { solution=defs } = defs - -let return_constr { solution = defs } c = Evarutil.nf_evar defs c - -let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry) - - -(** {6 Focusing commands} *) - -(** A [focus_context] represents the part of the proof view which has - been removed by a focusing action, it can be used to unfocus later - on. *) -(* First component is a reverse list of the goals which come before - and second component is the list of the goals which go after (in - the expected order). *) -type focus_context = Evar.t list * Evar.t list - - -(** Returns a stylised view of a focus_context for use by, for - instance, ide-s. *) -(* spiwack: the type of [focus_context] will change as we push more - refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) -(* In this version: the goals in the context, as a "zipper" (the first - list is in reversed order). *) -let focus_context f = f - -(** This (internal) function extracts a sublist between two indices, - and returns this sublist together with its context: if it returns - [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the - original list. The focused list has lenght [j-i-1] and contains - the goals from number [i] to number [j] (both included) the first - goal of the list being numbered [1]. [focus_sublist i j l] raises - [IndexOutOfRange] if [i > length l], or [j > length l] or [j < - i]. *) -let focus_sublist i j l = - let (left,sub_right) = CList.goto (i-1) l in - let (sub, right) = - try CList.chop (j-i+1) sub_right - with Failure _ -> raise CList.IndexOutOfRange - in - (sub, (left,right)) - -(** Inverse operation to the previous one. *) -let unfocus_sublist (left,right) s = - CList.rev_append left (s@right) - - -(** [focus i j] focuses a proofview on the goals from index [i] to - index [j] (inclusive, goals are indexed from [1]). I.e. goals - number [i] to [j] become the only focused goals of the returned - proofview. It returns the focused proofview, and a context for - the focus stack. *) -let focus i j sp = - let (new_comb, context) = focus_sublist i j sp.comb in - ( { sp with comb = new_comb } , context ) - - -(** [advance sigma g] returns [Some g'] if [g'] is undefined and is - the current avatar of [g] (for instance [g] was changed by [clear] - into [g']). It returns [None] if [g] has been (partially) - solved. *) -(* spiwack: [advance] is probably performance critical, and the good - behaviour of its definition may depend sensitively to the actual - definition of [Evd.find]. Currently, [Evd.find] starts looking for - a value in the heap of undefined variable, which is small. Hence in - the most common case, where [advance] is applied to an unsolved - goal ([advance] is used to figure if a side effect has modified the - goal) it terminates quickly. *) -let rec advance sigma g = - let open Evd in - let evi = Evd.find sigma g in - match evi.evar_body with - | Evar_empty -> Some g - | Evar_defined v -> - if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then - let (e,_) = Term.destEvar v in - advance sigma e - else - None - -(** [undefined defs l] is the list of goals in [l] which are still - unsolved (after advancing cleared goals). *) -let undefined defs l = CList.map_filter (advance defs) l - -(** Unfocuses a proofview with respect to a context. *) -let unfocus c sp = - { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) } - - -(** {6 The tactic monad} *) - -(** - Tactics are objects which apply a transformation to all the - subgoals of the current view at the same time. By opposition to - the old vision of applying it to a single goal. It allows tactics - such as [shelve_unifiable], tactics to reorder the focused goals, - or global automation tactic for dependent subgoals (instantiating - an evar has influences on the other goals of the proof in - progress, not being able to take that into account causes the - current eauto tactic to fail on some instances where it could - succeed). Another benefit is that it is possible to write tactics - that can be executed even if there are no focused goals. - - Tactics form a monad ['a tactic], in a sense a tactic can be - seen as a function (without argument) which returns a value of - type 'a and modifies the environment (in our case: the view). - Tactics of course have arguments, but these are given at the - meta-level as OCaml functions. Most tactics in the sense we are - used to return [()], that is no really interesting values. But - some might pass information around. The tactics seen in Coq's - Ltac are (for now at least) only [unit tactic], the return values - are kept for the OCaml toolkit. The operation or the monad are - [Proofview.tclUNIT] (which is the "return" of the tactic monad) - [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] - (which is a specialized bind on unit-returning tactics). - - Tactics have support for full-backtracking. Tactics can be seen - having multiple success: if after returning the first success a - failure is encountered, the tactic can backtrack and use a second - success if available. The state is backtracked to its previous - value, except the non-logical state defined in the {!NonLogical} - module below. -*) -(* spiwack: as far as I'm aware this doesn't really relate to - F. Kirchner and C. Muñoz. *) - -module Proof = Logical - -(** type of tactics: - - tactics can - - access the environment, - - report unsafe status, shelved goals and given up goals - - access and change the current [proofview] - - backtrack on previous changes of the proofview *) -type +'a tactic = 'a Proof.t - -(** Applies a tactic to the current proofview. *) -let apply env t sp = - let open Logic_monad in - let ans = Proof.repr (Proof.run t false (sp,env)) in - let ans = Logic_monad.NonLogical.run ans in - match ans with - | Nil (e, info) -> iraise (TacticFailure e, info) - | Cons ((r, (state, _), status, info), _) -> - let (status, gaveup) = status in - let status = (status, state.shelf, gaveup) in - let state = { state with shelf = [] } in - r, state, status, Trace.to_tree info - - - -(** {7 Monadic primitives} *) - -(** Unit of the tactic monad. *) -let tclUNIT = Proof.return - -(** Bind operation of the tactic monad. *) -let tclBIND = Proof.(>>=) - -(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, - it's a specialized "bind". *) -let tclTHEN = Proof.(>>) - -(** [tclIGNORE t] has the same operational content as [t], but drops - the returned value. *) -let tclIGNORE = Proof.ignore - -module Monad = Proof - - - -(** {7 Failure and backtracking} *) - - -(** [tclZERO e] fails with exception [e]. It has no success. *) -let tclZERO ?info e = - let info = match info with - | None -> Exninfo.null - | Some info -> info - in - Proof.zero (e, info) - -(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever - the successes of [t1] have been depleted and it failed with [e], - then it behaves as [t2 e]. In other words, [tclOR] inserts a - backtracking point. *) -let tclOR = Proof.plus - -(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one - success or [t2 e] if [t1] fails with [e]. It is analogous to - [try/with] handler of exception in that it is not a backtracking - point. *) -let tclORELSE t1 t2 = - let open Logic_monad in - let open Proof in - split t1 >>= function - | Nil e -> t2 e - | Cons (a,t1') -> plus (return a) t1' - -(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] - succeeds at least once then it behaves as [tclBIND a s] otherwise, - if [a] fails with [e], then it behaves as [f e]. *) -let tclIFCATCH a s f = - let open Logic_monad in - let open Proof in - split a >>= function - | Nil e -> f e - | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x')) - -(** [tclONCE t] behave like [t] except it has at most one success: - [tclONCE t] stops after the first success of [t]. If [t] fails - with [e], [tclONCE t] also fails with [e]. *) -let tclONCE = Proof.once - -exception MoreThanOneSuccess -let _ = Errors.register_handler begin function - | MoreThanOneSuccess -> Errors.error "This tactic has more than one success." - | _ -> raise Errors.Unhandled -end - -(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one - success. Otherwise it fails. The tactic [t] is run until its first - success, then a failure with exception [e] is simulated. It [t] - yields another success, then [tclEXACTLY_ONCE e t] fails with - [MoreThanOneSuccess] (it is a user error). Otherwise, - [tclEXACTLY_ONCE e t] succeeds with the first success of - [t]. Notice that the choice of [e] is relevant, as the presence of - further successes may depend on [e] (see {!tclOR}). *) -let tclEXACTLY_ONCE e t = - let open Logic_monad in - let open Proof in - split t >>= function - | Nil (e, info) -> tclZERO ~info e - | Cons (x,k) -> - Proof.split (k (e, Exninfo.null)) >>= function - | Nil _ -> tclUNIT x - | _ -> tclZERO MoreThanOneSuccess - - -(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) -type 'a case = -| Fail of iexn -| Next of 'a * (iexn -> 'a tactic) -let tclCASE t = - let open Logic_monad in - let map = function - | Nil e -> Fail e - | Cons (x, t) -> Next (x, t) - in - Proof.map map (Proof.split t) - -let tclBREAK = Proof.break - - - -(** {7 Focusing tactics} *) - -exception NoSuchGoals of int - -(* This hook returns a string to be appended to the usual message. - Primarily used to add a suggestion about the right bullet to use to - focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) -let set_nosuchgoals_hook f = nosuchgoals_hook := f - - - -(* This uses the hook above *) -let _ = Errors.register_handler begin function - | NoSuchGoals n -> - let suffix = !nosuchgoals_hook n in - Errors.errorlabstrm "" - (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) - | _ -> raise Errors.Unhandled -end - -(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where - only the goals numbered [i] to [j] are focused (the rest of the goals - is restored at the end of the tactic). If the range [i]-[j] is not - valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *) -let tclFOCUS_gen nosuchgoal i j t = - let open Proof in - Pv.get >>= fun initial -> - try - let (focused,context) = focus i j initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - with CList.IndexOutOfRange -> nosuchgoal - -let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t -let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t - -(** Like {!tclFOCUS} but selects a single goal by name. *) -let tclFOCUSID id t = - let open Proof in - Pv.get >>= fun initial -> - try - let ev = Evd.evar_key id initial.solution in - try - let n = CList.index Evar.equal ev initial.comb in - (* goal is already under focus *) - let (focused,context) = focus n n initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - with Not_found -> - (* otherwise, save current focus and work purely on the shelve *) - Comb.set [ev] >> - t >>= fun result -> - Comb.set initial.comb >> - return result - with Not_found -> tclZERO (NoSuchGoals 1) - -(** {7 Dispatching on goals} *) - -exception SizeMismatch of int*int -let _ = Errors.register_handler begin function - | SizeMismatch (i,_) -> - let open Pp in - let errmsg = - str"Incorrect number of goals" ++ spc() ++ - str"(expected "++int i++str(String.plural i " tactic") ++ str")." - in - Errors.errorlabstrm "" errmsg - | _ -> raise Errors.Unhandled -end - -(** A variant of [Monad.List.iter] where we iter over the focused list - of goals. The argument tactic is executed in a focus comprising - only of the current goal, a goal which has been solved by side - effect is skipped. The generated subgoals are concatenated in - order. *) -let iter_goal i = - let open Proof in - Comb.get >>= fun initial -> - Proof.List.fold_left begin fun (subgoals as cur) goal -> - Solution.get >>= fun step -> - match advance step goal with - | None -> return cur - | Some goal -> - Comb.set [goal] >> - i goal >> - Proof.map (fun comb -> comb :: subgoals) Comb.get - end [] initial >>= fun subgoals -> - Solution.get >>= fun evd -> - Comb.set CList.(undefined evd (flatten (rev subgoals))) - -(** A variant of [Monad.List.fold_left2] where the first list is the - list of focused goals. The argument tactic is executed in a focus - comprising only of the current goal, a goal which has been solved - by side effect is skipped. The generated subgoals are concatenated - in order. *) -let fold_left2_goal i s l = - let open Proof in - Pv.get >>= fun initial -> - let err = - return () >>= fun () -> (* Delay the computation of list lengths. *) - tclZERO (SizeMismatch (CList.length initial.comb,CList.length l)) - in - Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> - Solution.get >>= fun step -> - match advance step goal with - | None -> return cur - | Some goal -> - Comb.set [goal] >> - i goal a r >>= fun r -> - Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get - end (s,[]) initial.comb l >>= fun (r,subgoals) -> - Solution.get >>= fun evd -> - Comb.set CList.(undefined evd (flatten (rev subgoals))) >> - return r - -(** Dispatch tacticals are used to apply a different tactic to each - goal under focus. They come in two flavours: [tclDISPATCH] takes a - list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] - takes a list of ['a tactic] and returns an ['a list tactic]. - - They both work by applying each of the tactic in a focus - restricted to the corresponding goal (starting with the first - goal). In the case of [tclDISPATCHL], the tactic returns a list of - the same size as the argument list (of tactics), each element - being the result of the tactic executed in the corresponding goal. - - When the length of the tactic list is not the number of goal, - raises [SizeMismatch (g,t)] where [g] is the number of available - goals, and [t] the number of tactics passed. - - [tclDISPATCHGEN join tacs] generalises both functions as the - successive results of [tacs] are stored in reverse order in a - list, and [join] is used to convert the result into the expected - form. *) -let tclDISPATCHGEN0 join tacs = - match tacs with - | [] -> - begin - let open Proof in - Comb.get >>= function - | [] -> tclUNIT (join []) - | comb -> tclZERO (SizeMismatch (CList.length comb,0)) - end - | [tac] -> - begin - let open Proof in - Pv.get >>= function - | { comb=[goal] ; solution } -> - begin match advance solution goal with - | None -> tclUNIT (join []) - | Some _ -> Proof.map (fun res -> join [res]) tac - end - | {comb} -> tclZERO (SizeMismatch(CList.length comb,1)) - end - | _ -> - let iter _ t cur = Proof.map (fun y -> y :: cur) t in - let ans = fold_left2_goal iter [] tacs in - Proof.map join ans - -let tclDISPATCHGEN join tacs = - let branch t = InfoL.tag (Info.DBranch) t in - let tacs = CList.map branch tacs in - InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs) - -let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs - -let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs - - -(** [extend_to_list startxs rx endxs l] builds a list - [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises - [SizeMismatch] if [startxs@endxs] is already longer than [l]. *) -let extend_to_list startxs rx endxs l = - (* spiwack: I use [l] essentially as a natural number *) - let rec duplicate acc = function - | [] -> acc - | _::rest -> duplicate (rx::acc) rest - in - let rec tail to_match rest = - match rest, to_match with - | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) - | _::rest , _::to_match -> tail to_match rest - | _ , [] -> duplicate endxs rest - in - let rec copy pref rest = - match rest,pref with - | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *) - | _::rest, a::pref -> a::(copy pref rest) - | _ , [] -> tail endxs rest - in - copy startxs l - -(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] - tactic is "repeated" enough time such that every goal has a tactic - assigned to it ([b] is the list of tactics applied to the first - goals, [e] to the last goals, and [r] is applied to every goal in - between). *) -let tclEXTEND tacs1 rtac tacs2 = - let open Proof in - Comb.get >>= fun comb -> - try - let tacs = extend_to_list tacs1 rtac tacs2 comb in - tclDISPATCH tacs - with SizeMismatch _ -> - tclZERO (SizeMismatch( - CList.length comb, - (CList.length tacs1)+(CList.length tacs2))) -(* spiwack: failure occurs only when the number of goals is too - small. Hence we can assume that [rtac] is replicated 0 times for - any error message. *) - -(** [tclEXTEND [] tac []]. *) -let tclINDEPENDENT tac = - let open Proof in - Pv.get >>= fun initial -> - match initial.comb with - | [] -> tclUNIT () - | [_] -> tac - | _ -> - let tac = InfoL.tag (Info.DBranch) tac in - InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac)) - - - -(** {7 Goal manipulation} *) - -(** Shelves all the goals under focus. *) -let shelve = - let open Proof in - Comb.get >>= fun initial -> - Comb.set [] >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> - Shelf.modify (fun gls -> gls @ initial) - - -(** [contained_in_info e evi] checks whether the evar [e] appears in - the hypotheses, the conclusion or the body of the evar_info - [evi]. Note: since we want to use it on goals, the body is actually - supposed to be empty. *) -let contained_in_info sigma e evi = - Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) - -(** [depends_on sigma src tgt] checks whether the goal [src] appears - as an existential variable in the definition of the goal [tgt] in - [sigma]. *) -let depends_on sigma src tgt = - let evi = Evd.find sigma tgt in - contained_in_info sigma src evi - -(** [unifiable sigma g l] checks whether [g] appears in another - subgoal of [l]. The list [l] may contain [g], but it does not - affect the result. *) -let unifiable sigma g l = - CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l - -(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] - where [u] is composed of the unifiable goals, i.e. the goals on - whose definition other goals of [l] depend, and [n] are the - non-unifiable goals. *) -let partition_unifiable sigma l = - CList.partition (fun g -> unifiable sigma g l) l - -(** Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -let shelve_unifiable = - let open Proof in - Pv.get >>= fun initial -> - let (u,n) = partition_unifiable initial.solution initial.comb in - Comb.set n >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> - Shelf.modify (fun gls -> gls @ u) - -(** [guard_no_unifiable] returns the list of unifiable goals if some - goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -let guard_no_unifiable = - let open Proof in - Pv.get >>= fun initial -> - let (u,n) = partition_unifiable initial.solution initial.comb in - match u with - | [] -> tclUNIT None - | gls -> - let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in - let l = CList.map (fun id -> Names.Name id) l in - tclUNIT (Some l) - -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) -let unshelve l p = - (* advance the goals in case of clear *) - let l = undefined p.solution l in - { p with comb = p.comb@l } - -let with_shelf tac = - let open Proof in - Pv.get >>= fun pv -> - let { shelf; solution } = pv in - Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> - tac >>= fun ans -> - Pv.get >>= fun npv -> - let { shelf = gls; solution = sigma } = npv in - let gls' = Evd.future_goals sigma in - let fgoals = Evd.future_goals solution in - let pgoal = Evd.principal_future_goal solution in - let sigma = Evd.restore_future_goals sigma fgoals pgoal in - Pv.set { npv with shelf; solution = sigma } >> - tclUNIT (CList.rev_append gls' gls, ans) - -(** [goodmod p m] computes the representative of [p] modulo [m] in the - interval [[0,m-1]].*) -let goodmod p m = - let p' = p mod m in - (* if [n] is negative [n mod l] is negative of absolute value less - than [l], so [(n mod l)+l] is the representative of [n] in the - interval [[0,l-1]].*) - if p' < 0 then p'+m else p' - -let cycle n = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> - Comb.modify begin fun initial -> - let l = CList.length initial in - let n' = goodmod n l in - let (front,rear) = CList.chop n' initial in - rear@front - end - -let swap i j = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> - Comb.modify begin fun initial -> - let l = CList.length initial in - let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in - let i = goodmod i l and j = goodmod j l in - CList.map_i begin fun k x -> - match k with - | k when Int.equal k i -> CList.nth initial j - | k when Int.equal k j -> CList.nth initial i - | _ -> x - end 0 initial - end - -let revgoals = - let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >> - Comb.modify CList.rev - -let numgoals = - let open Proof in - Comb.get >>= fun comb -> - return (CList.length comb) - - - -(** {7 Access primitives} *) - -let tclEVARMAP = Solution.get - -let tclENV = Env.get - - - -(** {7 Put-like primitives} *) - - -let emit_side_effects eff x = - { x with solution = Evd.emit_side_effects eff x.solution } - -let tclEFFECTS eff = - let open Proof in - return () >>= fun () -> (* The Global.env should be taken at exec time *) - Env.set (Global.env ()) >> - Pv.modify (fun initial -> emit_side_effects eff initial) - -let mark_as_unsafe = Status.put false - -(** Gives up on the goal under focus. Reports an unsafe status. Proofs - with given up goals cannot be closed. *) -let give_up = - let open Proof in - Comb.get >>= fun initial -> - Comb.set [] >> - mark_as_unsafe >> - InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >> - Giveup.put initial - - - -(** {7 Control primitives} *) - - -module Progress = struct - - let eq_constr = Evarutil.eq_constr_univs_test - - (** equality function on hypothesis contexts *) - let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = - let open Environ in - let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in - let eq_named_declaration d1 d2 = - match d1, d2 with - | LocalAssum (i1,t1), LocalAssum (i2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 - | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 - && eq_constr sigma1 sigma2 t1 t2 - | _ -> - false - in List.equal eq_named_declaration c1 c2 - - let eq_evar_body sigma1 sigma2 b1 b2 = - let open Evd in - match b1, b2 with - | Evar_empty, Evar_empty -> true - | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2 - | _ -> false - - let eq_evar_info sigma1 sigma2 ei1 ei2 = - let open Evd in - eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl && - eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) && - eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body - - (** Equality function on goals *) - let goal_equal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 gl1 in - let evi2 = Evd.find evars2 gl2 in - eq_evar_info evars1 evars2 evi1 evi2 - -end - -let tclPROGRESS t = - let open Proof in - Pv.get >>= fun initial -> - t >>= fun res -> - Pv.get >>= fun final -> - (* [*_test] test absence of progress. [quick_test] is approximate - whereas [exhaustive_test] is complete. *) - let quick_test = - initial.solution == final.solution && initial.comb == final.comb - in - let exhaustive_test = - Util.List.for_all2eq begin fun i f -> - Progress.goal_equal initial.solution i final.solution f - end initial.comb final.comb - in - let test = - quick_test || exhaustive_test - in - if not test then - tclUNIT res - else - tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) - -exception Timeout -let _ = Errors.register_handler begin function - | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") - | _ -> Pervasives.raise Errors.Unhandled -end - -let tclTIMEOUT n t = - let open Proof in - (* spiwack: as one of the monad is a continuation passing monad, it - doesn't force the computation to be threaded inside the underlying - (IO) monad. Hence I force it myself by asking for the evaluation of - a dummy value first, lest [timeout] be called when everything has - already been computed. *) - let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in - Proof.get >>= fun initial -> - Proof.current >>= fun envvar -> - Proof.lift begin - Logic_monad.NonLogical.catch - begin - let open Logic_monad.NonLogical in - timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r -> - match r with - | Logic_monad.Nil e -> return (Util.Inr e) - | Logic_monad.Cons (r, _) -> return (Util.Inl r) - end - begin let open Logic_monad.NonLogical in function (e, info) -> - match e with - | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) - | Logic_monad.TacticFailure e -> - return (Util.Inr (e, info)) - | e -> Logic_monad.NonLogical.raise ~info e - end - end >>= function - | Util.Inl (res,s,m,i) -> - Proof.set s >> - Proof.put m >> - Proof.update (fun _ -> i) >> - return res - | Util.Inr (e, info) -> tclZERO ~info e - -let tclTIME s t = - let pr_time t1 t2 n msg = - let msg = - if n = 0 then - str msg - else - str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking") - in - msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ - System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in - let rec aux n t = - let open Proof in - tclUNIT () >>= fun () -> - let tstart = System.get_time() in - Proof.split t >>= let open Logic_monad in function - | Nil (e, info) -> - begin - let tend = System.get_time() in - pr_time tstart tend n "failure"; - tclZERO ~info e - end - | Cons (x,k) -> - let tend = System.get_time() in - pr_time tstart tend n "success"; - tclOR (tclUNIT x) (fun e -> aux (n+1) (k e)) - in aux 0 t - - - -(** {7 Unsafe primitives} *) - -module Unsafe = struct - - let tclEVARS evd = - Pv.modify (fun ps -> { ps with solution = evd }) - - let tclNEWGOALS gls = - Pv.modify begin fun step -> - let gls = undefined step.solution gls in - { step with comb = step.comb @ gls } - end - - let tclGETGOALS = Comb.get - - let tclSETGOALS = Comb.set - - let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) - - let tclEVARUNIVCONTEXT ctx = - Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) - - let reset_future_goals p = - { p with solution = Evd.reset_future_goals p.solution } - - let mark_as_goal evd content = - let info = Evd.find evd content in - let info = - { info with Evd.evar_source = match info.Evd.evar_source with - | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x - | loc,_ -> loc,Evar_kinds.GoalEvar } - in - let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with - | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } - | Some () -> info - in - Evd.add evd content info - - let advance = advance - - let typeclass_resolvable = typeclass_resolvable - -end - -module UnsafeRepr = Proof.Unsafe - -let (>>=) = tclBIND -let (<*>) = tclTHEN -let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - -(** {6 Goal-dependent tactics} *) - -let goal_env evars gl = - let evi = Evd.find evars gl in - Evd.evar_filtered_env evi - -let goal_nf_evar sigma gl = - let evi = Evd.find sigma gl in - let evi = Evarutil.nf_evar_info sigma evi in - let sigma = Evd.add sigma gl evi in - (gl, sigma) - -let goal_extra evars gl = - let evi = Evd.find evars gl in - evi.Evd.evar_extra - - -let catchable_exception = function - | Logic_monad.Exception _ -> false - | e -> Errors.noncritical e - - -module Goal = struct - - type ('a, 'r) t = { - env : Environ.env; - sigma : Evd.evar_map; - concl : Term.constr ; - self : Evar.t ; (* for compatibility with old-style definitions *) - } - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } - - let assume (gl : ('a, 'r) t) = (gl :> ([ `NF ], 'r) t) - - let env { env=env } = env - let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma - let hyps { env=env } = Environ.named_context env - let concl { concl=concl } = concl - let extra { sigma=sigma; self=self } = goal_extra sigma self - - let raw_concl { concl=concl } = concl - - - let gmake_with info env sigma goal = - { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ; - sigma = sigma ; - concl = Evd.evar_concl info ; - self = goal } - - let nf_gmake env sigma goal = - let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in - let sigma = Evd.add sigma goal info in - gmake_with info env sigma goal , sigma - - let nf_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let (gl, sigma) = nf_gmake env sigma goal in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f.enter gl)) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let normalize { self } = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - let (gl,sigma) = nf_gmake env sigma self in - tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) - - let gmake env sigma goal = - let info = Evd.find sigma goal in - gmake_with info env sigma goal - - let enter f = - let f gl = InfoL.tag (Info.DBranch) (f.enter gl) in - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try f (gmake env sigma goal) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - let s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let gl = gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let nf_s_enter f = - InfoL.tag (Info.Dispatch) begin - iter_goal begin fun goal -> - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - try - let (gl, sigma) = nf_gmake env sigma goal in - let Sigma (tac, sigma, _) = f.s_enter gl in - let sigma = Sigma.to_evar_map sigma in - tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - end - end - - let goals = - Pv.get >>= fun step -> - let sigma = step.solution in - let map goal = - match advance sigma goal with - | None -> None (** ppedrot: Is this check really necessary? *) - | Some goal -> - let gl = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - tclUNIT (gmake env sigma goal) - in - Some gl - in - tclUNIT (CList.map_filter map step.comb) - - (* compatibility *) - let goal { self=self } = self - - let lift (gl : ('a, 'r) t) _ = (gl :> ('a, 's) t) - -end - - - -(** {6 Trace} *) - -module Trace = struct - - let record_info_trace = InfoL.record_trace - - let log m = InfoL.leaf (Info.Msg m) - let name_tactic m t = InfoL.tag (Info.Tactic m) t - - let pr_info ?(lvl=0) info = - assert (lvl >= 0); - Info.(print (collapse lvl info)) - -end - - - -(** {6 Non-logical state} *) - -module NonLogical = Logic_monad.NonLogical - -let tclLIFT = Proof.lift - -let tclCHECKINTERRUPT = - tclLIFT (NonLogical.make Control.check_for_interrupt) - - - - - -(*** Compatibility layer with <= 8.2 tactics ***) -module V82 = struct - type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma - - let tactic tac = - (* spiwack: we ignore the dependencies between goals here, - expectingly preserving the semantics of <= 8.2 tactics *) - (* spiwack: convenience notations, waiting for ocaml 3.12 *) - let open Proof in - Pv.get >>= fun ps -> - try - let tac gl evd = - let glsigma = - tac { Evd.it = gl ; sigma = evd; } in - let sigma = glsigma.Evd.sigma in - let g = glsigma.Evd.it in - ( g, sigma ) - in - (* Old style tactics expect the goals normalized with respect to evars. *) - let (initgoals,initevd) = - Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution - in - let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in - let sgs = CList.flatten goalss in - let sgs = undefined evd sgs in - InfoL.leaf (Info.Tactic (fun () -> Pp.str"")) >> - Pv.set { ps with solution = evd; comb = sgs; } - with e when catchable_exception e -> - let (e, info) = Errors.push e in - tclZERO ~info e - - - (* normalises the evars in the goals, and stores the result in - solution. *) - let nf_evar_goals = - Pv.modify begin fun ps -> - let map g s = goal_nf_evar s g in - let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in - { ps with solution = evd; comb = goals; } - end - - let has_unresolved_evar pv = - Evd.has_undefined pv.solution - - (* Main function in the implementation of Grab Existential Variables.*) - let grab pv = - let undef = Evd.undefined_map pv.solution in - let goals = CList.rev_map fst (Evar.Map.bindings undef) in - { pv with comb = goals } - - - - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - let goals { comb = comb ; solution = solution; } = - { Evd.it = comb ; sigma = solution } - - let top_goals initial { solution=solution; } = - let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in - { Evd.it = goals ; sigma=solution; } - - let top_evars initial = - let evars_of_initial (c,_) = - Evar.Set.elements (Evd.evars_of_term c) - in - CList.flatten (CList.map evars_of_initial initial) - - let of_tactic t gls = - try - let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in - let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in - { Evd.sigma = final.solution ; it = final.comb } - with Logic_monad.TacticFailure e as src -> - let (_, info) = Errors.push src in - iraise (e, info) - - let put_status = Status.put - - let catchable_exception = catchable_exception - - let wrap_exceptions f = - try f () - with e when catchable_exception e -> - let (e, info) = Errors.push e in tclZERO ~info e - -end - -(** {7 Notations} *) - -module Notations = struct - let (>>=) = tclBIND - let (<*>) = tclTHEN - let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } -end diff --git a/pretyping/proofview.mli b/pretyping/proofview.mli deleted file mode 100644 index 7996b7969c..0000000000 --- a/pretyping/proofview.mli +++ /dev/null @@ -1,589 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Goal.goal list * Evd.evar_map - - -(** {6 Starting and querying a proof view} *) - -(** Abstract representation of the initial goals of a proof. *) -type entry - -(** Optimize memory consumption *) -val compact : entry -> proofview -> entry * proofview - -(** Initialises a proofview, the main argument is a list of - environments (including a [named_context] which are used as - hypotheses) pair with conclusion types, creating accordingly many - initial goals. Because a proof does not necessarily starts in an - empty [evar_map] (indeed a proof can be triggered by an incomplete - pretyping), [init] takes an additional argument to represent the - initial [evar_map]. *) -val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview - -(** A [telescope] is a list of environment and conclusion like in - {!init}, except that each element may depend on the previous - goals. The telescope passes the goals in the form of a - [Term.constr] which represents the goal as an [evar]. The - [evar_map] is threaded in state passing style. *) -type telescope = - | TNil of Evd.evar_map - | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) - -(** Like {!init}, but goals are allowed to be dependent on one - another. Dependencies between goals is represented with the type - [telescope] instead of [list]. Note that the first [evar_map] of - the telescope plays the role of the [evar_map] argument in - [init]. *) -val dependent_init : telescope -> entry * proofview - -(** [finished pv] is [true] if and only if [pv] is complete. That is, - if it has an empty list of focused goals. There could still be - unsolved subgoaled, but they would then be out of focus. *) -val finished : proofview -> bool - -(** Returns the current [evar] state. *) -val return : proofview -> Evd.evar_map - -val partial_proof : entry -> proofview -> constr list -val initial_goals : entry -> (constr * types) list - - - -(** {6 Focusing commands} *) - -(** A [focus_context] represents the part of the proof view which has - been removed by a focusing action, it can be used to unfocus later - on. *) -type focus_context - -(** Returns a stylised view of a focus_context for use by, for - instance, ide-s. *) -(* spiwack: the type of [focus_context] will change as we push more - refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) -(* In this version: the goals in the context, as a "zipper" (the first - list is in reversed order). *) -val focus_context : focus_context -> Goal.goal list * Goal.goal list - -(** [focus i j] focuses a proofview on the goals from index [i] to - index [j] (inclusive, goals are indexed from [1]). I.e. goals - number [i] to [j] become the only focused goals of the returned - proofview. It returns the focused proofview, and a context for - the focus stack. *) -val focus : int -> int -> proofview -> proofview * focus_context - -(** Unfocuses a proofview with respect to a context. *) -val unfocus : focus_context -> proofview -> proofview - - -(** {6 The tactic monad} *) - -(** - Tactics are objects which apply a transformation to all the - subgoals of the current view at the same time. By opposition to - the old vision of applying it to a single goal. It allows tactics - such as [shelve_unifiable], tactics to reorder the focused goals, - or global automation tactic for dependent subgoals (instantiating - an evar has influences on the other goals of the proof in - progress, not being able to take that into account causes the - current eauto tactic to fail on some instances where it could - succeed). Another benefit is that it is possible to write tactics - that can be executed even if there are no focused goals. - - Tactics form a monad ['a tactic], in a sense a tactic can be - seen as a function (without argument) which returns a value of - type 'a and modifies the environment (in our case: the view). - Tactics of course have arguments, but these are given at the - meta-level as OCaml functions. Most tactics in the sense we are - used to return [()], that is no really interesting values. But - some might pass information around. The tactics seen in Coq's - Ltac are (for now at least) only [unit tactic], the return values - are kept for the OCaml toolkit. The operation or the monad are - [Proofview.tclUNIT] (which is the "return" of the tactic monad) - [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN] - (which is a specialized bind on unit-returning tactics). - - Tactics have support for full-backtracking. Tactics can be seen - having multiple success: if after returning the first success a - failure is encountered, the tactic can backtrack and use a second - success if available. The state is backtracked to its previous - value, except the non-logical state defined in the {!NonLogical} - module below. -*) - - -(** The abstract type of tactics *) -type +'a tactic - -(** Applies a tactic to the current proofview. Returns a tuple - [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv] - is the updated proofview, [b] a boolean which is [true] if the - tactic has not done any action considered unsafe (such as - admitting a lemma), [sh] is the list of goals which have been - shelved by the tactic, and [gu] the list of goals on which the - tactic has given up. In case of multiple success the first one is - selected. If there is no success, fails with - {!Logic_monad.TacticFailure}*) -val apply : Environ.env -> 'a tactic -> proofview -> 'a - * proofview - * (bool*Goal.goal list*Goal.goal list) - * Proofview_monad.Info.tree - -(** {7 Monadic primitives} *) - -(** Unit of the tactic monad. *) -val tclUNIT : 'a -> 'a tactic - -(** Bind operation of the tactic monad. *) -val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - -(** Interprets the ";" (semicolon) of Ltac. As a monadic operation, - it's a specialized "bind". *) -val tclTHEN : unit tactic -> 'a tactic -> 'a tactic - -(** [tclIGNORE t] has the same operational content as [t], but drops - the returned value. *) -val tclIGNORE : 'a tactic -> unit tactic - -(** Generic monadic combinators for tactics. *) -module Monad : Monad.S with type +'a t = 'a tactic - -(** {7 Failure and backtracking} *) - -(** [tclZERO e] fails with exception [e]. It has no success. *) -val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic - -(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever - the successes of [t1] have been depleted and it failed with [e], - then it behaves as [t2 e]. In other words, [tclOR] inserts a - backtracking point. *) -val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic - -(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one - success or [t2 e] if [t1] fails with [e]. It is analogous to - [try/with] handler of exception in that it is not a backtracking - point. *) -val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic - -(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] - succeeds at least once then it behaves as [tclBIND a s] otherwise, - if [a] fails with [e], then it behaves as [f e]. *) -val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic - -(** [tclONCE t] behave like [t] except it has at most one success: - [tclONCE t] stops after the first success of [t]. If [t] fails - with [e], [tclONCE t] also fails with [e]. *) -val tclONCE : 'a tactic -> 'a tactic - -(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one - success. Otherwise it fails. The tactic [t] is run until its first - success, then a failure with exception [e] is simulated. It [t] - yields another success, then [tclEXACTLY_ONCE e t] fails with - [MoreThanOneSuccess] (it is a user error). Otherwise, - [tclEXACTLY_ONCE e t] succeeds with the first success of - [t]. Notice that the choice of [e] is relevant, as the presence of - further successes may depend on [e] (see {!tclOR}). *) -exception MoreThanOneSuccess -val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic - -(** [tclCASE t] splits [t] into its first success and a - continuation. It is the most general primitive to control - backtracking. *) -type 'a case = - | Fail of iexn - | Next of 'a * (iexn -> 'a tactic) -val tclCASE : 'a tactic -> 'a case tactic - -(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of - stopping after the first success, it succeeds like [t] until a - failure with an exception [e] such that [p e = Some e'] is raised. At - which point it drops the remaining successes, failing with [e']. - [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *) -val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic - - -(** {7 Focusing tactics} *) - -(** [tclFOCUS i j t] applies [t] after focusing on the goals number - [i] to [j] (see {!focus}). The rest of the goals is restored after - the tactic action. If the specified range doesn't correspond to - existing goals, fails with [NoSuchGoals] (a user error). this - exception is caught at toplevel with a default message + a hook - message that can be customized by [set_nosuchgoals_hook] below. - This hook is used to add a suggestion about bullets when - applicable. *) -exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit - -val tclFOCUS : int -> int -> 'a tactic -> 'a tactic - -(** [tclFOCUSID x t] applies [t] on a (single) focused goal like - {!tclFOCUS}. The goal is found by its name rather than its - number.*) -val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic - -(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the - specified range doesn't correspond to existing goals, behaves like - [tclUNIT ()] instead of failing. *) -val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic - - -(** {7 Dispatching on goals} *) - -(** Dispatch tacticals are used to apply a different tactic to each - goal under focus. They come in two flavours: [tclDISPATCH] takes a - list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL] - takes a list of ['a tactic] and returns an ['a list tactic]. - - They both work by applying each of the tactic in a focus - restricted to the corresponding goal (starting with the first - goal). In the case of [tclDISPATCHL], the tactic returns a list of - the same size as the argument list (of tactics), each element - being the result of the tactic executed in the corresponding goal. - - When the length of the tactic list is not the number of goal, - raises [SizeMismatch (g,t)] where [g] is the number of available - goals, and [t] the number of tactics passed. *) -exception SizeMismatch of int*int -val tclDISPATCH : unit tactic list -> unit tactic -val tclDISPATCHL : 'a tactic list -> 'a list tactic - -(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r] - tactic is "repeated" enough time such that every goal has a tactic - assigned to it ([b] is the list of tactics applied to the first - goals, [e] to the last goals, and [r] is applied to every goal in - between). *) -val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic - -(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from - the first one to the last one. Backtracking in one goal is - independent of backtracking in another. It is equivalent to - [tclEXTEND [] tac []]. *) -val tclINDEPENDENT : unit tactic -> unit tactic - - -(** {7 Goal manipulation} *) - -(** Shelves all the goals under focus. The goals are placed on the - shelf for later use (or being solved by side-effects). *) -val shelve : unit tactic - -(** Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -val shelve_unifiable : unit tactic - -(** [guard_no_unifiable] returns the list of unifiable goals if some - goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -val guard_no_unifiable : Names.Name.t list option tactic - -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) -val unshelve : Goal.goal list -> proofview -> proofview - -(** [with_shelf tac] executes [tac] and returns its result together with the set - of goals shelved by [tac]. The current shelf is unchanged. *) -val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic - -(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] - is negative, then it puts the [n] last goals first.*) -val cycle : int -> unit tactic - -(** [swap i j] swaps the position of goals number [i] and [j] - (negative numbers can be used to address goals from the end. Goals - are indexed from [1]. For simplicity index [0] corresponds to goal - [1] as well, rather than raising an error. *) -val swap : int -> int -> unit tactic - -(** [revgoals] reverses the list of focused goals. *) -val revgoals : unit tactic - -(** [numgoals] returns the number of goals under focus. *) -val numgoals : int tactic - - -(** {7 Access primitives} *) - -(** [tclEVARMAP] doesn't affect the proof, it returns the current - [evar_map]. *) -val tclEVARMAP : Evd.evar_map tactic - -(** [tclENV] doesn't affect the proof, it returns the current - environment. It is not the environment of a particular goal, - rather the "global" environment of the proof. The goal-wise - environment is obtained via {!Proofview.Goal.env}. *) -val tclENV : Environ.env tactic - - -(** {7 Put-like primitives} *) - -(** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Safe_typing.private_constants -> unit tactic - -(** [mark_as_unsafe] declares the current tactic is unsafe. *) -val mark_as_unsafe : unit tactic - -(** Gives up on the goal under focus. Reports an unsafe status. Proofs - with given up goals cannot be closed. *) -val give_up : unit tactic - - -(** {7 Control primitives} *) - -(** [tclPROGRESS t] checks the state of the proof after [t]. It it is - identical to the state before, then [tclePROGRESS t] fails, otherwise - it succeeds like [t]. *) -val tclPROGRESS : 'a tactic -> 'a tactic - -(** Checks for interrupts *) -val tclCHECKINTERRUPT : unit tactic - -exception Timeout -(** [tclTIMEOUT n t] can have only one success. - In case of timeout if fails with [tclZERO Timeout]. *) -val tclTIMEOUT : int -> 'a tactic -> 'a tactic - -(** [tclTIME s t] displays time for each atomic call to t, using s as an - identifying annotation if present *) -val tclTIME : string option -> 'a tactic -> 'a tactic - -(** {7 Unsafe primitives} *) - -(** The primitives in the [Unsafe] module should be avoided as much as - possible, since they can make the proof state inconsistent. They are - nevertheless helpful, in particular when interfacing the pretyping and - the proof engine. *) -module Unsafe : sig - - (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If - [sigma] has new unresolved [evar]-s they will not appear as - goal. If goals have been solved in [sigma] they will still - appear as unsolved goals. *) - val tclEVARS : Evd.evar_map -> unit tactic - - (** Like {!tclEVARS} but also checks whether goals have been solved. *) - val tclEVARSADVANCE : Evd.evar_map -> unit tactic - - (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently - being proved, appending them to the list of focused goals. If a - goal is already solved, it is not added. *) - val tclNEWGOALS : Goal.goal list -> unit tactic - - (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a - goal is already solved, it is not set. *) - val tclSETGOALS : Goal.goal list -> unit tactic - - (** [tclGETGOALS] returns the list of goals under focus. *) - val tclGETGOALS : Goal.goal list tactic - - (** Sets the evar universe context. *) - val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic - - (** Clears the future goals store in the proof view. *) - val reset_future_goals : proofview -> proofview - - (** Give an evar the status of a goal (changes its source location - and makes it unresolvable for type classes. *) - val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map - - (** [advance sigma g] returns [Some g'] if [g'] is undefined and is - the current avatar of [g] (for instance [g] was changed by [clear] - into [g']). It returns [None] if [g] has been (partially) - solved. *) - val advance : Evd.evar_map -> Evar.t -> Evar.t option - - val typeclass_resolvable : unit Evd.Store.field - -end - -(** This module gives access to the innards of the monad. Its use is - restricted to very specific cases. *) -module UnsafeRepr : -sig - type state = Proofview_monad.Logical.Unsafe.state - val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t - val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic -end - -(** {6 Goal-dependent tactics} *) - -module Goal : sig - - (** Type of goals. - - The first parameter type is a phantom argument indicating whether the data - contained in the goal has been normalized w.r.t. the current sigma. If it - is the case, it is flagged [ `NF ]. You may still access the un-normalized - data using {!assume} if you known you do not rely on the assumption of - being normalized, at your own risk. - - The second parameter is a stage indicating where the goal belongs. See - module {!Sigma}. - *) - type ('a, 'r) t - - (** Assume that you do not need the goal to be normalized. *) - val assume : ('a, 'r) t -> ([ `NF ], 'r) t - - (** Normalises the argument goal. *) - val normalize : ('a, 'r) t -> ([ `NF ], 'r) t tactic - - (** [concl], [hyps], [env] and [sigma] given a goal [gl] return - respectively the conclusion of [gl], the hypotheses of [gl], the - environment of [gl] (i.e. the global environment and the - hypotheses) and the current evar map. *) - val concl : ([ `NF ], 'r) t -> Term.constr - val hyps : ([ `NF ], 'r) t -> Context.Named.t - val env : ('a, 'r) t -> Environ.env - val sigma : ('a, 'r) t -> 'r Sigma.t - val extra : ('a, 'r) t -> Evd.Store.t - - (** Returns the goal's conclusion even if the goal is not - normalised. *) - val raw_concl : ('a, 'r) t -> Term.constr - - type ('a, 'b) enter = - { enter : 'r. ('a, 'r) t -> 'b } - - (** [nf_enter t] applies the goal-dependent tactic [t] in each goal - independently, in the manner of {!tclINDEPENDENT} except that - the current goal is also given as an argument to [t]. The goal - is normalised with respect to evars. *) - val nf_enter : ([ `NF ], unit tactic) enter -> unit tactic - - (** Like {!nf_enter}, but does not normalize the goal beforehand. *) - val enter : ([ `LZ ], unit tactic) enter -> unit tactic - - type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } - - (** A variant of {!enter} allows to work with a monotonic state. The evarmap - returned by the argument is put back into the current state before firing - the returned tactic. *) - val s_enter : ([ `LZ ], unit tactic) s_enter -> unit tactic - - (** Like {!s_enter}, but normalizes the goal beforehand. *) - val nf_s_enter : ([ `NF ], unit tactic) s_enter -> unit tactic - - (** Recover the list of current goals under focus, without evar-normalization. - FIXME: encapsulate the level in an existential type. *) - val goals : ([ `LZ ], 'r) t tactic list tactic - - (** Compatibility: avoid if possible *) - val goal : ([ `NF ], 'r) t -> Evar.t - - (** Every goal is valid at a later stage. FIXME: take a later evarmap *) - val lift : ('a, 'r) t -> ('r, 's) Sigma.le -> ('a, 's) t - -end - - -(** {6 Trace} *) - -module Trace : sig - - (** [record_info_trace t] behaves like [t] except the [info] trace - is stored. *) - val record_info_trace : 'a tactic -> 'a tactic - - val log : Proofview_monad.lazy_msg -> unit tactic - val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic - - val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds - -end - - -(** {6 Non-logical state} *) - -(** The [NonLogical] module allows the execution of effects (including - I/O) in tactics (non-logical side-effects are not discarded at - failures). *) -module NonLogical : module type of Logic_monad.NonLogical - -(** [tclLIFT c] is a tactic which behaves exactly as [c]. *) -val tclLIFT : 'a NonLogical.t -> 'a tactic - - -(**/**) - -(*** Compatibility layer with <= 8.2 tactics ***) -module V82 : sig - type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma - val tactic : tac -> unit tactic - - (* normalises the evars in the goals, and stores the result in - solution. *) - val nf_evar_goals : unit tactic - - val has_unresolved_evar : proofview -> bool - - (* Main function in the implementation of Grab Existential Variables. - Resets the proofview's goals so that it contains all unresolved evars - (in chronological order of insertion). *) - val grab : proofview -> proofview - - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - val goals : proofview -> Evar.t list Evd.sigma - - val top_goals : entry -> proofview -> Evar.t list Evd.sigma - - (* returns the existential variable used to start the proof *) - val top_evars : entry -> Evd.evar list - - (* Caution: this function loses quite a bit of information. It - should be avoided as much as possible. It should work as - expected for a tactic obtained from {!V82.tactic} though. *) - val of_tactic : 'a tactic -> tac - - (* marks as unsafe if the argument is [false] *) - val put_status : bool -> unit tactic - - (* exception for which it is deemed to be safe to transmute into - tactic failure. *) - val catchable_exception : exn -> bool - - (* transforms every Ocaml (catchable) exception into a failure in - the monad. *) - val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic -end - -(** {7 Notations} *) - -module Notations : sig - - (** {!tclBIND} *) - val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic - (** {!tclTHEN} *) - val (<*>) : unit tactic -> 'a tactic -> 'a tactic - (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *) - val (<+>) : 'a tactic -> 'a tactic -> 'a tactic - - type ('a, 'b) enter = ('a, 'b) Goal.enter = - { enter : 'r. ('a, 'r) Goal.t -> 'b } - type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } -end -- cgit v1.2.3 From 6d87fd89abdf17ddd4864386d66bb06f0d0a151f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 21:20:29 +0100 Subject: Documenting changes. --- dev/doc/changes.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 1f5ba7862f..2f631c6338 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -76,6 +76,11 @@ the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound in the parsing rules, so beware of recursive calls. +- Evarutil was split in two parts. The new Evardefine file exposes functions +define_evar_* mostly used internally in the unification engine. + +- The Refine module was move out of Proofview. + ========================================= = CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = ========================================= -- cgit v1.2.3 From f39543a752d05e5661749bbc3f221d75e525b3b4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 03:10:54 +0100 Subject: Moving Tactic_debug to Hightactic. --- dev/printers.mllib | 1 - tactics/hightactics.mllib | 1 + tactics/tacinterp.ml | 2 +- tactics/tactic_debug.ml | 20 ++++++++++++++++---- tactics/tactic_debug.mli | 4 ++-- tactics/tactics.mllib | 1 - toplevel/cerrors.ml | 28 +++++++++++++--------------- toplevel/cerrors.mli | 1 + 8 files changed, 34 insertions(+), 24 deletions(-) diff --git a/dev/printers.mllib b/dev/printers.mllib index a3ba42ba78..aad56f586b 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -201,7 +201,6 @@ Egramml Egramcoq Tacsubst Tacenv -Tactic_debug Trie Dn Btermdn diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 468b938b6a..76455f4ac3 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,3 +1,4 @@ +Tactic_debug Tacintern Tacentries Tacinterp diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 6bf0e2aa73..5dab244afa 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -365,7 +365,7 @@ let debugging_exception_step ist signal_anomaly e pp = if signal_anomaly then explain_logic_error else explain_logic_error_no_anomaly in debugging_step ist (fun () -> - pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ !explain_exc e) + pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) let error_ltac_variable loc id env v s = user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ diff --git a/tactics/tactic_debug.ml b/tactics/tactic_debug.ml index e991eb86dc..d661f9677c 100644 --- a/tactics/tactic_debug.ml +++ b/tactics/tactic_debug.ml @@ -14,6 +14,7 @@ open Termops open Nameops open Proofview.Notations + let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () let prtac x = @@ -34,9 +35,11 @@ type debug_info = | DebugOff (* An exception handler *) -let explain_logic_error = ref (fun e -> mt()) +let explain_logic_error e = + Errors.print (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) -let explain_logic_error_no_anomaly = ref (fun e -> mt()) +let explain_logic_error_no_anomaly e = + Errors.print_no_report (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) @@ -202,7 +205,7 @@ let debug_prompt lev tac f = (Proofview.tclLIFT begin (skip:=0) >> (skipped:=0) >> if Logic.catchable_exception reraise then - msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ Pervasives.(!) explain_logic_error reraise) + msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) else return () end) (Proofview.tclZERO ~info reraise) @@ -304,7 +307,7 @@ let db_logic_failure debug err = is_debug debug >>= fun db -> if db then begin - msg_tac_debug (Pervasives.(!) explain_logic_error err) >> + msg_tac_debug (explain_logic_error err) >> msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ str "Let us try the next one...") end @@ -398,3 +401,12 @@ let extract_ltac_trace trace eloc = | [] -> Loc.ghost in aux trace in None, best_loc + +let get_ltac_trace (_, info) = + let ltac_trace = Exninfo.get info ltac_trace_info in + let loc = Option.default Loc.ghost (Loc.get_loc info) in + match ltac_trace with + | None -> None + | Some trace -> Some (extract_ltac_trace trace loc) + +let () = Cerrors.register_additional_error_info get_ltac_trace diff --git a/tactics/tactic_debug.mli b/tactics/tactic_debug.mli index 523398e75a..520fb41eff 100644 --- a/tactics/tactic_debug.mli +++ b/tactics/tactic_debug.mli @@ -61,13 +61,13 @@ val db_matching_failure : debug_info -> unit Proofview.NonLogical.t val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t (** An exception handler *) -val explain_logic_error: (exn -> Pp.std_ppcmds) ref +val explain_logic_error: exn -> Pp.std_ppcmds (** For use in the Ltac debugger: some exception that are usually consider anomalies are acceptable because they are caught later in the process that is being debugged. One should not require from users that they report these anomalies. *) -val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref +val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds (** Prints a logic failure message for a rule *) val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index b495a885f8..c290ce228c 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -20,5 +20,4 @@ Tacenv Hints Auto Tactic_matching -Tactic_debug Term_dnet diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 0b8edd91c1..4f3ffbcaee 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -110,6 +110,11 @@ let rec strip_wrapping_exceptions = function strip_wrapping_exceptions e | exc -> exc +let additional_error_info = ref [] + +let register_additional_error_info f = + additional_error_info := f :: !additional_error_info + let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) = let exc = strip_wrapping_exceptions exc in let e = process_vernac_interp_error with_header (exc, info) in @@ -120,19 +125,12 @@ let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, let err = Errors.make_anomaly msg in Util.iraise (err, info) in - let ltac_trace = Exninfo.get info Tactic_debug.ltac_trace_info in - let loc = Option.default Loc.ghost (Loc.get_loc info) in - match ltac_trace with + let e' = + try Some (CList.find_map (fun f -> f e) !additional_error_info) + with _ -> None + in + match e' with | None -> e - | Some trace -> - let (e, info) = e in - match Tactic_debug.extract_ltac_trace trace loc with - | None, loc -> (e, Loc.add_loc info loc) - | Some msg, loc -> - (EvaluatedError (msg, Some e), Loc.add_loc info loc) - -let _ = Tactic_debug.explain_logic_error := - (fun e -> Errors.print (fst (process_vernac_interp_error (e, Exninfo.null)))) - -let _ = Tactic_debug.explain_logic_error_no_anomaly := - (fun e -> Errors.print_no_report (fst (process_vernac_interp_error (e, Exninfo.null)))) + | Some (None, loc) -> (fst e, Loc.add_loc (snd e) loc) + | Some (Some msg, loc) -> + (EvaluatedError (msg, Some (fst e)), Loc.add_loc (snd e) loc) diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index 68c46010b5..a0e3e3c199 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -19,3 +19,4 @@ val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> U val explain_exn_default : exn -> Pp.std_ppcmds +val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit -- cgit v1.2.3 From 6de9f13ba666250ea397c7db1d9d37075a9dc1c2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 03:37:55 +0100 Subject: Moving Tacenv to Hightactics. --- dev/printers.mllib | 1 - tactics/hightactics.mllib | 1 + tactics/tactics.mllib | 1 - 3 files changed, 1 insertion(+), 2 deletions(-) diff --git a/dev/printers.mllib b/dev/printers.mllib index aad56f586b..9f25ba55e7 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -200,7 +200,6 @@ Ppdecl_proof Egramml Egramcoq Tacsubst -Tacenv Trie Dn Btermdn diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 76455f4ac3..2bd748414c 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,3 +1,4 @@ +Tacenv Tactic_debug Tacintern Tacentries diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index c290ce228c..038bb59f09 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -16,7 +16,6 @@ Inv Leminv Tacsubst Taccoerce -Tacenv Hints Auto Tactic_matching -- cgit v1.2.3 From dc7b77f09fe5e59e6e48486d9a8c0bdc6acf83b7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 16:59:15 +0100 Subject: Adding a new Ltac generic argument for forced tactics returing unit. --- interp/constrarg.ml | 2 ++ interp/constrarg.mli | 5 +++++ parsing/pcoq.ml | 1 + printing/pptactic.ml | 5 +++++ tactics/tacintern.ml | 1 + tactics/tacinterp.ml | 4 ++++ tactics/tacsubst.ml | 1 + 7 files changed, 19 insertions(+) diff --git a/interp/constrarg.ml b/interp/constrarg.ml index 81e942d828..46be0b8a1f 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -28,6 +28,8 @@ let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = Genarg.make0 "tactic" +let wit_ltac = Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac" + let wit_ident = Genarg.make0 "ident" diff --git a/interp/constrarg.mli b/interp/constrarg.mli index 1197b85a25..d38b1183c5 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -71,6 +71,11 @@ val wit_red_expr : val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type +(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their + toplevel interpretation. The one of [wit_ltac] forces the tactic and + discards the result. *) +val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type + val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type (** Aliases for compatibility *) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index c7cb62d592..207b43064c 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -881,5 +881,6 @@ let () = (* Grammar.register0 wit_hyp_location_flag; *) Grammar.register0 wit_red_expr (Tactic.red_expr); Grammar.register0 wit_tactic (Tactic.tactic); + Grammar.register0 wit_ltac (Tactic.tactic); Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl); () diff --git a/printing/pptactic.ml b/printing/pptactic.ml index d99a5f0d89..982c18ec61 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1415,6 +1415,11 @@ let () = let printer _ _ prtac = prtac (0, E) in declare_extra_genarg_pprule wit_tactic printer printer printer +let () = + let pr_unit _ _ _ () = str "()" in + let printer _ _ prtac = prtac (0, E) in + declare_extra_genarg_pprule wit_ltac printer printer pr_unit + module Richpp = struct include Make (Ppconstr.Richpp) (struct diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 89dc843cb8..a75805b4f8 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -795,6 +795,7 @@ let () = Genintern.register_intern0 wit_ident intern_ident'; Genintern.register_intern0 wit_var (lift intern_hyp); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg); Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 5dab244afa..8afc73526e 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -2143,6 +2143,10 @@ let () = let interp ist tac = Ftactic.return (Value.of_closure ist tac) in Geninterp.register_interp0 wit_tactic interp +let () = + let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + Geninterp.register_interp0 wit_ltac interp + let () = Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 55941c1ca6..4059877b75 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -299,6 +299,7 @@ let () = Genintern.register_subst0 wit_var (fun _ v -> v); Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); Genintern.register_subst0 wit_tactic subst_tactic; + Genintern.register_subst0 wit_ltac subst_tactic; Genintern.register_subst0 wit_constr subst_glob_constr; Genintern.register_subst0 wit_sort (fun _ v -> v); Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); -- cgit v1.2.3 From bc1d2825b7f7d0fc828b4ed99cee8ce62c646148 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 23:00:46 +0100 Subject: Relying on generic arguments to represent Extern hints. --- tactics/auto.ml | 10 +++++++--- tactics/auto.mli | 5 +---- tactics/hints.ml | 7 ++++--- tactics/hints.mli | 2 +- tactics/tacinterp.ml | 6 ------ 5 files changed, 13 insertions(+), 17 deletions(-) diff --git a/tactics/auto.ml b/tactics/auto.ml index 761c41da6f..fc6ff03b4b 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -140,8 +140,6 @@ si après Intros la conclusion matche le pattern. (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) -let (forward_interp_tactic, extern_interp) = Hook.make () - let conclPattern concl pat tac = let constr_bindings env sigma = match pat with @@ -156,7 +154,13 @@ let conclPattern concl pat tac = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in constr_bindings env sigma >>= fun constr_bindings -> - Hook.get forward_interp_tactic constr_bindings tac + let open Genarg in + let open Geninterp in + let inj c = Val.Dyn (val_tag (topwit Constrarg.wit_constr), c) in + let fold id c accu = Id.Map.add id (inj c) accu in + let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in + let ist = { lfun; extra = TacStore.empty } in + Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) end } (***********************************************************) diff --git a/tactics/auto.mli b/tactics/auto.mli index cd2de99be5..8c4f359041 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -13,9 +13,6 @@ open Pattern open Decl_kinds open Hints -val extern_interp : - (patvar_map -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic) Hook.t - (** Auto and related automation tactics *) val priority : ('a * full_hint) list -> ('a * full_hint) list @@ -35,7 +32,7 @@ val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clause [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) -val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic +val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic (** The Auto tactic *) diff --git a/tactics/hints.ml b/tactics/hints.ml index e5abad6863..b2104ba433 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -76,7 +76,7 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of glob_tactic_expr (* Hint Extern *) + | Extern of Genarg.glob_generic_argument (* Hint Extern *) type hints_path_atom = | PathHints of global_reference list @@ -749,6 +749,7 @@ let make_unfold eref = code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = + let tacast = Genarg.in_gen (Genarg.glbwit Constrarg.wit_ltac) tacast in let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; @@ -900,7 +901,7 @@ let subst_autohint (subst, obj) = let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code.obj else Unfold_nth ref' | Extern tac -> - let tac' = Tacsubst.subst_tactic subst tac in + let tac' = Genintern.generic_substitute subst tac in if tac==tac' then data.code.obj else Extern tac' in let name' = subst_path_atom subst data.name in @@ -1219,7 +1220,7 @@ let pr_hint h = match h.obj with env with e when Errors.noncritical e -> Global.env () in - (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac) + (str "(*external*) " ++ Pptactic.pr_glb_generic env tac) let pr_id_hint (id, v) = (pr_hint v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) diff --git a/tactics/hints.mli b/tactics/hints.mli index 3e08060f81..df9d792121 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -33,7 +33,7 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) + | Extern of Genarg.glob_generic_argument (* Hint Extern *) type hint type raw_hint = constr * types * Univ.universe_context_set diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 8afc73526e..4506f81596 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -2179,12 +2179,6 @@ let _ = in Hook.set Pretyping.genarg_interp_hook eval -let _ = Hook.set Auto.extern_interp - (fun l -> - let lfun = Id.Map.map (fun c -> Value.of_constr c) l in - let ist = { (default_ist ()) with lfun; } in - interp_tactic ist) - (** Used in tactic extension **) let dummy_id = Id.of_string "_" -- cgit v1.2.3 From 87e27056beee0f7b63326d0a1cb3f68249539bee Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 23:24:10 +0100 Subject: Moving Tacsubst to hightactics. --- tactics/hightactics.mllib | 1 + tactics/tactics.mllib | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index 2bd748414c..7987d774d1 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,3 +1,4 @@ +Tacsubst Tacenv Tactic_debug Tacintern diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 038bb59f09..cb327e52c1 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -14,7 +14,6 @@ Equality Contradiction Inv Leminv -Tacsubst Taccoerce Hints Auto -- cgit v1.2.3 From a581331f26d96d1a037128ae83bebd5e6c27f665 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Mar 2016 00:26:02 +0100 Subject: Creating a dedicated ltac/ folder for Hightactics. --- Makefile.build | 6 +- Makefile.common | 8 +- dev/base_include | 1 + dev/doc/coq-src-description.txt | 7 - dev/ocamldebug-coq.run | 2 +- ltac/autorewrite.ml | 315 ++++++ ltac/autorewrite.mli | 61 ++ ltac/class_tactics.ml | 903 ++++++++++++++++ ltac/class_tactics.mli | 32 + ltac/coretactics.ml4 | 299 ++++++ ltac/eauto.ml | 526 ++++++++++ ltac/eauto.mli | 33 + ltac/eqdecide.ml | 225 ++++ ltac/eqdecide.mli | 17 + ltac/evar_tactics.ml | 91 ++ ltac/evar_tactics.mli | 19 + ltac/extraargs.ml4 | 345 ++++++ ltac/extraargs.mli | 66 ++ ltac/extratactics.ml4 | 1048 ++++++++++++++++++ ltac/extratactics.mli | 14 + ltac/g_auto.ml4 | 211 ++++ ltac/g_class.ml4 | 89 ++ ltac/g_eqdecide.ml4 | 27 + ltac/g_ltac.ml4 | 430 ++++++++ ltac/g_obligations.ml4 | 147 +++ ltac/g_rewrite.ml4 | 272 +++++ ltac/ltac.mllib | 23 + ltac/rewrite.ml | 2184 ++++++++++++++++++++++++++++++++++++++ ltac/rewrite.mli | 114 ++ ltac/tacentries.ml | 263 +++++ ltac/tacentries.mli | 21 + ltac/tacenv.ml | 145 +++ ltac/tacenv.mli | 74 ++ ltac/tacintern.ml | 821 +++++++++++++++ ltac/tacintern.mli | 64 ++ ltac/tacinterp.ml | 2216 +++++++++++++++++++++++++++++++++++++++ ltac/tacinterp.mli | 124 +++ ltac/tacsubst.ml | 313 ++++++ ltac/tacsubst.mli | 30 + ltac/tactic_debug.ml | 412 ++++++++ ltac/tactic_debug.mli | 80 ++ ltac/tactic_option.ml | 51 + ltac/tactic_option.mli | 15 + ltac/tauto.ml | 282 +++++ ltac/tauto.mli | 0 myocamlbuild.ml | 2 +- tactics/autorewrite.ml | 315 ------ tactics/autorewrite.mli | 61 -- tactics/class_tactics.ml | 903 ---------------- tactics/class_tactics.mli | 32 - tactics/coretactics.ml4 | 299 ------ tactics/eauto.ml | 526 ---------- tactics/eauto.mli | 33 - tactics/eqdecide.ml | 225 ---- tactics/eqdecide.mli | 17 - tactics/evar_tactics.ml | 91 -- tactics/evar_tactics.mli | 19 - tactics/extraargs.ml4 | 345 ------ tactics/extraargs.mli | 66 -- tactics/extratactics.ml4 | 1048 ------------------ tactics/extratactics.mli | 14 - tactics/g_auto.ml4 | 211 ---- tactics/g_class.ml4 | 89 -- tactics/g_eqdecide.ml4 | 27 - tactics/g_ltac.ml4 | 430 -------- tactics/g_obligations.ml4 | 147 --- tactics/g_rewrite.ml4 | 272 ----- tactics/hightactics.mllib | 23 - tactics/rewrite.ml | 2184 -------------------------------------- tactics/rewrite.mli | 114 -- tactics/tacentries.ml | 263 ----- tactics/tacentries.mli | 21 - tactics/tacenv.ml | 145 --- tactics/tacenv.mli | 74 -- tactics/tacintern.ml | 821 --------------- tactics/tacintern.mli | 64 -- tactics/tacinterp.ml | 2216 --------------------------------------- tactics/tacinterp.mli | 124 --- tactics/tacsubst.ml | 313 ------ tactics/tacsubst.mli | 30 - tactics/tactic_debug.ml | 412 -------- tactics/tactic_debug.mli | 80 -- tactics/tactic_option.ml | 51 - tactics/tactic_option.mli | 15 - tactics/tauto.ml | 282 ----- tactics/tauto.mli | 0 tools/coq_makefile.ml | 4 +- 87 files changed, 12414 insertions(+), 12420 deletions(-) create mode 100644 ltac/autorewrite.ml create mode 100644 ltac/autorewrite.mli create mode 100644 ltac/class_tactics.ml create mode 100644 ltac/class_tactics.mli create mode 100644 ltac/coretactics.ml4 create mode 100644 ltac/eauto.ml create mode 100644 ltac/eauto.mli create mode 100644 ltac/eqdecide.ml create mode 100644 ltac/eqdecide.mli create mode 100644 ltac/evar_tactics.ml create mode 100644 ltac/evar_tactics.mli create mode 100644 ltac/extraargs.ml4 create mode 100644 ltac/extraargs.mli create mode 100644 ltac/extratactics.ml4 create mode 100644 ltac/extratactics.mli create mode 100644 ltac/g_auto.ml4 create mode 100644 ltac/g_class.ml4 create mode 100644 ltac/g_eqdecide.ml4 create mode 100644 ltac/g_ltac.ml4 create mode 100644 ltac/g_obligations.ml4 create mode 100644 ltac/g_rewrite.ml4 create mode 100644 ltac/ltac.mllib create mode 100644 ltac/rewrite.ml create mode 100644 ltac/rewrite.mli create mode 100644 ltac/tacentries.ml create mode 100644 ltac/tacentries.mli create mode 100644 ltac/tacenv.ml create mode 100644 ltac/tacenv.mli create mode 100644 ltac/tacintern.ml create mode 100644 ltac/tacintern.mli create mode 100644 ltac/tacinterp.ml create mode 100644 ltac/tacinterp.mli create mode 100644 ltac/tacsubst.ml create mode 100644 ltac/tacsubst.mli create mode 100644 ltac/tactic_debug.ml create mode 100644 ltac/tactic_debug.mli create mode 100644 ltac/tactic_option.ml create mode 100644 ltac/tactic_option.mli create mode 100644 ltac/tauto.ml create mode 100644 ltac/tauto.mli delete mode 100644 tactics/autorewrite.ml delete mode 100644 tactics/autorewrite.mli delete mode 100644 tactics/class_tactics.ml delete mode 100644 tactics/class_tactics.mli delete mode 100644 tactics/coretactics.ml4 delete mode 100644 tactics/eauto.ml delete mode 100644 tactics/eauto.mli delete mode 100644 tactics/eqdecide.ml delete mode 100644 tactics/eqdecide.mli delete mode 100644 tactics/evar_tactics.ml delete mode 100644 tactics/evar_tactics.mli delete mode 100644 tactics/extraargs.ml4 delete mode 100644 tactics/extraargs.mli delete mode 100644 tactics/extratactics.ml4 delete mode 100644 tactics/extratactics.mli delete mode 100644 tactics/g_auto.ml4 delete mode 100644 tactics/g_class.ml4 delete mode 100644 tactics/g_eqdecide.ml4 delete mode 100644 tactics/g_ltac.ml4 delete mode 100644 tactics/g_obligations.ml4 delete mode 100644 tactics/g_rewrite.ml4 delete mode 100644 tactics/hightactics.mllib delete mode 100644 tactics/rewrite.ml delete mode 100644 tactics/rewrite.mli delete mode 100644 tactics/tacentries.ml delete mode 100644 tactics/tacentries.mli delete mode 100644 tactics/tacenv.ml delete mode 100644 tactics/tacenv.mli delete mode 100644 tactics/tacintern.ml delete mode 100644 tactics/tacintern.mli delete mode 100644 tactics/tacinterp.ml delete mode 100644 tactics/tacinterp.mli delete mode 100644 tactics/tacsubst.ml delete mode 100644 tactics/tacsubst.mli delete mode 100644 tactics/tactic_debug.ml delete mode 100644 tactics/tactic_debug.mli delete mode 100644 tactics/tactic_option.ml delete mode 100644 tactics/tactic_option.mli delete mode 100644 tactics/tauto.ml delete mode 100644 tactics/tauto.mli diff --git a/Makefile.build b/Makefile.build index f4319243c5..190a62d000 100644 --- a/Makefile.build +++ b/Makefile.build @@ -503,7 +503,7 @@ test-suite: world $(ALLSTDLIB).v ################################################################## .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine highparsing stm toplevel hightactics +.PHONY: engine highparsing stm toplevel ltac lib: lib/clib.cma lib/lib.cma kernel: kernel/kernel.cma @@ -518,7 +518,7 @@ pretyping: pretyping/pretyping.cma highparsing: parsing/highparsing.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma -hightactics: tactics/hightactics.cma +ltac: ltac/ltac.cma ########################################################################### # 2) theories and plugins files @@ -869,7 +869,7 @@ parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d grammar/grammar.dot : | grammar/grammar.mllib.d $(OCAMLDOC_MLLIBD) -tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d +tactics/tactics.dot: | tactics/tactics.mllib.d ltac/ltac.mllib.d $(OCAMLDOC_MLLIBD) %.dot: %.mli diff --git a/Makefile.common b/Makefile.common index 6cf332686d..3e2bfcb3aa 100644 --- a/Makefile.common +++ b/Makefile.common @@ -63,7 +63,7 @@ CSDPCERT:=plugins/micromega/csdpcert$(EXE) CORESRCDIRS:=\ config lib kernel kernel/byterun library \ proofs tactics pretyping interp stm \ - toplevel parsing printing grammar intf engine + toplevel parsing printing grammar intf engine ltac PLUGINS:=\ omega romega micromega quote \ @@ -161,14 +161,14 @@ BYTERUN:=$(addprefix kernel/byterun/, \ coq_fix_code.o coq_memory.o coq_values.o coq_interp.o ) # LINK ORDER: -# Beware that highparsing.cma should appear before hightactics.cma +# Beware that highparsing.cma should appear before ltac.cma # respecting this order is useful for developers that want to load or link # the libraries directly CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma \ - stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma tactics/hightactics.cma + stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma ltac/ltac.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma @@ -379,7 +379,7 @@ OCAMLDOCDIR=dev/ocamldoc DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \ ./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \ ./parsing/*.mli ./proofs/*.mli \ - ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli) + ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli ./ltac/*.mli) # Defining options to generate dependencies graphs DOT=dot diff --git a/dev/base_include b/dev/base_include index 767e023ea2..86f34b2ac9 100644 --- a/dev/base_include +++ b/dev/base_include @@ -17,6 +17,7 @@ #directory "grammar";; #directory "intf";; #directory "stm";; +#directory "ltac";; #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *) #directory "+camlp5";; (* Gramext is found in top_printers.ml *) diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index fe896d3160..00e7f5c53c 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -19,13 +19,6 @@ highparsing : Files in parsing/ that cannot be linked too early. Contains the grammar rules g_*.ml4 -hightactics : - - Files in tactics/ that cannot be linked too early. - These are the .ml4 files that uses the EXTEND possibilities - provided by grammar.cma, for instance eauto.ml4. - - Special components ------------------ diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index b00d084edb..f9310e076a 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -20,7 +20,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/library -I $COQTOP/engine \ -I $COQTOP/pretyping -I $COQTOP/parsing \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ - -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \ + -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \ -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \ diff --git a/ltac/autorewrite.ml b/ltac/autorewrite.ml new file mode 100644 index 0000000000..ea598b61ca --- /dev/null +++ b/ltac/autorewrite.ml @@ -0,0 +1,315 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + errorlabstrm "AutoRewrite" + (str "Rewriting base " ++ str bas ++ str " does not exist.") + +let find_rewrites bas = + List.rev_map snd (HintDN.find_all (find_base bas)) + +let find_matches bas pat = + let base = find_base bas in + let res = HintDN.search_pattern base pat in + List.map snd res + +let print_rewrite_hintdb bas = + (str "Database " ++ str bas ++ fnl () ++ + prlist_with_sep fnl + (fun h -> + str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ + Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ + Option.cata (fun tac -> str " then use tactic " ++ + Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) + (find_rewrites bas)) + +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option + +(* Applies all the rules of one base *) +let one_base general_rewrite_maybe_in tac_main bas = + let lrul = find_rewrites bas in + let try_rewrite dir ctx c tc = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c in + let sigma = Sigma.to_evar_map sigma in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + let tac = general_rewrite_maybe_in dir c' tc in + Sigma.Unsafe.of_pair (tac, sigma) + end } in + let lrul = List.map (fun h -> + let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in + (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> + Tacticals.New.tclTHEN tac + (Tacticals.New.tclREPEAT_MAIN + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) + (Proofview.tclUNIT()) lrul)) + +(* The AutoRewrite tactic *) +let autorewrite ?(conds=Naive) tac_main lbas = + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS + (List.fold_left (fun tac bas -> + Tacticals.New.tclTHEN tac + (one_base (fun dir c tac -> + let tac = (tac, conds) in + general_rewrite dir AllOccurrences true false ~tac c) + tac_main bas)) + (Proofview.tclUNIT()) lbas)) + +let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = + Proofview.Goal.nf_enter { enter = begin fun gl -> + (* let's check at once if id exists (to raise the appropriate error) *) + let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in + let general_rewrite_in id = + let id = ref id in + let to_be_cleared = ref false in + fun dir cstr tac gl -> + let last_hyp_id = + match Tacmach.pf_hyps gl with + d :: _ -> Context.Named.Declaration.get_id d + | _ -> (* even the hypothesis id is missing *) + raise (Logic.RefinerError (Logic.NoSuchHyp !id)) + in + let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false) gl in + let gls = gl'.Evd.it in + match gls with + g::_ -> + (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with + d ::_ -> + let lastid = Context.Named.Declaration.get_id d in + if not (Id.equal last_hyp_id lastid) then + begin + let gl'' = + if !to_be_cleared then + tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl + else gl' in + id := lastid ; + to_be_cleared := true ; + gl'' + end + else + begin + to_be_cleared := false ; + gl' + end + | _ -> assert false) (* there must be at least an hypothesis *) + | _ -> assert false (* rewriting cannot complete a proof *) + in + let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in + Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS + (List.fold_left (fun tac bas -> + Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) + idl + end } + +let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] + +let gen_auto_multi_rewrite conds tac_main lbas cl = + let try_do_hyps treat_id l = + autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas + in + if cl.concl_occs != AllOccurrences && + cl.concl_occs != NoOccurrences + then + Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") + else + let compose_tac t1 t2 = + match cl.onhyps with + | Some [] -> t1 + | _ -> Tacticals.New.tclTHENFIRST t1 t2 + in + compose_tac + (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) + (match cl.onhyps with + | Some l -> try_do_hyps (fun ((_,id),_) -> id) l + | None -> + (* try to rewrite in all hypothesis + (except maybe the rewritten one) *) + Proofview.Goal.nf_enter { enter = begin fun gl -> + let ids = Tacmach.New.pf_ids_of_hyps gl in + try_do_hyps (fun id -> id) ids + end }) + +let auto_multi_rewrite ?(conds=Naive) lems cl = + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) + +let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = + let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in + match onconcl,cl.Locus.onhyps with + | false,Some [_] | true,Some [] | false,Some [] -> + (* autorewrite with .... in clause using tac n'est sur que + si clause represente soit le but soit UNE hypothese + *) + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) + | _ -> + Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") + +(* Functions necessary to the library object declaration *) +let cache_hintrewrite (_,(rbase,lrl)) = + let base = try raw_find_base rbase with Not_found -> HintDN.empty in + let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 + in + let lrl = HintDN.refresh_metas lrl in + let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in + rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab + + +let subst_hintrewrite (subst,(rbase,list as node)) = + let list' = HintDN.subst subst list in + if list' == list then node else + (rbase,list') + +let classify_hintrewrite x = Libobject.Substitute x + + +(* Declaration of the Hint Rewrite library object *) +let inHintRewrite : string * HintDN.t -> Libobject.obj = + Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with + Libobject.cache_function = cache_hintrewrite; + Libobject.load_function = (fun _ -> cache_hintrewrite); + Libobject.subst_function = subst_hintrewrite; + Libobject.classify_function = classify_hintrewrite } + + +open Clenv + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +let decompose_applied_relation metas env sigma c ctype left2right = + let find_rel ty = + let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in + let eqclause = + if metas then eqclause + else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) + in + let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in + let rec split_last_two = function + | [c1;c2] -> [],(c1, c2) + | x::y::z -> + let l,res = split_last_two (y::z) in x::l, res + | _ -> raise Not_found + in + try + let others,(c1,c2) = split_last_two args in + let ty1, ty2 = + Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 + in +(* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) +(* else *) + Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; + hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); + hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } + with Not_found -> None + in + match find_rel ctype with + | Some c -> Some c + | None -> + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> Some c + | None -> None + +let find_applied_relation metas loc env sigma c left2right = + let ctype = Typing.unsafe_type_of env sigma c in + match decompose_applied_relation metas env sigma c ctype left2right with + | Some c -> c + | None -> + user_err_loc (loc, "decompose_applied_relation", + str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ + spc () ++ str"of this term does not end with an applied relation.") + +(* To add rewriting rules to a base *) +let add_rew_rules base lrul = + let counter = ref 0 in + let env = Global.env () in + let sigma = Evd.from_env env in + let lrul = + List.fold_left + (fun dn (loc,(c,ctx),b,t) -> + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let info = find_applied_relation false loc env sigma c b in + let pat = if b then info.hyp_left else info.hyp_right in + let rul = { rew_lemma = c; rew_type = info.hyp_ty; + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; + rew_tac = Option.map Tacintern.glob_tactic t} + in incr counter; + HintDN.add pat (!counter, rul) dn) HintDN.empty lrul + in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) + diff --git a/ltac/autorewrite.mli b/ltac/autorewrite.mli new file mode 100644 index 0000000000..6196b04e18 --- /dev/null +++ b/ltac/autorewrite.mli @@ -0,0 +1,61 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raw_rew_rule list -> unit + +(** The AutoRewrite tactic. + The optional conditions tell rewrite how to handle matching and side-condition solving. + Default is Naive: first match in the clause, don't look at the side-conditions to + tell if the rewrite succeeded. *) +val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic +val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic + +(** Rewriting rules *) +type rew_rule = { rew_lemma: constr; + rew_type: types; + rew_pat: constr; + rew_ctx: Univ.universe_context_set; + rew_l2r: bool; + rew_tac: glob_tactic_expr option } + +val find_rewrites : string -> rew_rule list + +val find_matches : string -> constr -> rew_rule list + +val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic + +val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic + +val print_rewrite_hintdb : string -> Pp.std_ppcmds + +open Clenv + + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +val find_applied_relation : bool -> + Loc.t -> + Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo + diff --git a/ltac/class_tactics.ml b/ltac/class_tactics.ml new file mode 100644 index 0000000000..4855598989 --- /dev/null +++ b/ltac/class_tactics.ml @@ -0,0 +1,903 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + if Evar.Map.mem ev !tosee then + visit ev (Evar.Map.find ev !tosee)) evs; + tosee := Evar.Map.remove ev !tosee; + l' := ev :: !l'; + in + while not (Evar.Map.is_empty !tosee) do + let ev, evi = Evar.Map.min_binding !tosee in + visit ev evi + done; + List.rev !l' + +let evars_to_goals p evm = + let goals = ref Evar.Map.empty in + let map ev evi = + let evi, goal = p evm ev evi in + let () = if goal then goals := Evar.Map.add ev evi !goals in + evi + in + let evm = Evd.raw_map_undefined map evm in + if Evar.Map.is_empty !goals then None + else Some (!goals, evm) + +(** Typeclasses instance search tactic / eauto *) + +open Auto + +open Unification + +let auto_core_unif_flags st freeze = { + modulo_conv_on_closed_terms = Some st; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = st; + modulo_delta_types = st; + check_applied_meta_types = false; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = freeze; + restrict_conv_on_strict_subterms = false; (* ? *) + modulo_betaiota = true; + modulo_eta = !typeclasses_modulo_eta; +} + +let auto_unif_flags freeze st = + let fl = auto_core_unif_flags st freeze in + { core_unify_flags = fl; + merge_unify_flags = fl; + subterm_unify_flags = fl; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + +let rec eq_constr_mod_evars x y = + match kind_of_term x, kind_of_term y with + | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true + | _, _ -> compare_constr eq_constr_mod_evars x y + +let progress_evars t = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let check = + Proofview.Goal.nf_enter { enter = begin fun gl' -> + let newconcl = Proofview.Goal.concl gl' in + if eq_constr_mod_evars concl newconcl + then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)") + else Proofview.tclUNIT () + end } + in t <*> check + end } + + +let e_give_exact flags poly (c,clenv) gl = + let (c, _, _) = c in + let c, gl = + if poly then + let clenv', subst = Clenv.refresh_undefined_univs clenv in + let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in + let c = Vars.subst_univs_level_constr subst c in + c, {gl with sigma = evd} + else c, gl + in + let t1 = pf_unsafe_type_of gl c in + tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl + +let unify_e_resolve poly flags = { enter = begin fun gls (c,clenv) -> + let clenv', c = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine true ~with_classes:false clenv' + end } + +let unify_resolve poly flags = { enter = begin fun gls (c,clenv) -> + let clenv', _ = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine false ~with_classes:false clenv' + end } + +let clenv_of_prods poly nprods (c, clenv) gl = + let (c, _, _) = c in + if poly || Int.equal nprods 0 then Some clenv + else + let ty = Tacmach.New.pf_unsafe_type_of gl c in + let diff = nb_prod ty - nprods in + if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) + Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) + else None + +let with_prods nprods poly (c, clenv) f = + Proofview.Goal.nf_enter { enter = begin fun gl -> + match clenv_of_prods poly nprods (c, clenv) gl with + | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") + | Some clenv' -> f.enter gl (c, clenv') + end } + +(** Hack to properly solve dependent evars that are typeclasses *) + +let rec e_trivial_fail_db db_list local_db goal = + let tacl = + Proofview.V82.of_tactic Eauto.registered_e_assumption :: + (tclTHEN (Proofview.V82.of_tactic Tactics.intro) + (function g'-> + let d = pf_last_hyp g' in + let hintl = make_resolve_hyp (pf_env g') (project g') d in + (e_trivial_fail_db db_list + (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: + (List.map (fun (x,_,_,_,_) -> x) + (e_trivial_resolve db_list local_db (project goal) (pf_concl goal))) + in + tclFIRST (List.map tclCOMPLETE tacl) goal + +and e_my_find_search db_list local_db hdc complete sigma concl = + let prods, concl = decompose_prod_assum concl in + let nprods = List.length prods in + let freeze = + try + let cl = Typeclasses.class_info (fst hdc) in + if cl.cl_strict then + Evd.evars_of_term concl + else Evar.Set.empty + with e when Errors.noncritical e -> Evar.Set.empty + in + let hintl = + List.map_append + (fun db -> + let tacs = + if Hint_db.use_dn db then (* Using dnet *) + Hint_db.map_eauto hdc concl db + else Hint_db.map_existential hdc concl db + in + let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) tacs) + (local_db::db_list) + in + let tac_of_hint = + fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> + let tac = function + | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) + | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) + | Res_pf_THEN_trivial_fail (term,cl) -> + Proofview.V82.tactic (tclTHEN + (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) + (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) + | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]))) + | Extern tacast -> conclPattern concl p tacast + in + let tac = Proofview.V82.of_tactic (run_hint t tac) in + let tac = if complete then tclCOMPLETE tac else tac in + match repr_hint t with + | Extern _ -> (tac,b,true, name, lazy (pr_hint t)) + | _ -> +(* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) + (tac,b,false, name, lazy (pr_hint t)) + in List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db sigma concl = + try + e_my_find_search db_list local_db + (decompose_app_bound concl) true sigma concl + with Bound | Not_found -> [] + +let e_possible_resolve db_list local_db sigma concl = + try + e_my_find_search db_list local_db + (decompose_app_bound concl) false sigma concl + with Bound | Not_found -> [] + +let catchable = function + | Refiner.FailError _ -> true + | e -> Logic.catchable_exception e + +let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) + +let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) + +type autoinfo = { hints : hint_db; is_evar: existential_key option; + only_classes: bool; unique : bool; + auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; + auto_path : global_reference option list; + auto_cut : hints_path } +type autogoal = goal * autoinfo +type failure = NotApplicable | ReachedLimit +type 'ans fk = failure -> 'ans +type ('a,'ans) sk = 'a -> 'ans fk -> 'ans +type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } + +type auto_result = autogoal list sigma + +type atac = auto_result tac + +(* Some utility types to avoid the need of -rectypes *) + +type 'a optionk = + | Nonek + | Somek of 'a * 'a optionk fk + +type ('a,'b) optionk2 = + | Nonek2 of failure + | Somek2 of 'a * 'b * ('a,'b) optionk2 fk + +let make_resolve_hyp env sigma st flags only_classes pri decl = + let open Context.Named.Declaration in + let id = get_id decl in + let cty = Evarutil.nf_evar sigma (get_type decl) in + let rec iscl env ty = + let ctx, ar = decompose_prod_assum ty in + match kind_of_term (fst (decompose_app ar)) with + | Const (c,_) -> is_class (ConstRef c) + | Ind (i,_) -> is_class (IndRef i) + | _ -> + let env' = Environ.push_rel_context ctx env in + let ty' = whd_betadeltaiota env' ar in + if not (Term.eq_constr ty' ar) then iscl env' ty' + else false + in + let is_class = iscl env cty in + let keep = not only_classes || is_class in + if keep then + let c = mkVar id in + let name = PathHints [VarRef id] in + let hints = + if is_class then + let hints = build_subclasses ~check:false env sigma (VarRef id) None in + (List.map_append + (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) + (true,false,Flags.is_verbose()) pri false + (IsConstr (c,Univ.ContextSet.empty))) + hints) + else [] + in + (hints @ List.map_filter + (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) + with Failure _ | UserError _ -> None) + [make_exact_entry ~name env sigma pri false; + make_apply_entry ~name env sigma flags pri false]) + else [] + +let pf_filtered_hyps gls = + Goal.V82.hyps gls.Evd.sigma (sig_it gls) + +let make_hints g st only_classes sign = + let paths, hintlist = + List.fold_left + (fun (paths, hints) hyp -> + let consider = + let open Context.Named.Declaration in + try let t = Global.lookup_named (get_id hyp) |> get_type in + (* Section variable, reindex only if the type changed *) + not (Term.eq_constr t (get_type hyp)) + with Not_found -> true + in + if consider then + let path, hint = + PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp + in + (PathOr (paths, path), hint @ hints) + else (paths, hints)) + (PathEmpty, []) sign + in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) + +let make_autogoal_hints = + let cache = ref (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) + in + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + let (onlyc, sign', cached_hints) = !cache in + if onlyc == only_classes && + (sign == sign' || Environ.eq_named_context_val sign sign') + && Hint_db.transparent_state cached_hints == st + then + cached_hints + else + let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in + cache := (only_classes, sign, hints); hints + +let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = + { skft = fun sk fk {it = gl,hints; sigma=s;} -> + let res = try Some (tac {it=gl; sigma=s;}) + with e when catchable e -> None in + match res with + | Some gls -> sk (f gls hints) fk + | None -> fk NotApplicable } + +let intro_tac : atac = + lift_tactic (Proofview.V82.of_tactic Tactics.intro) + (fun {it = gls; sigma = s} info -> + let gls' = + List.map (fun g' -> + let env = Goal.V82.env s g' in + let context = Environ.named_context_of_val (Goal.V82.hyps s g') in + let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) + (true,false,false) info.only_classes None (List.hd context) in + let ldb = Hint_db.add_list env s hint info.hints in + (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls + in {it = gls'; sigma = s;}) + +let normevars_tac : atac = + { skft = fun sk fk {it = (gl, info); sigma = s;} -> + let gl', sigma' = Goal.V82.nf_evar s gl in + let info' = { info with auto_last_tac = lazy (str"normevars") } in + sk {it = [gl', info']; sigma = sigma';} fk } + +let merge_failures x y = + match x, y with + | _, ReachedLimit + | ReachedLimit, _ -> ReachedLimit + | NotApplicable, NotApplicable -> NotApplicable + +let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = + { skft = fun sk fk gls -> x.skft sk + (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls } + +let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac = + { skft = fun sk fk gls -> x.skft sk + (fun f -> (y f).skft sk fk gls) gls } + +let is_Prop env sigma concl = + let ty = Retyping.get_type_of env sigma concl in + match kind_of_term ty with + | Sort (Prop Null) -> true + | _ -> false + +let is_unique env concl = + try + let (cl,u), args = dest_class_app env concl in + cl.cl_unique + with e when Errors.noncritical e -> false + +let needs_backtrack env evd oev concl = + if Option.is_empty oev || is_Prop env evd concl then + occur_existential concl + else true + +let hints_tac hints = + { skft = fun sk fk {it = gl,info; sigma = s;} -> + let env = Goal.V82.env s gl in + let concl = Goal.V82.concl s gl in + let tacgl = {it = gl; sigma = s;} in + let poss = e_possible_resolve hints info.hints s concl in + let unique = is_unique env concl in + let rec aux i foundone = function + | (tac, _, b, name, pp) :: tl -> + let derivs = path_derivate info.auto_cut name in + let res = + try + if path_matches derivs [] then None else Some (tac tacgl) + with e when catchable e -> None + in + (match res with + | None -> aux i foundone tl + | Some {it = gls; sigma = s';} -> + if !typeclasses_debug then + msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp + ++ str" on" ++ spc () ++ pr_ev s gl); + let sgls = + evars_to_goals + (fun evm ev evi -> + if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && + (not info.only_classes || Typeclasses.is_class_evar evm evi) + then Typeclasses.mark_unresolvable evi, true + else evi, false) s' + in + let newgls, s' = + let gls' = List.map (fun g -> (None, g)) gls in + match sgls with + | None -> gls', s' + | Some (evgls, s') -> + if not !typeclasses_dependency_order then + (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') + else + (* Reorder with dependent subgoals. *) + let evm = List.fold_left + (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in + let gls = top_sort s' evm in + (List.map (fun ev -> Some ev, ev) gls, s') + in + let gls' = List.map_i + (fun j (evar, g) -> + let info = + { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; + is_evar = evar; + hints = + if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) + (Goal.V82.hyps s' gl)) + then make_autogoal_hints info.only_classes + ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s';} + else info.hints; + auto_cut = derivs } + in g, info) 1 newgls in + let glsv = {it = gls'; sigma = s';} in + let fk' = + (fun e -> + let do_backtrack = + if unique then occur_existential concl + else if info.unique then true + else if List.is_empty gls' then + needs_backtrack env s' info.is_evar concl + else true + in + let e' = match foundone with None -> e | Some e' -> merge_failures e e' in + if !typeclasses_debug then + msg_debug + ((if do_backtrack then str"Backtracking after " + else str "Not backtracking after ") + ++ Lazy.force pp); + if do_backtrack then aux (succ i) (Some e') tl + else fk e') + in + sk glsv fk') + | [] -> + if foundone == None && !typeclasses_debug then + msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ + Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ + spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); + match foundone with + | Some e -> fk e + | None -> fk NotApplicable + in aux 1 None poss } + +let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = + let rec aux s (acc : autogoal list list) fk = function + | (gl,info) :: gls -> + Control.check_for_interrupt (); + (match info.is_evar with + | Some ev when Evd.is_defined s ev -> aux s acc fk gls + | _ -> + second.skft + (fun {it=gls';sigma=s'} fk' -> + let fk'' = + if not info.unique && List.is_empty gls' && + not (needs_backtrack (Goal.V82.env s gl) s + info.is_evar (Goal.V82.concl s gl)) + then fk + else fk' + in + aux s' (gls'::acc) fk'' gls) + fk {it = (gl,info); sigma = s; }) + | [] -> Somek2 (List.rev acc, s, fk) + in fun {it = gls; sigma = s; } fk -> + let rec aux' = function + | Nonek2 e -> fk e + | Somek2 (res, s', fk') -> + let goals' = List.concat res in + sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e)) + in aux' (aux s [] (fun e -> Nonek2 e) gls) + +let then_tac (first : atac) (second : atac) : atac = + { skft = fun sk fk -> first.skft (then_list second sk) fk } + +let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = + t.skft (fun x _ -> Some x) (fun _ -> None) gl + +type run_list_res = auto_result optionk + +let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = + (then_list t (fun x fk -> Somek (x, fk))) + gl + (fun _ -> Nonek) + +let fail_tac reason : atac = + { skft = fun sk fk _ -> fk reason } + +let rec fix (t : 'a tac) : 'a tac = + then_tac t { skft = fun sk fk -> (fix t).skft sk fk } + +let rec fix_limit limit (t : 'a tac) : 'a tac = + if Int.equal limit 0 then fail_tac ReachedLimit + else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } + +let fix_iterative t = + let rec aux depth = + or_else_tac (fix_limit depth t) + (function + | NotApplicable as e -> fail_tac e + | ReachedLimit -> aux (succ depth)) + in aux 1 + +let fix_iterative_limit limit (t : 'a tac) : 'a tac = + let rec aux depth = + if Int.equal depth limit then fail_tac ReachedLimit + else or_tac (fix_limit depth t) { skft = fun sk fk -> (aux (succ depth)).skft sk fk } + in aux 1 + +let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g = + let hints = make_autogoal_hints only_classes ~st g in + (g.it, { hints = hints ; is_evar = ev; unique = unique; + only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); + auto_path = []; auto_cut = cut }) + + +let cut_of_hints h = + List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h + +let make_autogoals ?(only_classes=true) ?(unique=false) + ?(st=full_transparent_state) hints gs evm' = + let cut = cut_of_hints hints in + { it = List.map_i (fun i g -> + let (gl, auto) = make_autogoal ~only_classes ~unique + ~st cut (Some g) {it = g; sigma = evm'; } in + (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; } + +let get_result r = + match r with + | Nonek -> None + | Somek (gls, fk) -> Some (gls.sigma,fk) + +let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) p evm hints tac = + match evars_to_goals p evm with + | None -> None (* This happens only because there's no evar having p *) + | Some (goals, evm') -> + let goals = + if !typeclasses_dependency_order then + top_sort evm' goals + else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) + in + let res = run_list_tac tac p goals + (make_autogoals ~only_classes ~unique ~st hints goals evm') in + match get_result res with + | None -> raise Not_found + | Some (evm', fk) -> + Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) + +let eauto_tac hints = + then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) + +let eauto_tac ?limit hints = + if get_typeclasses_iterative_deepening () then + match limit with + | None -> fix_iterative (eauto_tac hints) + | Some limit -> fix_iterative_limit limit (eauto_tac hints) + else + match limit with + | None -> fix (eauto_tac hints) + | Some limit -> fix_limit limit (eauto_tac hints) + +let real_eauto ?limit unique st hints p evd = + let res = + run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints) + in + match res with + | None -> evd + | Some (evd', fk) -> + if unique then + (match get_result (fk NotApplicable) with + | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" + | None -> evd') + else evd' + +let resolve_all_evars_once debug limit unique p evd = + let db = searchtable_map typeclasses_db in + real_eauto ?limit unique (Hint_db.transparent_state db) [db] p evd + +let eauto ?(only_classes=true) ?st ?limit hints g = + let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in + match run_tac (eauto_tac ?limit hints) gl with + | None -> raise Not_found + | Some {it = goals; sigma = s; } -> + {it = List.map fst goals; sigma = s;} + +(** We compute dependencies via a union-find algorithm. + Beware of the imperative effects on the partition structure, + it should not be shared, but only used locally. *) + +module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) + +let deps_of_constraints cstrs evm p = + List.iter (fun (_, _, x, y) -> + let evx = Evarutil.undefined_evars_of_term evm x in + let evy = Evarutil.undefined_evars_of_term evm y in + Intpart.union_set (Evar.Set.union evx evy) p) + cstrs + +let evar_dependencies evm p = + Evd.fold_undefined + (fun ev evi _ -> + let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + in Intpart.union_set evars p) + evm () + +let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = + let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in + let (gl,t,sigma) = + Goal.V82.mk_goal sigma nc gl Store.empty in + let gls = { it = gl ; sigma = sigma; } in + let hints = searchtable_map typeclasses_db in + let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in + let evd = sig_sig gls' in + let t' = let (ev, inst) = destEvar t in + mkEvar (ev, Array.of_list subst) + in + let term = Evarutil.nf_evar evd t' in + evd, term + +let _ = + Typeclasses.solve_instantiation_problem := + (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) + +(** [split_evars] returns groups of undefined evars according to dependencies *) + +let split_evars evm = + let p = Intpart.create () in + evar_dependencies evm p; + deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; + Intpart.partition p + +let is_inference_forced p evd ev = + try + let evi = Evd.find_undefined evd ev in + if Typeclasses.is_resolvable evi && snd (p ev evi) + then + let (loc, k) = evar_source ev evd in + match k with + | Evar_kinds.ImplicitArg (_, _, b) -> b + | Evar_kinds.QuestionMark _ -> false + | _ -> true + else true + with Not_found -> assert false + +let is_mandatory p comp evd = + Evar.Set.exists (is_inference_forced p evd) comp + +(** In case of unsatisfiable constraints, build a nice error message *) + +let error_unresolvable env comp evd = + let evd = Evarutil.nf_evar_map_undefined evd in + let is_part ev = match comp with + | None -> true + | Some s -> Evar.Set.mem ev s + in + let fold ev evi (found, accu) = + let ev_class = class_of_constr evi.evar_concl in + if not (Option.is_empty ev_class) && is_part ev then + (* focus on one instance if only one was searched for *) + if not found then (true, Some ev) + else (found, None) + else (found, accu) + in + let (_, ev) = Evd.fold_undefined fold evd (true, None) in + Pretype_errors.unsatisfiable_constraints + (Evarutil.nf_env_evar evd env) evd ev comp + +(** Check if an evar is concerned by the current resolution attempt, + (and in particular is in the current component), and also update + its evar_info. + Invariant : this should only be applied to undefined evars, + and return undefined evar_info *) + +let select_and_update_evars p oevd in_comp evd ev evi = + assert (evi.evar_body == Evar_empty); + try + let oevi = Evd.find_undefined oevd ev in + if Typeclasses.is_resolvable oevi then + Typeclasses.mark_unresolvable evi, + (in_comp ev && p evd ev evi) + else evi, false + with Not_found -> + Typeclasses.mark_unresolvable evi, p evd ev evi + +(** Do we still have unresolved evars that should be resolved ? *) + +let has_undefined p oevd evd = + let check ev evi = snd (p oevd ev evi) in + Evar.Map.exists check (Evd.undefined_map evd) + +(** Revert the resolvability status of evars after resolution, + potentially unprotecting some evars that were set unresolvable + just for this call to resolution. *) + +let revert_resolvability oevd evd = + let map ev evi = + try + if not (Typeclasses.is_resolvable evi) then + let evi' = Evd.find_undefined oevd ev in + if Typeclasses.is_resolvable evi' then + Typeclasses.mark_resolvable evi + else evi + else evi + with Not_found -> evi + in + Evd.raw_map_undefined map evd + +(** If [do_split] is [true], we try to separate the problem in + several components and then solve them separately *) + +exception Unresolved + +let resolve_all_evars debug m unique env p oevd do_split fail = + let split = if do_split then split_evars oevd else [Evar.Set.empty] in + let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true + in + let rec docomp evd = function + | [] -> revert_resolvability oevd evd + | comp :: comps -> + let p = select_and_update_evars p oevd (in_comp comp) in + try + let evd' = resolve_all_evars_once debug m unique p evd in + if has_undefined p oevd evd' then raise Unresolved; + docomp evd' comps + with Unresolved | Not_found -> + if fail && (not do_split || is_mandatory (p evd) comp evd) + then (* Unable to satisfy the constraints. *) + let comp = if do_split then Some comp else None in + error_unresolvable env comp evd + else (* Best effort: do nothing on this component *) + docomp evd comps + in docomp oevd split + +let initial_select_evars filter = + fun evd ev evi -> + filter ev (snd evi.Evd.evar_source) && + Typeclasses.is_class_evar evd evi + +let resolve_typeclass_evars debug m unique env evd filter split fail = + let evd = + try Evarconv.consider_remaining_unif_problems + ~ts:(Typeclasses.classes_transparent_state ()) env evd + with e when Errors.noncritical e -> evd + in + resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail + +let solve_inst debug depth env evd filter unique split fail = + resolve_typeclass_evars debug depth unique env evd filter split fail + +let _ = + Typeclasses.solve_instantiations_problem := + solve_inst false !typeclasses_depth + +let set_typeclasses_debug d = (:=) typeclasses_debug d; + Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth + +let get_typeclasses_debug () = !typeclasses_debug + +let set_typeclasses_depth d = (:=) typeclasses_depth d; + Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth + +let get_typeclasses_depth () = !typeclasses_depth + +open Goptions + +let set_typeclasses_debug = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "debug output for typeclasses proof search"; + optkey = ["Typeclasses";"Debug"]; + optread = get_typeclasses_debug; + optwrite = set_typeclasses_debug; } + +let set_typeclasses_depth = + declare_int_option + { optsync = true; + optdepr = false; + optname = "depth for typeclasses proof search"; + optkey = ["Typeclasses";"Depth"]; + optread = get_typeclasses_depth; + optwrite = set_typeclasses_depth; } + +let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = + try + let dbs = List.map_filter + (fun db -> try Some (searchtable_map db) + with e when Errors.noncritical e -> None) + dbs + in + let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl + with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl + +(** Take the head of the arity of a constr. + Used in the partial application tactic. *) + +let rec head_of_constr t = + let t = strip_outer_cast(collapse_appl t) in + match kind_of_term t with + | Prod (_,_,c2) -> head_of_constr c2 + | LetIn (_,_,_,c2) -> head_of_constr c2 + | App (f,args) -> head_of_constr f + | _ -> t + +let head_of_constr h c = + let c = head_of_constr c in + letin_tac None (Name h) c None Locusops.allHyps + +let not_evar c = match kind_of_term c with +| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") +| _ -> Proofview.tclUNIT () + +let is_ground c gl = + if Evarutil.is_ground_term (project gl) c then tclIDTAC gl + else tclFAIL 0 (str"Not ground") gl + +let autoapply c i gl = + let flags = auto_unif_flags Evar.Set.empty + (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in + let cty = pf_unsafe_type_of gl c in + let ce = mk_clenv_from gl (c,cty) in + let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),ce) } in + Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/ltac/class_tactics.mli b/ltac/class_tactics.mli new file mode 100644 index 0000000000..f1bcfa7dd4 --- /dev/null +++ b/ltac/class_tactics.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool + +val set_typeclasses_debug : bool -> unit +val get_typeclasses_debug : unit -> bool + +val set_typeclasses_depth : int option -> unit +val get_typeclasses_depth : unit -> int option + +val progress_evars : unit Proofview.tactic -> unit Proofview.tactic + +val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> + Hints.hint_db_name list -> tactic + +val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic + +val not_evar : constr -> unit Proofview.tactic + +val is_ground : constr -> tactic + +val autoapply : constr -> Hints.hint_db_name -> tactic diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 new file mode 100644 index 0000000000..6c02a7202f --- /dev/null +++ b/ltac/coretactics.ml4 @@ -0,0 +1,299 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Tactics.intros_reflexivity ] +END + +TACTIC EXTEND assumption + [ "assumption" ] -> [ Tactics.assumption ] +END + +TACTIC EXTEND etransitivity + [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] +END + +TACTIC EXTEND cut + [ "cut" constr(c) ] -> [ Tactics.cut c ] +END + +TACTIC EXTEND exact_no_check + [ "exact_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.exact_no_check c) ] +END + +TACTIC EXTEND vm_cast_no_check + [ "vm_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ] +END + +TACTIC EXTEND native_cast_no_check + [ "native_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.native_cast_no_check c) ] +END + +TACTIC EXTEND casetype + [ "casetype" constr(c) ] -> [ Tactics.case_type c ] +END + +TACTIC EXTEND elimtype + [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] +END + +TACTIC EXTEND lapply + [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] +END + +TACTIC EXTEND transitivity + [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] +END + +(** Left *) + +TACTIC EXTEND left + [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] +END + +TACTIC EXTEND eleft + [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] +END + +TACTIC EXTEND left_with + [ "left" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) + ] +END + +TACTIC EXTEND eleft_with + [ "eleft" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) + ] +END + +(** Right *) + +TACTIC EXTEND right + [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] +END + +TACTIC EXTEND eright + [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] +END + +TACTIC EXTEND right_with + [ "right" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) + ] +END + +TACTIC EXTEND eright_with + [ "eright" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) + ] +END + +(** Constructor *) + +TACTIC EXTEND constructor + [ "constructor" ] -> [ Tactics.any_constructor false None ] +| [ "constructor" int_or_var(i) ] -> [ + Tactics.constructor_tac false None i NoBindings + ] +| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ + let tac bl = Tactics.constructor_tac false None i bl in + Tacticals.New.tclDELAYEDWITHHOLES false bl tac + ] +END + +TACTIC EXTEND econstructor + [ "econstructor" ] -> [ Tactics.any_constructor true None ] +| [ "econstructor" int_or_var(i) ] -> [ + Tactics.constructor_tac true None i NoBindings + ] +| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ + let tac bl = Tactics.constructor_tac true None i bl in + Tacticals.New.tclDELAYEDWITHHOLES true bl tac + ] +END + +(** Specialize *) + +TACTIC EXTEND specialize + [ "specialize" constr_with_bindings(c) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false c Tactics.specialize + ] +END + +TACTIC EXTEND symmetry + [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +| [ "symmetry" clause_dft_concl(cl) ] -> [ Tactics.intros_symmetry cl ] +END + +(** Split *) + +let rec delayed_list = function +| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } +| x :: l -> + { Tacexpr.delayed = fun env sigma -> + let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in + let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in + Sigma (x :: l, sigma, p +> q) } + +TACTIC EXTEND split + [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +END + +TACTIC EXTEND esplit + [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +END + +TACTIC EXTEND split_with + [ "split" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) + ] +END + +TACTIC EXTEND esplit_with + [ "esplit" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) + ] +END + +TACTIC EXTEND exists + [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) + ] +END + +TACTIC EXTEND eexists + [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) + ] +END + +(** Intro *) + +TACTIC EXTEND intros_until + [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] +END + +(** Move *) + +TACTIC EXTEND move + [ "move" hyp(id) "at" "top" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveFirst) ] +| [ "move" hyp(id) "at" "bottom" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveLast) ] +| [ "move" hyp(id) "after" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveAfter h)) ] +| [ "move" hyp(id) "before" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveBefore h)) ] +END + +(** Revert *) + +TACTIC EXTEND revert + [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] +END + +(** Simple induction / destruct *) + +TACTIC EXTEND simple_induction + [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ] +END + +TACTIC EXTEND simple_destruct + [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] +END + +(* Admit *) + +TACTIC EXTEND admit + [ "admit" ] -> [ Proofview.give_up ] +END + +(* Fix *) + +TACTIC EXTEND fix + [ "fix" natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix None n) ] +| [ "fix" ident(id) natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix (Some id) n) ] +END + +(* Cofix *) + +TACTIC EXTEND cofix + [ "cofix" ] -> [ Proofview.V82.tactic (Tactics.cofix None) ] +| [ "cofix" ident(id) ] -> [ Proofview.V82.tactic (Tactics.cofix (Some id)) ] +END + +(* Clear *) + +TACTIC EXTEND clear + [ "clear" hyp_list(ids) ] -> [ + if List.is_empty ids then Tactics.keep [] + else Proofview.V82.tactic (Tactics.clear ids) + ] +| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] +END + +(* Clearbody *) + +TACTIC EXTEND clearbody + [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] +END + +(* Generalize dependent *) + +TACTIC EXTEND generalize_dependent + [ "generalize" "dependent" constr(c) ] -> [ Proofview.V82.tactic (Tactics.generalize_dep c) ] +END + +(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) + +open Tacexpr + +let initial_atomic () = + let dloc = Loc.ghost in + let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in + let iter (s, t) = + let body = TacAtom (dloc, t) in + Tacenv.register_ltac false false (Id.of_string s) body + in + let () = List.iter iter + [ "red", TacReduce(Red false,nocl); + "hnf", TacReduce(Hnf,nocl); + "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); + "compute", TacReduce(Cbv Redops.all_flags,nocl); + "intro", TacIntroMove(None,MoveLast); + "intros", TacIntroPattern []; + ] + in + let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in + List.iter iter + [ "idtac",TacId []; + "fail", TacFail(TacLocal,ArgArg 0,[]); + "fresh", TacArg(dloc,TacFreshId []) + ] + +let () = Mltop.declare_cache_obj initial_atomic "coretactics" diff --git a/ltac/eauto.ml b/ltac/eauto.ml new file mode 100644 index 0000000000..0449467598 --- /dev/null +++ b/ltac/eauto.ml @@ -0,0 +1,526 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let t1 = Tacmach.New.pf_unsafe_type_of gl c in + let t2 = Tacmach.New.pf_concl gl in + if occur_existential t1 || occur_existential t2 then + Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) + else exact_check c + end } + +let assumption id = e_give_exact (mkVar id) + +let e_assumption = + Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) + end } + +let registered_e_assumption = + Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) + (Tacmach.New.pf_ids_of_hyps gl)) + end } + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + +(************************************************************************) +(* PROLOG tactic *) +(************************************************************************) + +(*s Tactics handling a list of goals. *) + +(* first_goal : goal list sigma -> goal sigma *) + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then error "first_goal"; + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) + +let apply_tac_list tac glls = + let (sigr,lg) = unpackage glls in + match lg with + | (g1::rest) -> + let gl = apply_sig_tac sigr tac g1 in + repackage sigr (gl@rest) + | _ -> error "apply_tac_list" + +let one_step l gl = + [Proofview.V82.of_tactic Tactics.intro] + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) + @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) + +let rec prolog l n gl = + if n <= 0 then error "prolog - failure"; + let prol = (prolog l (n-1)) in + (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl + +let out_term = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + +let prolog_tac l n = + Proofview.V82.tactic begin fun gl -> + let map c = + let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in + out_term c + in + let l = List.map map l in + try (prolog l n gl) + with UserError ("Refiner.tclFIRST",_) -> + errorlabstrm "Prolog.prolog" (str "Prolog failed.") + end + +open Auto +open Unification + +(***************************************************************************) +(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) +(***************************************************************************) + +let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) + +let unify_e_resolve poly flags (c,clenv) = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + Proofview.V82.tactic + (fun gls -> + let clenv' = clenv_unique_resolver ~flags clenv' gls in + tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) + end } + +let hintmap_of hdc concl = + match hdc with + | None -> fun db -> Hint_db.map_none db + | Some hdc -> + if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) + else (fun db -> Hint_db.map_auto hdc concl db) + (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) + +let e_exact poly flags (c,clenv) = + let (c, _, _) = c in + let clenv', subst = + if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst + in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) + +let rec e_trivial_fail_db db_list local_db = + let next = Proofview.Goal.nf_enter { enter = begin fun gl -> + let d = Tacmach.New.pf_last_hyp gl in + let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in + e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) + end } in + Proofview.Goal.enter { enter = begin fun gl -> + let tacl = + registered_e_assumption :: + (Tacticals.New.tclTHEN Tactics.intro next) :: + (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) + in + Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) + end } + +and e_my_find_search db_list local_db hdc concl = + let hint_of_db = hintmap_of hdc concl in + let hintl = + List.map_append (fun db -> + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) + in + let tac_of_hint = + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> + let b = match Hints.repr_hint t with + | Unfold_nth _ -> 1 + | _ -> b + in + (b, + let tac = function + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) + | Res_pf_THEN_trivial_fail (term,cl) -> + Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) + (e_trivial_fail_db db_list local_db) + | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl + | Extern tacast -> conclPattern concl p tacast + in + let tac = run_hint t tac in + (tac, lazy (pr_hint t))) + in + List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db gl = + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try priority (e_my_find_search db_list local_db hd gl) + with Not_found -> [] + +let e_possible_resolve db_list local_db gl = + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) + with Not_found -> [] + +let find_first_goal gls = + try first_goal gls with UserError _ -> assert false + +(*s The following module [SearchProblem] is used to instantiate the generic + exploration functor [Explore.Make]. *) + +type search_state = { + priority : int; + depth : int; (*r depth of search before failing *) + tacres : goal list sigma; + last_tactic : std_ppcmds Lazy.t; + dblist : hint_db list; + localdb : hint_db list; + prev : prev_search_state; + local_lemmas : Tacexpr.delayed_open_constr list; +} + +and prev_search_state = (* for info eauto *) + | Unknown + | Init + | State of search_state + +module SearchProblem = struct + + type state = search_state + + let success s = List.is_empty (sig_it s.tacres) + +(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) + + let filter_tactics glls l = +(* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) +(* let evars = Evarutil.nf_evars (Refiner.project glls) in *) +(* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) + let rec aux = function + | [] -> [] + | (tac, cost, pptac) :: tacl -> + try + let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in +(* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) +(* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) + (lgls, cost, pptac) :: aux tacl + with e when Errors.noncritical e -> + let e = Errors.push e in + Refiner.catch_failerror e; aux tacl + in aux l + + (* Ordering of states is lexicographic on depth (greatest first) then + number of remaining goals. *) + let compare s s' = + let d = s'.depth - s.depth in + let d' = Int.compare s.priority s'.priority in + let nbgoals s = List.length (sig_it s.tacres) in + if not (Int.equal d 0) then d + else if not (Int.equal d' 0) then d' + else Int.compare (nbgoals s) (nbgoals s') + + let branching s = + if Int.equal s.depth 0 then + [] + else + let ps = if s.prev == Unknown then Unknown else State s in + let lg = s.tacres in + let nbgl = List.length (sig_it lg) in + assert (nbgl > 0); + let g = find_first_goal lg in + let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in + let assumption_tacs = + let tacs = List.map map_assum (pf_ids_of_hyps g) in + let l = filter_tactics s.tacres tacs in + List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = List.tl s.localdb; + prev = ps; local_lemmas = s.local_lemmas}) l + in + let intro_tac = + let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in + List.map + (fun (lgls, cost, pp) -> + let g' = first_goal lgls in + let hintl = + make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in + let ldb = Hint_db.add_list (pf_env g') (project g') + hintl (List.hd s.localdb) in + { depth = s.depth; priority = cost; tacres = lgls; + last_tactic = pp; dblist = s.dblist; + localdb = ldb :: List.tl s.localdb; prev = ps; + local_lemmas = s.local_lemmas}) + l + in + let rec_tacs = + let l = + filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + in + List.map + (fun (lgls, cost, pp) -> + let nbgl' = List.length (sig_it lgls) in + if nbgl' < nbgl then + { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; + prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; + local_lemmas = s.local_lemmas } + else + let newlocal = + let hyps = pf_hyps g in + List.map (fun gl -> + let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in + let hyps' = pf_hyps gls in + if hyps' == hyps then List.hd s.localdb + else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) + (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) + in + { depth = pred s.depth; priority = cost; tacres = lgls; + dblist = s.dblist; last_tactic = pp; prev = ps; + localdb = newlocal @ List.tl s.localdb; + local_lemmas = s.local_lemmas }) + l + in + List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + + let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + (Lazy.force s.last_tactic)) + +end + +module Search = Explore.Make(SearchProblem) + +(** Utilities for debug eauto / info eauto *) + +let global_debug_eauto = ref false +let global_info_eauto = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Debug Eauto"; + Goptions.optkey = ["Debug";"Eauto"]; + Goptions.optread = (fun () -> !global_debug_eauto); + Goptions.optwrite = (:=) global_debug_eauto } + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Info Eauto"; + Goptions.optkey = ["Info";"Eauto"]; + Goptions.optread = (fun () -> !global_info_eauto); + Goptions.optwrite = (:=) global_info_eauto } + +let mk_eauto_dbg d = + if d == Debug || !global_debug_eauto then Debug + else if d == Info || !global_info_eauto then Info + else Off + +let pr_info_nop = function + | Info -> msg_debug (str "idtac.") + | _ -> () + +let pr_dbg_header = function + | Off -> () + | Debug -> msg_debug (str "(* debug eauto : *)") + | Info -> msg_debug (str "(* info eauto : *)") + +let pr_info dbg s = + if dbg != Info then () + else + let rec loop s = + match s.prev with + | Unknown | Init -> s.depth + | State sp -> + let mindepth = loop sp in + let indent = String.make (mindepth - sp.depth) ' ' in + msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + mindepth + in + ignore (loop s) + +(** Eauto main code *) + +let make_initial_state dbg n gl dblist localdb lems = + { depth = n; + priority = 0; + tacres = tclIDTAC gl; + last_tactic = lazy (mt()); + dblist = dblist; + localdb = [localdb]; + prev = if dbg == Info then Init else Unknown; + local_lemmas = lems; + } + +let e_search_auto debug (in_depth,p) lems db_list gl = + let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in + let d = mk_eauto_dbg debug in + let tac = match in_depth,d with + | (true,Debug) -> Search.debug_depth_first + | (true,_) -> Search.depth_first + | (false,Debug) -> Search.debug_breadth_first + | (false,_) -> Search.breadth_first + in + try + pr_dbg_header d; + let s = tac (make_initial_state d p gl db_list local_db lems) in + pr_info d s; + s.tacres + with Not_found -> + pr_info_nop d; + error "eauto: search failed" + +(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) +(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) + +let eauto_with_bases ?(debug=Off) np lems db_list = + tclTRY (e_search_auto debug np lems db_list) + +let eauto ?(debug=Off) np lems dbnames = + let db_list = make_db_list dbnames in + tclTRY (e_search_auto debug np lems db_list) + +let full_eauto ?(debug=Off) n lems gl = + let dbnames = current_db_names () in + let dbnames = String.Set.remove "v62" dbnames in + let db_list = List.map searchtable_map (String.Set.elements dbnames) in + tclTRY (e_search_auto debug n lems db_list) gl + +let gen_eauto ?(debug=Off) np lems = function + | None -> Proofview.V82.tactic (full_eauto ~debug np lems) + | Some l -> Proofview.V82.tactic (eauto ~debug np lems l) + +let make_depth = function + | None -> !default_search_depth + | Some d -> d + +let make_dimension n = function + | None -> (true,make_depth n) + | Some d -> (false,d) + +let cons a l = a :: l + +let autounfolds db occs cls gl = + let unfolds = List.concat (List.map (fun dbname -> + let db = try searchtable_map dbname + with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + in + let (ids, csts) = Hint_db.unfolds db in + let hyps = pf_ids_of_hyps gl in + let ids = Idset.filter (fun id -> List.mem id hyps) ids in + Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts + (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) + in Proofview.V82.of_tactic (unfold_option unfolds cls) gl + +let autounfold db cls = + Proofview.V82.tactic begin fun gl -> + let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in + let tac = autounfolds db in + tclMAP (function + | OnHyp (id,occs,where) -> tac occs (Some (id,where)) + | OnConcl occs -> tac occs None) + cls gl + end + +let autounfold_tac db cls = + Proofview.tclUNIT () >>= fun () -> + let dbs = match db with + | None -> String.Set.elements (current_db_names ()) + | Some [] -> ["core"] + | Some l -> l + in + autounfold dbs cls + +let unfold_head env (ids, csts) c = + let rec aux c = + match kind_of_term c with + | Var id when Id.Set.mem id ids -> + (match Environ.named_body id env with + | Some b -> true, b + | None -> false, c) + | Const (cst,u as c) when Cset.mem cst csts -> + true, Environ.constant_value_in env c + | App (f, args) -> + (match aux f with + | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) + | false, _ -> + let done_, args' = + Array.fold_left_i (fun i (done_, acc) arg -> + if done_ then done_, arg :: acc + else match aux arg with + | true, arg' -> true, arg' :: acc + | false, arg' -> false, arg :: acc) + (false, []) args + in + if done_ then true, mkApp (f, Array.of_list (List.rev args')) + else false, c) + | _ -> + let done_ = ref false in + let c' = map_constr (fun c -> + if !done_ then c else + let x, c' = aux c in + done_ := x; c') c + in !done_, c' + in aux c + +let autounfold_one db cl = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let st = + List.fold_left (fun (i,c) dbname -> + let db = try searchtable_map dbname + with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + in + let (ids, csts) = Hint_db.unfolds db in + (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db + in + let did, c' = unfold_head env st + (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) + in + if did then + match cl with + | Some hyp -> change_in_hyp None (make_change_arg c') hyp + | None -> convert_concl_no_check c' DEFAULTcast + else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") + end } diff --git a/ltac/eauto.mli b/ltac/eauto.mli new file mode 100644 index 0000000000..8812093d5f --- /dev/null +++ b/ltac/eauto.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> unit Proofview.tactic + +val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic + +val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> + hint_db_name list option -> unit Proofview.tactic + +val eauto_with_bases : + ?debug:Tacexpr.debug -> + bool * int -> + Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic + +val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic +val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic +val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic + +val make_dimension : int option -> int option -> bool * int diff --git a/ltac/eqdecide.ml b/ltac/eqdecide.ml new file mode 100644 index 0000000000..7d0df2f522 --- /dev/null +++ b/ltac/eqdecide.ml @@ -0,0 +1,225 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (clear [destVar c]))) + +let choose_eq eqonleft = + if eqonleft then + left_with_bindings false Misctypes.NoBindings + else + right_with_bindings false Misctypes.NoBindings +let choose_noteq eqonleft = + if eqonleft then + right_with_bindings false Misctypes.NoBindings + else + left_with_bindings false Misctypes.NoBindings + +let mkBranches c1 c2 = + tclTHENLIST + [Proofview.V82.tactic (generalize [c2]); + Simple.elim c1; + intros; + onLastHyp Simple.case; + clear_last; + intros] + +let solveNoteqBranch side = + tclTHEN (choose_noteq side) + (tclTHEN introf + (onLastHypId (fun id -> Extratactics.discrHyp id))) + +(* Constructs the type {c1=c2}+{~c1=c2} *) + +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + +let mkDecideEqGoal eqonleft op rectype c1 c2 = + let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in + let disequality = mkApp(build_coq_not (), [|equality|]) in + if eqonleft then mkApp(op, [|equality; disequality |]) + else mkApp(op, [|disequality; equality |]) + + +(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) + +let idx = Id.of_string "x" +let idy = Id.of_string "y" + +let mkGenDecideEqGoal rectype g = + let hypnames = pf_ids_of_hyps g in + let xname = next_ident_away idx hypnames + and yname = next_ident_away idy hypnames in + (mkNamedProd xname rectype + (mkNamedProd yname rectype + (mkDecideEqGoal true (build_coq_sumbool ()) + rectype (mkVar xname) (mkVar yname)))) + +let rec rewrite_and_clear hyps = match hyps with +| [] -> Proofview.tclUNIT () +| id :: hyps -> + tclTHENLIST [ + Equality.rewriteLR (mkVar id); + clear [id]; + rewrite_and_clear hyps; + ] + +let eqCase tac = + tclTHEN intro (onLastHypId tac) + +let diseqCase hyps eqonleft = + let diseq = Id.of_string "diseq" in + let absurd = Id.of_string "absurd" in + (tclTHEN (intro_using diseq) + (tclTHEN (choose_noteq eqonleft) + (tclTHEN (rewrite_and_clear (List.rev hyps)) + (tclTHEN (red_in_concl) + (tclTHEN (intro_using absurd) + (tclTHEN (Simple.apply (mkVar diseq)) + (tclTHEN (Extratactics.injHyp absurd) + (full_trivial [])))))))) + +open Proofview.Notations + +(* spiwack: a small wrapper around [Hipattern]. *) + +let match_eqdec c = + try Proofview.tclUNIT (match_eqdec c) + with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure + +(* /spiwack *) + +let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with +| [], [] -> + tclTHENLIST [ + choose_eq eqonleft; + rewrite_and_clear (List.rev hyps); + intros_reflexivity; + ] +| a1 :: largs, a2 :: rargs -> + Proofview.Goal.enter { enter = begin fun gl -> + let rectype = pf_unsafe_type_of gl a1 in + let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in + let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in + let subtacs = + if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] + else [diseqCase hyps eqonleft;eqCase tac;default_auto] in + (tclTHENS (elim_type decide) subtacs) + end } +| _ -> invalid_arg "List.fold_right2" + +let solveEqBranch rectype = + Proofview.tclORELSE + begin + Proofview.Goal.enter { enter = begin fun gl -> + let concl = pf_nf_concl gl in + match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) -> + let (mib,mip) = Global.lookup_inductive rectype in + let nparams = mib.mind_nparams in + let getargs l = List.skipn nparams (snd (decompose_app l)) in + let rargs = getargs rhs + and largs = getargs lhs in + solveArg [] eqonleft op largs rargs + end } + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") + | e -> Proofview.tclZERO ~info e + end + +(* The tactic Decide Equality *) + +let hd_app c = match kind_of_term c with + | App (h,_) -> h + | _ -> c + +let decideGralEquality = + Proofview.tclORELSE + begin + Proofview.Goal.enter { enter = begin fun gl -> + let concl = pf_nf_concl gl in + match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> + let headtyp = hd_app (pf_compute gl typ) in + begin match kind_of_term headtyp with + | Ind (mi,_) -> Proofview.tclUNIT mi + | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") + end >>= fun rectype -> + (tclTHEN + (mkBranches c1 c2) + (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) + end } + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> + Tacticals.New.tclZEROMSG (Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.") + | e -> Proofview.tclZERO ~info e + end + +let decideEqualityGoal = tclTHEN intros decideGralEquality + +let decideEquality rectype = + Proofview.Goal.enter { enter = begin fun gl -> + let decide = mkGenDecideEqGoal rectype gl in + (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) + end } + + +(* The tactic Compare *) + +let compare c1 c2 = + Proofview.Goal.enter { enter = begin fun gl -> + let rectype = pf_unsafe_type_of gl c1 in + let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in + (tclTHENS (cut decide) + [(tclTHEN intro + (tclTHEN (onLastHyp simplest_case) clear_last)); + decideEquality rectype]) + end } diff --git a/ltac/eqdecide.mli b/ltac/eqdecide.mli new file mode 100644 index 0000000000..cb48a5bcc8 --- /dev/null +++ b/ltac/eqdecide.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Constr.t -> unit Proofview.tactic diff --git a/ltac/evar_tactics.ml b/ltac/evar_tactics.ml new file mode 100644 index 0000000000..2e0996bf5a --- /dev/null +++ b/ltac/evar_tactics.ml @@ -0,0 +1,91 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let sigma = gl.sigma in + let evl = + match ido with + ConclLocation () -> evar_list (pf_concl gl) + | HypLocation (id,hloc) -> + let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in + match hloc with + InHyp -> + (match decl with + | LocalAssum (_,typ) -> evar_list typ + | _ -> error + "Please be more specific: in type or value?") + | InHypTypeOnly -> + evar_list (get_type decl) + | InHypValueOnly -> + (match decl with + | LocalDef (_,body,_) -> evar_list body + | _ -> error "Not a defined hypothesis.") in + if List.length evl < n then + error "Not enough uninstantiated existential variables."; + if n <= 0 then error "Incorrect existential variable index."; + let evk,_ = List.nth evl (n-1) in + instantiate_evar evk c sigma gl + end + +let instantiate_tac_by_name id c = + Proofview.V82.tactic begin fun gl -> + let sigma = gl.sigma in + let evk = + try Evd.evar_key id sigma + with Not_found -> error "Unknown existential variable." in + instantiate_evar evk c sigma gl + end + +let let_evar name typ = + let src = (Loc.ghost,Evar_kinds.GoalEvar) in + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let sigma = ref sigma in + let _ = Typing.e_sort_of env sigma typ in + let sigma = Sigma.Unsafe.of_evar_map !sigma in + let id = match name with + | Names.Anonymous -> + let id = Namegen.id_of_name_using_hdchar env typ name in + Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) + | Names.Name id -> id + in + let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let tac = + (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) + in + Sigma (tac, sigma, p) + end } diff --git a/ltac/evar_tactics.mli b/ltac/evar_tactics.mli new file mode 100644 index 0000000000..e67540c055 --- /dev/null +++ b/ltac/evar_tactics.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Tacinterp.interp_sign * Glob_term.glob_constr -> + (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic + +val instantiate_tac_by_name : Id.t -> + Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic + +val let_evar : Name.t -> Term.types -> unit Proofview.tactic diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 new file mode 100644 index 0000000000..d33ec91f9d --- /dev/null +++ b/ltac/extraargs.ml4 @@ -0,0 +1,345 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* " + +let pr_orient _prc _prlc _prt = function + | true -> Pp.mt () + | false -> Pp.str " <-" + +ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient +| [ "->" ] -> [ true ] +| [ "<-" ] -> [ false ] +| [ ] -> [ true ] +END + +let pr_int _ _ _ i = Pp.int i + +let _natural = Pcoq.Prim.natural + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int +| [ _natural(i) ] -> [ i ] +END + +let pr_orient = pr_orient () () () + + +let pr_int_list = Pp.pr_sequence Pp.int +let pr_int_list_full _prc _prlc _prt l = pr_int_list l + +let pr_occurrences _prc _prlc _prt l = + match l with + | ArgArg x -> pr_int_list x + | ArgVar (loc, id) -> Nameops.pr_id id + +let occurrences_of = function + | [] -> NoOccurrences + | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + Errors.error "Illegal negative occurrence number."; + OnlyOccurrences nl + +let coerce_to_int v = match Value.to_int v with + | None -> raise (CannotCoerceTo "an integer") + | Some n -> n + +let int_list_of_VList v = match Value.to_list v with +| Some l -> List.map (fun n -> coerce_to_int n) l +| _ -> raise (CannotCoerceTo "an integer") + +let interp_occs ist gl l = + match l with + | ArgArg x -> x + | ArgVar (_,id as locid) -> + (try int_list_of_VList (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) +let interp_occs ist gl l = + Tacmach.project gl , interp_occs ist gl l + +let glob_occs ist l = l + +let subst_occs evm l = l + +ARGUMENT EXTEND occurrences + PRINTED BY pr_int_list_full + + INTERPRETED BY interp_occs + GLOBALIZED BY glob_occs + SUBSTITUTED BY subst_occs + + RAW_TYPED AS occurrences_or_var + RAW_PRINTED BY pr_occurrences + + GLOB_TYPED AS occurrences_or_var + GLOB_PRINTED BY pr_occurrences + +| [ ne_integer_list(l) ] -> [ ArgArg l ] +| [ var(id) ] -> [ ArgVar id ] +END + +let pr_occurrences = pr_occurrences () () () + +let pr_gen prc _prlc _prtac c = prc c + +let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob + +let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) + +let glob_glob = Tacintern.intern_constr + +let pr_lconstr _ prc _ c = prc c + +let subst_glob = Tacsubst.subst_glob_constr_and_expr + +ARGUMENT EXTEND glob + PRINTED BY pr_globc + + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob + + RAW_TYPED AS constr_expr + RAW_PRINTED BY pr_gen + + GLOB_TYPED AS glob_constr_and_expr + GLOB_PRINTED BY pr_gen + [ constr(c) ] -> [ c ] +END + +let l_constr = Pcoq.Constr.lconstr + +ARGUMENT EXTEND lconstr + TYPED AS constr + PRINTED BY pr_lconstr + [ l_constr(c) ] -> [ c ] +END + +ARGUMENT EXTEND lglob + PRINTED BY pr_globc + + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob + + RAW_TYPED AS constr_expr + RAW_PRINTED BY pr_gen + + GLOB_TYPED AS glob_constr_and_expr + GLOB_PRINTED BY pr_gen + [ lconstr(c) ] -> [ c ] +END + +type 'id gen_place= ('id * hyp_location_flag,unit) location + +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place + +let pr_gen_place pr_id = function + ConclLocation () -> Pp.mt () + | HypLocation (id,InHyp) -> str "in " ++ pr_id id + | HypLocation (id,InHypTypeOnly) -> + str "in (Type of " ++ pr_id id ++ str ")" + | HypLocation (id,InHypValueOnly) -> + str "in (Value of " ++ pr_id id ++ str ")" + +let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) +let pr_place _ _ _ = pr_gen_place Nameops.pr_id +let pr_hloc = pr_loc_place () () () + +let intern_place ist = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) + +let interp_place ist env sigma = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) + +let interp_place ist gl p = + Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p + +let subst_place subst pl = pl + +ARGUMENT EXTEND hloc + PRINTED BY pr_place + INTERPRETED BY interp_place + GLOBALIZED BY intern_place + SUBSTITUTED BY subst_place + RAW_TYPED AS loc_place + RAW_PRINTED BY pr_loc_place + GLOB_TYPED AS loc_place + GLOB_PRINTED BY pr_loc_place + [ ] -> + [ ConclLocation () ] + | [ "in" "|-" "*" ] -> + [ ConclLocation () ] +| [ "in" ident(id) ] -> + [ HypLocation ((Loc.ghost,id),InHyp) ] +| [ "in" "(" "Type" "of" ident(id) ")" ] -> + [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] +| [ "in" "(" "Value" "of" ident(id) ")" ] -> + [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] + + END + + + + + + + +(* Julien: Mise en commun des differentes version de replace with in by *) + +let pr_by_arg_tac _prc _prlc prtac opt_c = + match opt_c with + | None -> mt () + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) + +ARGUMENT EXTEND by_arg_tac + TYPED AS tactic_opt + PRINTED BY pr_by_arg_tac +| [ "by" tactic3(c) ] -> [ Some c ] +| [ ] -> [ None ] +END + +let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c + +(* spiwack: the print functions are incomplete, but I don't know what they are + used for *) +let pr_r_nat_field natf = + str "nat " ++ + match natf with + | Retroknowledge.NatType -> str "type" + | Retroknowledge.NatPlus -> str "plus" + | Retroknowledge.NatTimes -> str "times" + +let pr_r_n_field nf = + str "binary N " ++ + match nf with + | Retroknowledge.NPositive -> str "positive" + | Retroknowledge.NType -> str "type" + | Retroknowledge.NTwice -> str "twice" + | Retroknowledge.NTwicePlusOne -> str "twice plus one" + | Retroknowledge.NPhi -> str "phi" + | Retroknowledge.NPhiInv -> str "phi inv" + | Retroknowledge.NPlus -> str "plus" + | Retroknowledge.NTimes -> str "times" + +let pr_r_int31_field i31f = + str "int31 " ++ + match i31f with + | Retroknowledge.Int31Bits -> str "bits" + | Retroknowledge.Int31Type -> str "type" + | Retroknowledge.Int31Twice -> str "twice" + | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" + | Retroknowledge.Int31Phi -> str "phi" + | Retroknowledge.Int31PhiInv -> str "phi inv" + | Retroknowledge.Int31Plus -> str "plus" + | Retroknowledge.Int31Times -> str "times" + | _ -> assert false + +let pr_retroknowledge_field f = + match f with + (* | Retroknowledge.KEq -> str "equality" + | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf + | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) + | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ + str "in " ++ str group + +VERNAC ARGUMENT EXTEND retroknowledge_nat +PRINTED BY pr_r_nat_field +| [ "nat" "type" ] -> [ Retroknowledge.NatType ] +| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] +| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] +END + + +VERNAC ARGUMENT EXTEND retroknowledge_binary_n +PRINTED BY pr_r_n_field +| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] +| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] +| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] +| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] +| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] +| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] +| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] +| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] +END + +VERNAC ARGUMENT EXTEND retroknowledge_int31 +PRINTED BY pr_r_int31_field +| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] +| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] +| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] +| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] +| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] +| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] +| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] +| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] +| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] +| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] +| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] +| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] +| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] +| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] +| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] +| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] +| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] +| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] +| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] +| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] +| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] +| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] +| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] +| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] +END + +VERNAC ARGUMENT EXTEND retroknowledge_field +PRINTED BY pr_retroknowledge_field +(*| [ "equality" ] -> [ Retroknowledge.KEq ] +| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] +| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) +| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] +END diff --git a/ltac/extraargs.mli b/ltac/extraargs.mli new file mode 100644 index 0000000000..14aa69875f --- /dev/null +++ b/ltac/extraargs.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Pp.std_ppcmds + +val occurrences : (int list or_var) Pcoq.Gram.entry +val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type +val pr_occurrences : int list or_var -> Pp.std_ppcmds +val occurrences_of : int list -> Locus.occurrences + +val wit_natural : int Genarg.uniform_genarg_type + +val wit_glob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type + +val wit_lglob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type + +val wit_lconstr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Constr.t) Genarg.genarg_type + +val glob : constr_expr Pcoq.Gram.entry +val lglob : constr_expr Pcoq.Gram.entry + +type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location + +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place + +val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type +val hloc : loc_place Pcoq.Gram.entry +val pr_hloc : loc_place -> Pp.std_ppcmds + +val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry +val wit_by_arg_tac : + (raw_tactic_expr option, + glob_tactic_expr option, + Genarg.Val.t option) Genarg.genarg_type + +val pr_by_arg_tac : + (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> + raw_tactic_expr option -> Pp.std_ppcmds + +(** Spiwack: Primitive for retroknowledge registration *) + +val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry +val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 new file mode 100644 index 0000000000..23aa8dcb47 --- /dev/null +++ b/ltac/extratactics.ml4 @@ -0,0 +1,1048 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) + +let replace_term ist dir_opt c cl = + with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) + +let clause = Pcoq.Tactic.clause_dft_concl + +TACTIC EXTEND replace + ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] +END + +TACTIC EXTEND replace_term_left + [ "replace" "->" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some true) c cl ] +END + +TACTIC EXTEND replace_term_right + [ "replace" "<-" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some false) c cl ] +END + +TACTIC EXTEND replace_term + [ "replace" uconstr(c) clause(cl) ] + -> [ replace_term ist None c cl ] +END + +let induction_arg_of_quantified_hyp = function + | AnonHyp n -> None,ElimOnAnonHyp n + | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) + +(* Versions *_main must come first!! so that "1" is interpreted as a + ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a + ElimOnIdent and not as "constr" *) + +let elimOnConstrWithHoles tac with_evars c = + Tacticals.New.tclDELAYEDWITHHOLES with_evars c + (fun c -> tac with_evars (Some (None,ElimOnConstr c))) + +TACTIC EXTEND simplify_eq_main +| [ "simplify_eq" constr_with_bindings(c) ] -> + [ elimOnConstrWithHoles dEq false c ] +END +TACTIC EXTEND simplify_eq + [ "simplify_eq" ] -> [ dEq false None ] +| [ "simplify_eq" quantified_hypothesis(h) ] -> + [ dEq false (Some (induction_arg_of_quantified_hyp h)) ] +END +TACTIC EXTEND esimplify_eq_main +| [ "esimplify_eq" constr_with_bindings(c) ] -> + [ elimOnConstrWithHoles dEq true c ] +END +TACTIC EXTEND esimplify_eq +| [ "esimplify_eq" ] -> [ dEq true None ] +| [ "esimplify_eq" quantified_hypothesis(h) ] -> + [ dEq true (Some (induction_arg_of_quantified_hyp h)) ] +END + +let discr_main c = elimOnConstrWithHoles discr_tac false c + +TACTIC EXTEND discriminate_main +| [ "discriminate" constr_with_bindings(c) ] -> + [ discr_main c ] +END +TACTIC EXTEND discriminate +| [ "discriminate" ] -> [ discr_tac false None ] +| [ "discriminate" quantified_hypothesis(h) ] -> + [ discr_tac false (Some (induction_arg_of_quantified_hyp h)) ] +END +TACTIC EXTEND ediscriminate_main +| [ "ediscriminate" constr_with_bindings(c) ] -> + [ elimOnConstrWithHoles discr_tac true c ] +END +TACTIC EXTEND ediscriminate +| [ "ediscriminate" ] -> [ discr_tac true None ] +| [ "ediscriminate" quantified_hypothesis(h) ] -> + [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ] +END + +open Proofview.Notations +let discrHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } + +let injection_main c = + elimOnConstrWithHoles (injClause None) false c + +TACTIC EXTEND injection_main +| [ "injection" constr_with_bindings(c) ] -> + [ injection_main c ] +END +TACTIC EXTEND injection +| [ "injection" ] -> [ injClause None false None ] +| [ "injection" quantified_hypothesis(h) ] -> + [ injClause None false (Some (induction_arg_of_quantified_hyp h)) ] +END +TACTIC EXTEND einjection_main +| [ "einjection" constr_with_bindings(c) ] -> + [ elimOnConstrWithHoles (injClause None) true c ] +END +TACTIC EXTEND einjection +| [ "einjection" ] -> [ injClause None true None ] +| [ "einjection" quantified_hypothesis(h) ] -> [ injClause None true (Some (induction_arg_of_quantified_hyp h)) ] +END +TACTIC EXTEND injection_as_main +| [ "injection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> + [ elimOnConstrWithHoles (injClause (Some ipat)) false c ] +END +TACTIC EXTEND injection_as +| [ "injection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) false None ] +| [ "injection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> + [ injClause (Some ipat) false (Some (induction_arg_of_quantified_hyp h)) ] +END +TACTIC EXTEND einjection_as_main +| [ "einjection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> + [ elimOnConstrWithHoles (injClause (Some ipat)) true c ] +END +TACTIC EXTEND einjection_as +| [ "einjection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) true None ] +| [ "einjection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> + [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ] +END + +let injHyp id = + Proofview.tclEVARMAP >>= fun sigma -> + injection_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } + +TACTIC EXTEND dependent_rewrite +| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] +| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] + -> [ rewriteInHyp b c id ] +END + +(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to + "replace u with t" or "enough (t=u) as <-" and + "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) + +TACTIC EXTEND cut_rewrite +| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] + -> [ cutRewriteInHyp b eqn id ] +END + +(**********************************************************************) +(* Decompose *) + +TACTIC EXTEND decompose_sum +| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] +END + +TACTIC EXTEND decompose_record +| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] +END + +(**********************************************************************) +(* Contradiction *) + +open Contradiction + +TACTIC EXTEND absurd + [ "absurd" constr(c) ] -> [ absurd c ] +END + +let onSomeWithHoles tac = function + | None -> tac None + | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) + +TACTIC EXTEND contradiction + [ "contradiction" constr_with_bindings_opt(c) ] -> + [ onSomeWithHoles contradiction c ] +END + +(**********************************************************************) +(* AutoRewrite *) + +open Autorewrite + +let pr_orient _prc _prlc _prt = function + | true -> Pp.mt () + | false -> Pp.str " <-" + +let pr_orient_string _prc _prlc _prt (orient, s) = + pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s + +ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string +| [ orient(r) preident(i) ] -> [ r, i ] +END + +TACTIC EXTEND autorewrite +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite l ( cl) ] +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> + [ + auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl + ] +END + +TACTIC EXTEND autorewrite_star +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite ~conds:AllMatches l cl ] +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> + [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] +END + +(**********************************************************************) +(* Rewrite star *) + +let rewrite_star ist clause orient occs c (tac : Val.t option) = + let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in + with_delayed_uconstr ist c + (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) + +TACTIC EXTEND rewrite_star +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist None o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> + [ rewrite_star ist None o Locus.AllOccurrences c tac ] + END + +(**********************************************************************) +(* Hint Rewrite *) + +let add_rewrite_hint bases ort t lcsr = + let env = Global.env() in + let sigma = Evd.from_env env in + let poly = Flags.use_polymorphic_flag () in + let f ce = + let c, ctx = Constrintern.interp_constr env sigma ce in + let ctx = + let ctx = UState.context_set ctx in + if poly then ctx + else (Global.push_context_set false ctx; Univ.ContextSet.empty) + in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in + let eqs = List.map f lcsr in + let add_hints base = add_rew_rules base eqs in + List.iter add_hints bases + +let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater + +VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint + [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o None l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) + ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o (Some t) l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + [ add_rewrite_hint ["core"] o None l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + [ add_rewrite_hint ["core"] o (Some t) l ] +END + +(**********************************************************************) +(* Hint Resolve *) + +open Term +open Vars +open Coqlib + +let project_hint pri l2r r = + let gr = Smartlocate.global_with_alias r in + let env = Global.env() in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in + let sign,ccl = decompose_prod_assum t in + let (a,b) = match snd (decompose_app ccl) with + | [a;b] -> (a,b) + | _ -> assert false in + let p = + if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in + let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_vect 0 sign)) in + let c = it_mkLambda_or_LetIn + (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let ctx = Evd.universe_context_set sigma in + let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in + (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) + +let add_hints_iff l2r lc n bl = + Hints.add_hints true bl + (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) + +VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) + ":" preident_list(bl) ] -> + [ add_hints_iff true lc n bl ] +| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> + [ add_hints_iff true lc n ["core"] ] +END +VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) + ":" preident_list(bl) ] -> + [ add_hints_iff false lc n bl ] +| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> + [ add_hints_iff false lc n ["core"] ] +END + +(**********************************************************************) +(* Refine *) + +let refine_tac ist simple c = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let flags = Pretyping.all_no_fail_flags in + let expected_type = Pretyping.OfType concl in + let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in + let update = { run = fun sigma -> c.delayed env sigma } in + let refine = Refine.refine ~unsafe:false update in + if simple then refine + else refine <*> + Tactics.New.reduce_after_refine <*> + Proofview.shelve_unifiable + end } + +TACTIC EXTEND refine +| [ "refine" uconstr(c) ] -> [ refine_tac ist false c ] +END + +TACTIC EXTEND simple_refine +| [ "simple" "refine" uconstr(c) ] -> [ refine_tac ist true c ] +END + +(**********************************************************************) +(* Inversion lemmas (Leminv) *) + +open Inv +open Leminv + +let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater + +VERNAC COMMAND EXTEND DeriveInversionClear +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] + +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] +END + +open Term + +VERNAC COMMAND EXTEND DeriveInversion +| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s false inv_tac ] + +| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_tac ] +END + +VERNAC COMMAND EXTEND DeriveDependentInversion +| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s true dinv_tac ] +END + +VERNAC COMMAND EXTEND DeriveDependentInversionClear +| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] +END + +(**********************************************************************) +(* Subst *) + +TACTIC EXTEND subst +| [ "subst" ne_var_list(l) ] -> [ subst l ] +| [ "subst" ] -> [ subst_all () ] +END + +let simple_subst_tactic_flags = + { only_leibniz = true; rewrite_dependent_proof = false } + +TACTIC EXTEND simple_subst +| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] +END + +open Evar_tactics + +(**********************************************************************) +(* Evar creation *) + +(* TODO: add support for some test similar to g_constr.name_colon so that + expressions like "evar (list A)" do not raise a syntax error *) +TACTIC EXTEND evar + [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] +| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] +END + +open Tacticals + +TACTIC EXTEND instantiate + [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> + [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] +| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> + [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] +| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] +END + +(**********************************************************************) +(** Nijmegen "step" tactic for setoid rewriting *) + +open Tactics +open Glob_term +open Libobject +open Lib + +(* Registered lemmas are expected to be of the form + x R y -> y == z -> x R z (in the right table) + x R y -> x == z -> z R y (in the left table) +*) + +let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r" +let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" + +(* [step] tries to apply a rewriting lemma; then apply [tac] intended to + complete to proof of the last hypothesis (assumed to state an equality) *) + +let step left x tac = + let l = + List.map (fun lem -> + Tacticals.New.tclTHENLAST + (apply_with_bindings (lem, ImplicitBindings [x])) + tac) + !(if left then transitivity_left_table else transitivity_right_table) + in + Tacticals.New.tclFIRST l + +(* Main function to push lemmas in persistent environment *) + +let cache_transitivity_lemma (_,(left,lem)) = + if left then + transitivity_left_table := lem :: !transitivity_left_table + else + transitivity_right_table := lem :: !transitivity_right_table + +let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) + +let inTransitivity : bool * constr -> obj = + declare_object {(default_object "TRANSITIVITY-STEPS") with + cache_function = cache_transitivity_lemma; + open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); + subst_function = subst_transitivity_lemma; + classify_function = (fun o -> Substitute o) } + +(* Main entry points *) + +let add_transitivity_lemma left lem = + let env = Global.env () in + let sigma = Evd.from_env env in + let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in + add_anonymous_leaf (inTransitivity (left,lem')) + +(* Vernacular syntax *) + +TACTIC EXTEND stepl +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] +| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] +END + +TACTIC EXTEND stepr +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] +| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] +END + +VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF +| [ "Declare" "Left" "Step" constr(t) ] -> + [ add_transitivity_lemma true t ] +END + +VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF +| [ "Declare" "Right" "Step" constr(t) ] -> + [ add_transitivity_lemma false t ] +END + +VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF +| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> + [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ] +| [ "Clear" "Implicit" "Tactic" ] -> + [ Pfedit.clear_implicit_tactic () ] +END + + + + +(**********************************************************************) +(*spiwack : Vernac commands for retroknowledge *) + +VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF + | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> + [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in + let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in + Global.register f tc tb ] +END + + + +(**********************************************************************) +(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as + defined by Conor McBride *) +TACTIC EXTEND generalize_eqs +| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] +END +TACTIC EXTEND dep_generalize_eqs +| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] +END +TACTIC EXTEND generalize_eqs_vars +| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] +END +TACTIC EXTEND dep_generalize_eqs_vars +| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] +END + +(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] + where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated + during dependent induction. For internal use. *) + +TACTIC EXTEND specialize_eqs +[ "specialize_eqs" hyp(id) ] -> [ Proofview.V82.tactic (specialize_eqs id) ] +END + +(**********************************************************************) +(* A tactic that considers a given occurrence of [c] in [t] and *) +(* abstract the minimal set of all the occurrences of [c] so that the *) +(* abstraction [fun x -> t[x/c]] is well-typed *) +(* *) +(* Contributed by Chung-Kil Hur (Winter 2009) *) +(**********************************************************************) + +let subst_var_with_hole occ tid t = + let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in + let locref = ref 0 in + let rec substrec = function + | GVar (_,id) as x -> + if Id.equal id tid + then + (decr occref; + if Int.equal !occref 0 then x + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true), + Misctypes.IntroAnonymous, None))) + else x + | c -> map_glob_constr_left_to_right substrec c in + let t' = substrec t + in + if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' + +let subst_hole_with_term occ tc t = + let locref = ref 0 in + let occref = ref occ in + let rec substrec = function + | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> + decr occref; + if Int.equal !occref 0 then tc + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) + | c -> map_glob_constr_left_to_right substrec c + in + substrec t + +open Tacmach + +let hResolve id c occ t = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in + let env = Termops.clear_named_body id (Proofview.Goal.env gl) in + let concl = Proofview.Goal.concl gl in + let env_ids = Termops.ids_of_context env in + let c_raw = Detyping.detype true env_ids env sigma c in + let t_raw = Detyping.detype true env_ids env sigma t in + let rec resolve_hole t_hole = + try + Pretyping.understand env sigma t_hole + with + | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> + let (e, info) = Errors.push e in + let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in + resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) + in + let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in + let sigma = Evd.merge_universe_context sigma ctx in + let t_constr_type = Retyping.get_type_of env sigma t_constr in + let tac = + (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + +let hResolve_auto id c t = + let rec resolve_auto n = + try + hResolve id c n t + with + | UserError _ as e -> raise e + | e when Errors.noncritical e -> resolve_auto (n+1) + in + resolve_auto 1 + +TACTIC EXTEND hresolve_core +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] +END + +(** + hget_evar +*) + +let hget_evar n = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let evl = evar_list concl in + if List.length evl < n then + error "Not enough uninstantiated existential variables."; + if n <= 0 then error "Incorrect existential variable index."; + let ev = List.nth evl (n-1) in + let ev_type = existential_type sigma ev in + change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) + end } + +TACTIC EXTEND hget_evar +| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] +END + +(**********************************************************************) + +(**********************************************************************) +(* A tactic that reduces one match t with ... by doing destruct t. *) +(* if t is not a variable, the tactic does *) +(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) +(* preserved). *) +(* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) +(**********************************************************************) + +exception Found of unit Proofview.tactic + +let rewrite_except h = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let hyps = Tacmach.New.pf_ids_of_hyps gl in + Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else + Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) + hyps + end } + + +let refl_equal = + let coq_base_constant s = + Coqlib.gen_constant_in_modules "RecursiveDefinition" + (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in + function () -> (coq_base_constant "eq_refl") + + +(* This is simply an implementation of the case_eq tactic. this code + should be replaced by a call to the tactic but I don't know how to + call it before it is defined. *) +let mkCaseEq a : unit Proofview.tactic = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in + Tacticals.New.tclTHENLIST + [Proofview.V82.tactic (Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + (** FIXME: this looks really wrong. Does anybody really use this tactic? *) + let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in + change_concl c + end }; + simplest_case a] + end } + + +let case_eq_intros_rewrite x = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let n = nb_prod (Proofview.Goal.concl gl) in + (* Pp.msgnl (Printer.pr_lconstr x); *) + Tacticals.New.tclTHENLIST [ + mkCaseEq x; + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let n' = nb_prod concl in + let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in + Tacticals.New.tclTHENLIST [ + Tacticals.New.tclDO (n'-n-1) intro; + introduction h; + rewrite_except h] + end } + ] + end } + +let rec find_a_destructable_match t = + let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in + let cl = [cl, (None, None), None], None in + let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in + match kind_of_term t with + | Case (_,_,x,_) when closed0 x -> + if isVar x then + (* TODO check there is no rel n. *) + raise (Found (Tacinterp.eval_tactic dest)) + else + (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) + raise (Found (case_eq_intros_rewrite x)) + | _ -> iter_constr find_a_destructable_match t + + +let destauto t = + try find_a_destructable_match t; + Tacticals.New.tclZEROMSG (str "No destructable match found") + with Found tac -> tac + +let destauto_in id = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in +(* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) +(* Pp.msgnl (Printer.pr_lconstr (ctype)); *) + destauto ctype + end } + +TACTIC EXTEND destauto +| [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] +| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] +END + + +(* ********************************************************************* *) + +let eq_constr x y = + Proofview.Goal.enter { enter = begin fun gl -> + let evd = Tacmach.New.project gl in + if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () + else Tacticals.New.tclFAIL 0 (str "Not equal") + end } + +TACTIC EXTEND constr_eq +| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] +END + +TACTIC EXTEND constr_eq_nounivs +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ + if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] +END + +TACTIC EXTEND is_evar +| [ "is_evar" constr(x) ] -> + [ match kind_of_term x with + | Evar _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") + ] +END + +let rec has_evar x = + match kind_of_term x with + | Evar _ -> true + | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> + false + | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> + has_evar t1 || has_evar t2 + | LetIn (_, t1, t2, t3) -> + has_evar t1 || has_evar t2 || has_evar t3 + | App (t1, ts) -> + has_evar t1 || has_evar_array ts + | Case (_, t1, t2, ts) -> + has_evar t1 || has_evar t2 || has_evar_array ts + | Fix ((_, tr)) | CoFix ((_, tr)) -> + has_evar_prec tr + | Proj (p, c) -> has_evar c +and has_evar_array x = + Array.exists has_evar x +and has_evar_prec (_, ts1, ts2) = + Array.exists has_evar ts1 || Array.exists has_evar ts2 + +TACTIC EXTEND has_evar +| [ "has_evar" constr(x) ] -> + [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ] +END + +TACTIC EXTEND is_hyp +| [ "is_var" constr(x) ] -> + [ match kind_of_term x with + | Var _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] +END + +TACTIC EXTEND is_fix +| [ "is_fix" constr(x) ] -> + [ match kind_of_term x with + | Fix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] +END;; + +TACTIC EXTEND is_cofix +| [ "is_cofix" constr(x) ] -> + [ match kind_of_term x with + | CoFix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] +END;; + +(* Command to grab the evars left unresolved at the end of a proof. *) +(* spiwack: I put it in extratactics because it is somewhat tied with + the semantics of the LCF-style tactics, hence with the classic tactic + mode. *) +VERNAC COMMAND EXTEND GrabEvars +[ "Grab" "Existential" "Variables" ] + => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] +END + +(* Shelves all the goals under focus. *) +TACTIC EXTEND shelve +| [ "shelve" ] -> + [ Proofview.shelve ] +END + +(* Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +TACTIC EXTEND shelve_unifiable +| [ "shelve_unifiable" ] -> + [ Proofview.shelve_unifiable ] +END + +(* Unshelves the goal shelved by the tactic. *) +TACTIC EXTEND unshelve +| [ "unshelve" tactic1(t) ] -> + [ + Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> + Proofview.Unsafe.tclGETGOALS >>= fun ogls -> + Proofview.Unsafe.tclSETGOALS (gls @ ogls) + ] +END + +(* Command to add every unshelved variables to the focus *) +VERNAC COMMAND EXTEND Unshelve +[ "Unshelve" ] + => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] +END + +(* Gives up on the goals under focus: the goals are considered solved, + but the proof cannot be closed until the user goes back and solve + these goals. *) +TACTIC EXTEND give_up +| [ "give_up" ] -> + [ Proofview.give_up ] +END + +(* cycles [n] goals *) +TACTIC EXTEND cycle +| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] +END + +(* swaps goals number [i] and [j] *) +TACTIC EXTEND swap +| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] +END + +(* reverses the list of focused goals *) +TACTIC EXTEND revgoals +| [ "revgoals" ] -> [ Proofview.revgoals ] +END + + +type cmp = + | Eq + | Lt | Le + | Gt | Ge + +type 'i test = + | Test of cmp * 'i * 'i + +let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 "cmp" +let wit_test : (int or_var test,int or_var test,int test) Genarg.genarg_type = + Genarg.make0 "tactest" + +let pr_cmp = function + | Eq -> Pp.str"=" + | Lt -> Pp.str"<" + | Le -> Pp.str"<=" + | Gt -> Pp.str">" + | Ge -> Pp.str">=" + +let pr_cmp' _prc _prlc _prt = pr_cmp + +let pr_test_gen f (Test(c,x,y)) = + Pp.(f x ++ pr_cmp c ++ f y) + +let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int) + +let pr_test' _prc _prlc _prt = pr_test + +let pr_itest = pr_test_gen Pp.int + +let pr_itest' _prc _prlc _prt = pr_itest + + + +ARGUMENT EXTEND comparison TYPED AS cmp PRINTED BY pr_cmp' +| [ "=" ] -> [ Eq ] +| [ "<" ] -> [ Lt ] +| [ "<=" ] -> [ Le ] +| [ ">" ] -> [ Gt ] +| [ ">=" ] -> [ Ge ] + END + +let interp_test ist gls = function + | Test (c,x,y) -> + project gls , + Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) + +ARGUMENT EXTEND test + PRINTED BY pr_itest' + INTERPRETED BY interp_test + RAW_TYPED AS test + RAW_PRINTED BY pr_test' + GLOB_TYPED AS test + GLOB_PRINTED BY pr_test' +| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] +END + +let interp_cmp = function + | Eq -> Int.equal + | Lt -> ((<):int->int->bool) + | Le -> ((<=):int->int->bool) + | Gt -> ((>):int->int->bool) + | Ge -> ((>=):int->int->bool) + +let run_test = function + | Test(c,x,y) -> interp_cmp c x y + +let guard tst = + if run_test tst then + Proofview.tclUNIT () + else + let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in + Tacticals.New.tclZEROMSG msg + + +TACTIC EXTEND guard +| [ "guard" test(tst) ] -> [ guard tst ] +END + +let decompose l c = + Proofview.Goal.enter { enter = begin fun gl -> + let to_ind c = + if isInd c then Univ.out_punivs (destInd c) + else error "not an inductive type" + in + let l = List.map to_ind l in + Elim.h_decompose l c + end } + +TACTIC EXTEND decompose +| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] +END + +(** library/keys *) + +VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ + let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in + let k1 = Keys.constr_key (it c) in + let k2 = Keys.constr_key (it c') in + match k1, k2 with + | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 + | _ -> () ] +END + +VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY +| [ "Print" "Equivalent" "Keys" ] -> [ msg_info (Keys.pr_keys Printer.pr_global) ] +END + + +VERNAC COMMAND EXTEND OptimizeProof +| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Proof_global.compact_the_proof () ] +| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Gc.compact () ] +END diff --git a/ltac/extratactics.mli b/ltac/extratactics.mli new file mode 100644 index 0000000000..18334dafe7 --- /dev/null +++ b/ltac/extratactics.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit Proofview.tactic +val injHyp : Names.Id.t -> unit Proofview.tactic + +(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) + +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 new file mode 100644 index 0000000000..788443944f --- /dev/null +++ b/ltac/g_auto.ml4 @@ -0,0 +1,211 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ Eauto.e_assumption ] +END + +TACTIC EXTEND eexact +| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND hintbases + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ "with" "*" ] -> [ None ] +| [ "with" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ Some [] ] +END + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + +let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) + +ARGUMENT EXTEND auto_using + TYPED AS uconstr_list + PRINTED BY pr_auto_using +| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] +| [ ] -> [ [] ] +END + +(** Auto *) + +TACTIC EXTEND trivial +| [ "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_trivial +| [ "info_trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_trivial +| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND auto +| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_auto +| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_auto +| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] +END + +(** Eauto *) + +TACTIC EXTEND prolog +| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> + [ Eauto.prolog_tac (eval_uconstrs ist l) n ] +END + +let make_depth n = snd (Eauto.make_dimension n None) + +TACTIC EXTEND eauto +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND new_eauto +| [ "new" "auto" int_or_var_opt(n) auto_using(lems) + hintbases(db) ] -> + [ match db with + | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] +END + +TACTIC EXTEND debug_eauto +| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_eauto +| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND dfs_eauto +| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND autounfold +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] +END + +TACTIC EXTEND autounfold_one +| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] +| [ "autounfold_one" hintbases(db) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + END + +TACTIC EXTEND autounfoldify +| [ "autounfoldify" constr(x) ] -> [ + let db = match Term.kind_of_term x with + | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) + | _ -> assert false + in Eauto.autounfold ["core";db] Locusops.onConcl + ] +END + +TACTIC EXTEND unify +| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ + let table = try Some (Hints.searchtable_map base) with Not_found -> None in + match table with + | None -> + let msg = str "Hint table " ++ str base ++ str " not found" in + Tacticals.New.tclZEROMSG msg + | Some t -> + let state = Hints.Hint_db.transparent_state t in + Tactics.unify ~state x y + ] +END + + +TACTIC EXTEND convert_concl_no_check +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +END + +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom + +ARGUMENT EXTEND hints_path_atom + TYPED AS hints_path_atom + PRINTED BY pr_hints_path_atom +| [ global_list(g) ] -> [ Hints.PathHints (List.map Nametab.global g) ] +| [ "*" ] -> [ Hints.PathAny ] +END + +let pr_hints_path prc prx pry c = Hints.pp_hints_path c + +ARGUMENT EXTEND hints_path + TYPED AS hints_path + PRINTED BY pr_hints_path +| [ "(" hints_path(p) ")" ] -> [ p ] +| [ "!" hints_path(p) ] -> [ Hints.PathStar p ] +| [ "emp" ] -> [ Hints.PathEmpty ] +| [ "eps" ] -> [ Hints.PathEpsilon ] +| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] +| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] +| [ hints_path(p) ";" hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND opthints + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ ":" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ None ] +END + +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ + let entry = Hints.HintsCutEntry p in + Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (match dbnames with None -> ["core"] | Some l -> l) entry ] +END diff --git a/ltac/g_class.ml4 b/ltac/g_class.ml4 new file mode 100644 index 0000000000..9ef1545416 --- /dev/null +++ b/ltac/g_class.ml4 @@ -0,0 +1,89 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ progress_evars (Tacinterp.tactic_of_value ist t) ] +END + +(** Options: depth, debug and transparency settings. *) + +let set_transparency cl b = + List.iter (fun r -> + let gr = Smartlocate.global_with_alias r in + let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in + Classes.set_typeclass_transparency ev false b) cl + +VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ + set_transparency cl true ] +END + +VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ + set_transparency cl false ] +END + +open Genarg + +let pr_debug _prc _prlc _prt b = + if b then Pp.str "debug" else Pp.mt() + +ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug +| [ "debug" ] -> [ true ] +| [ ] -> [ false ] +END + +let pr_depth _prc _prlc _prt = function + Some i -> Pp.int i + | None -> Pp.mt() + +ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth +| [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ] +END + +(* true = All transparent, false = Opaque if possible *) + +VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF + | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [ + set_typeclasses_debug d; + set_typeclasses_depth depth + ] +END + +TACTIC EXTEND typeclasses_eauto +| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ Proofview.V82.tactic (typeclasses_eauto l) ] +| [ "typeclasses" "eauto" ] -> [ Proofview.V82.tactic (typeclasses_eauto ~only_classes:true [Hints.typeclasses_db]) ] +END + +TACTIC EXTEND head_of_constr + [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] +END + +TACTIC EXTEND not_evar + [ "not_evar" constr(ty) ] -> [ not_evar ty ] +END + +TACTIC EXTEND is_ground + [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ] +END + +TACTIC EXTEND autoapply + [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ] +END diff --git a/ltac/g_eqdecide.ml4 b/ltac/g_eqdecide.ml4 new file mode 100644 index 0000000000..905653281c --- /dev/null +++ b/ltac/g_eqdecide.ml4 @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ decideEqualityGoal ] +END + +TACTIC EXTEND compare +| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] +END diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 new file mode 100644 index 0000000000..b55ac9ad06 --- /dev/null +++ b/ltac/g_ltac.ml4 @@ -0,0 +1,430 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a + | e -> Tacexp (e:raw_tactic_expr) + +let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () +let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n +let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c + +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + Errors.user_err_loc (loc, "", + str "This expression should be a simple identifier.") + +let tactic_mode = Gram.entry_create "vernac:tactic_command" + +let new_entry name = + let e = Gram.entry_create name in + let entry = Entry.create name in + let () = Pcoq.set_grammar entry e in + e + +let selector = new_entry "vernac:selector" +let tacdef_body = new_entry "tactic:tacdef_body" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> set_command_entry tactic_mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Gram.Entry.of_parser "test_bracket_ident" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "[" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* Tactics grammar rules *) + +GEXTEND Gram + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg + tactic_mode constr_may_eval constr_eval selector; + + tactic_then_last: + [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> + Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) + | -> [||] + ] ] + ; + tactic_then_gen: + [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) + | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) + | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) + | ta = tactic_expr -> ([ta], None) + | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) + | -> ([TacId []], None) + ] ] + ; + tactic_then_locality: (* [true] for the local variant [TacThens] and [false] + for [TacExtend] *) + [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] + ; + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> te ] + | "4" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) + | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> + match l , tail with + | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | false , None -> TacThen (ta0,TacDispatch first) + | true , None -> TacThens (ta0,first) ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> TacTry ta + | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) + | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) + | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) + | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta + | IDENT "progress"; ta = tactic_expr -> TacProgress ta + | IDENT "once"; ta = tactic_expr -> TacOnce ta + | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta + | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> + TacAbstract (tc,Some s) ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) + | IDENT "tryif" ; ta = tactic_expr ; + "then" ; tat = tactic_expr ; + "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) + | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] + | "1" RIGHTA + [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + TacMatchGoal (b,false,mrl) + | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + TacMatchGoal (b,true,mrl) + | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + TacMatch (b,c,mrl) + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacFirst l + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacSolve l + | IDENT "idtac"; l = LIST0 message_token -> TacId l + | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; + l = LIST0 message_token -> TacFail (g,n,l) + | st = simple_tactic -> st + | a = tactic_arg -> TacArg(!@loc,a) + | r = reference; la = LIST0 tactic_arg_compat -> + TacArg(!@loc,TacCall (!@loc,r,la)) ] + | "0" + [ "("; a = tactic_expr; ")" -> a + | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> + begin match tail with + | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) + | None -> TacDispatch tf + end + | a = tactic_atom -> TacArg (!@loc,a) ] ] + ; + failkw: + [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] + ; + (* binder_tactic: level 5 of tactic_expr *) + binder_tactic: + [ RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + TacFun (it,body) + | "let"; isrec = [IDENT "rec" -> true | -> false]; + llc = LIST1 let_clause SEP "with"; "in"; + body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) + | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] + ; + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> a + | r = reference -> Reference r + | c = Constr.constr -> ConstrMayEval (ConstrTerm c) + (* Unambigous entries: tolerated w/o "ltac:" modifier *) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + (* Can be used as argument and at toplevel in tactic expressions. *) + tactic_arg: + [ [ c = constr_eval -> ConstrMayEval c + | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l + | IDENT "type_term"; c=uconstr -> TacPretype c + | IDENT "numgoals" -> TacNumgoals ] ] + ; + (* If a qualid is given, use its short name. TODO: have the shortest + non ambiguous name where dots are replaced by "_"? Probably too + verbose most of the time. *) + fresh_id: + [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) + | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] + ; + constr_eval: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrEval (rtc,c) + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + ConstrContext (id,c) + | IDENT "type"; IDENT "of"; c = Constr.constr -> + ConstrTypeOf c ] ] + ; + constr_may_eval: (* For extensions *) + [ [ c = constr_eval -> c + | c = Constr.constr -> ConstrTerm c ] ] + ; + tactic_atom: + [ [ n = integer -> TacGeneric (genarg_of_int n) + | r = reference -> TacCall (!@loc,r,[]) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + match_key: + [ [ "match" -> Once + | "lazymatch" -> Select + | "multimatch" -> General ] ] + ; + input_fun: + [ [ "_" -> None + | l = ident -> Some l ] ] + ; + let_clause: + [ [ id = identref; ":="; te = tactic_expr -> + (id, arg_of_expr te) + | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + (id, arg_of_expr (TacFun(args,te))) ] ] + ; + match_pattern: + [ [ IDENT "context"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + let mode = not (!Flags.tactic_context_compat) in + Subterm (mode, oid, pc) + | IDENT "appcontext"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + msg_warning (strbrk "appcontext is deprecated"); + Subterm (true,oid, pc) + | pc = Constr.lconstr_pattern -> Term pc ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) + | na = name; ":="; mpv = match_pattern -> + let t, ty = + match mpv with + | Term t -> (match t with + | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) + ] ] + ; + match_context_rule: + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] + ; + message_token: + [ [ id = identref -> MsgIdent id + | s = STRING -> MsgString s + | n = integer -> MsgInt n ] ] + ; + + ltac_def_kind: + [ [ ":=" -> false + | "::=" -> true ] ] + ; + + (* Definitions for tactics *) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, body) + ] ] + ; + tactic: + [ [ tac = tactic_expr -> tac ] ] + ; + selector: + [ [ n=natural; ":" -> Vernacexpr.SelectNth n + | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id + | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] + ; + tactic_mode: + [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] + ; + END + +open Stdarg +open Constrarg +open Vernacexpr +open Vernac_classifier +open Goptions +open Libnames + +let print_info_trace = ref None + +let _ = declare_int_option { + optsync = true; + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Pp.feedback Feedback.AddedAxiom + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ selector(s) ] -> [ s ] +END + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info +| [ "Info" natural(n) ] -> [ n ] +END + +let pr_ltac_use_default b = if b then str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +VERNAC tactic_mode EXTEND VernacSolve +| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ classify_as_proofstep ] -> [ + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + vernac_solve g n t def + ] +| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ VtProofStep true, VtLater ] -> [ + vernac_solve SelectAll n t def + ] +END + +let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level +| [ "(" "at" "level" natural(n) ")" ] -> [ n ] +END + +VERNAC ARGUMENT EXTEND ltac_production_sep +| [ "," string(sep) ] -> [ sep ] +END + +let pr_ltac_production_item = function +| TacTerm s -> quote (str s) +| TacNonTerm (_, arg, (id, sep)) -> + let sep = match sep with + | "" -> mt () + | sep -> str "," ++ spc () ++ quote (str sep) + in + str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item +| [ string(s) ] -> [ TacTerm s ] +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + [ TacNonTerm (loc, Names.Id.to_string nt, (p, Option.default "" sep)) ] +END + +VERNAC COMMAND EXTEND VernacTacticNotation +| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => + [ VtUnknown, VtNow ] -> + [ + let l = Locality.LocalityFixme.consume () in + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality l, n, r, e) + ] +END + +VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY +| [ "Print" "Ltac" reference(r) ] -> + [ msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] +END + +VERNAC ARGUMENT EXTEND ltac_tacdef_body +| [ tacdef_body(t) ] -> [ t ] +END + +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ + VtSideff (List.map (function + | TacticDefinition ((_,r),_) -> r + | TacticRedefinition (Ident (_,r),_) -> r + | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater + ] -> [ + let lc = Locality.LocalityFixme.consume () in + Tacentries.register_ltac (Locality.make_module_locality lc) l + ] +END diff --git a/ltac/g_obligations.ml4 b/ltac/g_obligations.ml4 new file mode 100644 index 0000000000..4cd8bf1feb --- /dev/null +++ b/ltac/g_obligations.ml4 @@ -0,0 +1,147 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + snd (get_default_tactic ()) + end in + Obligations.default_tactic := tac + +(* We define new entries for programs, with the use of this module + * Subtac. These entries are named Subtac. + *) + +module Gram = Pcoq.Gram +module Tactic = Pcoq.Tactic + +open Pcoq + +let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type + +let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = + Genarg.create_arg "withtac" + +let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) + +GEXTEND Gram + GLOBAL: withtac; + + withtac: + [ [ "with"; t = Tactic.tactic -> Some t + | -> None ] ] + ; + + Constr.closed_binder: + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [LocalRawAssum ([id], default_binder_kind, typ)] + ] ]; + + END + +open Obligations + +let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, Some name, Some t) tac ] +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> + [ obligation (num, Some name, None) tac ] +| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, None, Some t) tac ] +| [ "Obligation" integer(num) withtac(tac) ] -> + [ obligation (num, None, None) tac ] +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> + [ next_obligation (Some name) tac ] +| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] +END + +VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF +| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> + [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] +END + +VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" "with" tactic(t) ] -> + [ try_solve_obligations None (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" ] -> + [ try_solve_obligations None None ] +END + +VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> + [ solve_all_obligations (Some (Tacinterp.interp t)) ] +| [ "Solve" "All" "Obligations" ] -> + [ solve_all_obligations None ] +END + +VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +END + +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ + set_default_tactic + (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (Tacintern.glob_tactic t) ] +END + +open Pp + +VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY +| [ "Show" "Obligation" "Tactic" ] -> [ + msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +END + +VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY +| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] +| [ "Obligations" ] -> [ show_obligations None ] +END + +VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY +| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ msg_info (show_term None) ] +END + +open Pp + +(* Declare a printer for the content of Program tactics *) +let () = + let printer _ _ _ = function + | None -> mt () + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + in + (* should not happen *) + let dummy _ _ _ expr = assert false in + Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 new file mode 100644 index 0000000000..c4ef1f297e --- /dev/null +++ b/ltac/g_rewrite.ml4 @@ -0,0 +1,272 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* [ bl ] +END + +type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast + +let interp_strategy ist gl s = + let sigma = project gl in + sigma, strategy_of_ast s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s +let subst_strategy s str = str + +let pr_strategy _ _ _ (s : strategy) = Pp.str "" +let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "" +let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "" + +ARGUMENT EXTEND rewstrategy + PRINTED BY pr_strategy + + INTERPRETED BY interp_strategy + GLOBALIZED BY glob_strategy + SUBSTITUTED BY subst_strategy + + RAW_TYPED AS raw_strategy + RAW_PRINTED BY pr_raw_strategy + + GLOB_TYPED AS glob_strategy + GLOB_PRINTED BY pr_glob_strategy + + [ glob(c) ] -> [ StratConstr (c, true) ] + | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] + | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] + | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] + | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] + | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] + | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] + | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] + | [ "id" ] -> [ StratId ] + | [ "fail" ] -> [ StratFail ] + | [ "refl" ] -> [ StratRefl ] + | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] + | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] + | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] + | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] + | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] + | [ "(" rewstrategy(h) ")" ] -> [ h ] + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] + | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] + | [ "hints" preident(h) ] -> [ StratHints (false, h) ] + | [ "terms" constr_list(h) ] -> [ StratTerms h ] + | [ "eval" red_expr(r) ] -> [ StratEval r ] + | [ "fold" constr(c) ] -> [ StratFold c ] +END + +(* By default the strategy for "rewrite_db" is top-down *) + +let db_strat db = StratUnary (Topdown, StratHints (false, db)) +let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) + +let cl_rewrite_clause_db = + if Flags.profile then + let key = Profile.declare_profile "cl_rewrite_clause_db" in + Profile.profile3 key cl_rewrite_clause_db + else cl_rewrite_clause_db + +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ] +| [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ] +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db (Some id)) ] +| [ "rewrite_db" preident(db) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db None) ] +END + +let clsubstitute o c = + let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in + Tacticals.onAllHypsAndConcl + (fun cl -> + match cl with + | Some id when is_tac id -> tclIDTAC + | _ -> cl_rewrite_clause c o AllOccurrences cl) + +TACTIC EXTEND substitute +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ] +END + + +(* Compatibility with old Setoids *) + +TACTIC EXTEND setoid_rewrite + [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] + -> [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences None) ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences (Some id))] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) None)] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> + [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] +END + +VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] + + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None None ] + | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) None ] + | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n None None (Some lemma3) ] +END + +type binders_argtype = local_binder list + +let wit_binders = + (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) + +let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) + +open Pcoq + +GEXTEND Gram + GLOBAL: binders; + binders: + [ [ b = Pcoq.Constr.binders -> b ] ]; +END + +VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF + [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] + | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] + | [ "Add" "Morphism" constr(m) ":" ident(n) ] + (* This command may or may not open a goal *) + => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] + -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] + | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] + | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] +END + +TACTIC EXTEND setoid_symmetry + [ "setoid_symmetry" ] -> [ setoid_symmetry ] + | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] +END + +TACTIC EXTEND setoid_reflexivity +[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +END + +TACTIC EXTEND setoid_transitivity + [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] +| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] +END + +VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY + [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Pp.msg_notice (Autorewrite.print_rewrite_hintdb s) ] +END diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib new file mode 100644 index 0000000000..7987d774d1 --- /dev/null +++ b/ltac/ltac.mllib @@ -0,0 +1,23 @@ +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Autorewrite +Extratactics +Eauto +G_auto +Class_tactics +G_class +Rewrite +G_rewrite +Tauto +Eqdecide +G_eqdecide +G_ltac diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml new file mode 100644 index 0000000000..fb04bee070 --- /dev/null +++ b/ltac/rewrite.ml @@ -0,0 +1,2184 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") + +let find_reference dir s = + let gr = lazy (try_find_global_reference dir s) in + fun () -> Lazy.force gr + +type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) + +let find_global dir s = + let gr = lazy (try_find_global_reference dir s) in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + +(** Utility for dealing with polymorphic applications *) + +(** Global constants. *) + +let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" +let coq_eq = find_global ["Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" +let coq_all = find_global ["Init"; "Logic"] "all" +let impl = find_global ["Program"; "Basics"] "impl" + +(** Bookkeeping which evars are constraints so that we can + remove them at the end of the tactic. *) + +let goalevars evars = fst evars +let cstrevars evars = snd evars + +let new_cstr_evar (evd,cstrs) env t = + let s = Typeclasses.set_resolvable Evd.Store.empty false in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in + let evd' = Sigma.to_evar_map evd' in + let ev, _ = destEvar t in + (evd', Evar.Set.add ev cstrs), t + +(** Building or looking up instances. *) +let e_new_cstr_evar env evars t = + let evd', t = new_cstr_evar !evars env t in evars := evd'; t + +(** Building or looking up instances. *) + +let extends_undefined evars evars' = + let f ev evi found = found || not (Evd.mem evars ev) + in fold_undefined f evars' false + +let app_poly_check env evars f args = + let (evars, cstrs), fc = f evars in + let evdref = ref evars in + let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in + (!evdref, cstrs), t + +let app_poly_nocheck env evars f args = + let evars, fc = f evars in + evars, mkApp (fc, args) + +let app_poly_sort b = + if b then app_poly_nocheck + else app_poly_check + +let find_class_proof proof_type proof_method env evars carrier relation = + try + let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in + let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in + if extends_undefined (goalevars evars) evars' then raise Not_found + else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |] + with e when Logic.catchable_exception e -> raise Not_found + +(** Utility functions *) + +module GlobalBindings (M : sig + val relation_classes : string list + val morphisms : string list + val relation : string list * string + val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr + val arrow : evars -> evars * constr +end) = struct + open M + open Context.Rel.Declaration + let relation : evars -> evars * constr = find_global (fst relation) (snd relation) + + let reflexive_type = find_global relation_classes "Reflexive" + let reflexive_proof = find_global relation_classes "reflexivity" + + let symmetric_type = find_global relation_classes "Symmetric" + let symmetric_proof = find_global relation_classes "symmetry" + + let transitive_type = find_global relation_classes "Transitive" + let transitive_proof = find_global relation_classes "transitivity" + + let forall_relation = find_global morphisms "forall_relation" + let pointwise_relation = find_global morphisms "pointwise_relation" + + let forall_relation_ref = find_reference morphisms "forall_relation" + let pointwise_relation_ref = find_reference morphisms "pointwise_relation" + + let respectful = find_global morphisms "respectful" + let respectful_ref = find_reference morphisms "respectful" + + let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + + let coq_forall = find_global morphisms "forall_def" + + let subrelation = find_global relation_classes "subrelation" + let do_subrelation = find_global morphisms "do_subrelation" + let apply_subrelation = find_global morphisms "apply_subrelation" + + let rewrite_relation_class = find_global relation_classes "RewriteRelation" + + let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) + let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) + + let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) + + let proper_type = + let l = lazy (Lazy.force proper_class).cl_impl in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + + let proper_proxy_type = + let l = lazy (Lazy.force proper_proxy_class).cl_impl in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + + let proper_proof env evars carrier relation x = + let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in + new_cstr_evar evars env goal + + let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env + let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env + let get_transitive_proof env = find_class_proof transitive_type transitive_proof env + + let mk_relation env evd a = + app_poly env evd relation [| a |] + + (** Build an infered signature from constraints on the arguments and expected output + relation *) + + let build_signature evars env m (cstrs : (types * types option) option list) + (finalcstr : (types * types option) option) = + let mk_relty evars newenv ty obj = + match obj with + | None | Some (_, None) -> + let evars, relty = mk_relation env evars ty in + if closed0 ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_cstr_evar evars env' relty + else new_cstr_evar evars newenv relty + | Some (x, Some rel) -> evars, rel + in + let rec aux env evars ty l = + let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in + match kind_of_term t, l with + | Prod (na, ty, b), obj :: cstrs -> + let b = Reductionops.nf_betaiota (goalevars evars) b in + if noccurn 1 b (* non-dependent product *) then + let ty = Reductionops.nf_betaiota (goalevars evars) ty in + let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in + let evars, relty = mk_relty evars env ty obj in + let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in + evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs + else + let (evars, b, arg, cstrs) = + aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs + in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in + if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs + else error "build_signature: no constraint can apply on a dependent argument" + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") + | _, [] -> + (match finalcstr with + | None | Some (_, None) -> + let t = Reductionops.nf_betaiota (fst evars) ty in + let evars, rel = mk_relty evars env t None in + evars, t, rel, [t, Some rel] + | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) + in aux env evars m cstrs + + (** Folding/unfolding of the tactic constants. *) + + let unfold_impl t = + match kind_of_term t with + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + mkProd (Anonymous, a, lift 1 b) + | _ -> assert false + + let unfold_all t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let unfold_forall t = + match kind_of_term t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match kind_of_term b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let arrow_morphism env evd ta tb a b = + let ap = is_Prop ta and bp = is_Prop tb in + if ap && bp then app_poly env evd impl [| a; b |], unfold_impl + else if ap then (* Domain in Prop, CoDomain in Type *) + (app_poly env evd arrow [| a; b |]), unfold_impl + (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) + else if bp then (* Dummy forall *) + (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall + else (* None in Prop, use arrow *) + (app_poly env evd arrow [| a; b |]), unfold_impl + + let rec decomp_pointwise n c = + if Int.equal n 0 then c + else + match kind_of_term c with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + decomp_pointwise (pred n) relb + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) + | _ -> invalid_arg "decomp_pointwise" + + let rec apply_pointwise rel = function + | arg :: args -> + (match kind_of_term rel with + | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> + apply_pointwise relb args + | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> + apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args + | _ -> invalid_arg "apply_pointwise") + | [] -> rel + + let pointwise_or_dep_relation env evd n t car rel = + if noccurn 1 car && noccurn 1 rel then + app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] + else + app_poly env evd forall_relation + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + + let lift_cstr env evars (args : constr list) c ty cstr = + let start evars env car = + match cstr with + | None | Some (_, None) -> + let evars, rel = mk_relation env evars car in + new_cstr_evar evars env rel + | Some (ty, Some rel) -> evars, rel + in + let rec aux evars env prod n = + if Int.equal n 0 then start evars env prod + else + match kind_of_term (Reduction.whd_betadeltaiota env prod) with + | Prod (na, ty, b) -> + if noccurn 1 b then + let b' = lift (-1) b in + let evars, rb = aux evars env b' (pred n) in + app_poly env evars pointwise_relation [| ty; b'; rb |] + else + let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in + app_poly env evars forall_relation + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + | _ -> raise Not_found + in + let rec find env c ty = function + | [] -> None + | arg :: args -> + try let evars, found = aux evars env ty (succ (List.length args)) in + Some (evars, found, c, ty, arg :: args) + with Not_found -> + let ty = whd_betadeltaiota env ty in + find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args + in find env c ty args + + let unlift_cstr env sigma = function + | None -> None + | Some codom -> Some (decomp_pointwise 1 codom) + + (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) + let is_applied_rewrite_relation env sigma rels t = + match kind_of_term t with + | App (c, args) when Array.length args >= 2 -> + let head = if isApp c then fst (destApp c) else c in + if Globnames.is_global (coq_eq_ref ()) head then None + else + (try + let params, args = Array.chop (Array.length args - 2) args in + let env' = Environ.push_rel_context rels env in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let evars = Sigma.to_evar_map sigma in + let evars, inst = + app_poly env (evars,Evar.Set.empty) + rewrite_relation_class [| evar; mkApp (c, params) |] in + let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in + Some (it_mkProd_or_LetIn t rels) + with e when Errors.noncritical e -> None) + | _ -> None + + +end + +(* let my_type_of env evars c = Typing.e_type_of env evars c *) +(* let mytypeofkey = Profile.declare_profile "my_type_of";; *) +(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) + + +let type_app_poly env env evd f args = + let evars, c = app_poly_nocheck env evd f args in + let evd', t = Typing.type_of env (goalevars evars) c in + (evd', cstrevars evars), c + +module PropGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "RelationClasses"] + let morphisms = ["Classes"; "Morphisms"] + let relation = ["Relations";"Relation_Definitions"], "relation" + let app_poly = app_poly_nocheck + let arrow = find_global ["Program"; "Basics"] "arrow" + let coq_inverse = find_global ["Program"; "Basics"] "flip" + end + + module G = GlobalBindings(Consts) + + include G + include Consts + let inverse env evd car rel = + type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |] + (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *) + +end + +module TypeGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "CRelationClasses"] + let morphisms = ["Classes"; "CMorphisms"] + let relation = relation_classes, "crelation" + let app_poly = app_poly_check + let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" + let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" + end + + module G = GlobalBindings(Consts) + include G + include Consts + + + let inverse env (evd,cstrs) car rel = + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in + let evd = Sigma.to_evar_map sigma in + app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] + +end + +let sort_of_rel env evm rel = + Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) + +let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation + +(* let _ = *) +(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) + +let split_head = function + hd :: tl -> hd, tl + | [] -> assert(false) + +let evd_convertible env evd x y = + try + let evd = Evarconv.the_conv_x env x y evd in + (* Unfortunately, the_conv_x might say they are unifiable even if some + unsolvable constraints remain, so we check them here *) + let evd = Evarconv.consider_remaining_unif_problems env evd in + let () = Evarconv.check_problems_are_solved env evd in + Some evd + with e when Errors.noncritical e -> None + +let convertible env evd x y = + Reductionops.is_conv_leq env evd x y + +type hypinfo = { + prf : constr; + car : constr; + rel : constr; + sort : bool; (* true = Prop; false = Type *) + c1 : constr; + c2 : constr; + holes : Clenv.hole list; +} + +let get_symmetric_proof b = + if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof + +let error_no_relation () = error "Cannot find a relation to rewrite." + +let rec decompose_app_rel env evd t = + (** Head normalize for compatibility with the old meta mechanism *) + let t = Reductionops.whd_betaiota evd t in + match kind_of_term t with + | App (f, [||]) -> assert false + | App (f, [|arg|]) -> + let (f', argl, argr) = decompose_app_rel env evd arg in + let ty = Typing.unsafe_type_of env evd argl in + let f'' = mkLambda (Name default_dependent_ident, ty, + mkLambda (Name (Id.of_string "y"), lift 1 ty, + mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) + in (f'', argl, argr) + | App (f, args) -> + let len = Array.length args in + let fargs = Array.sub args 0 (Array.length args - 2) in + let rel = mkApp (f, fargs) in + rel, args.(len - 2), args.(len - 1) + | _ -> error_no_relation () + +let decompose_app_rel env evd t = + let (rel, t1, t2) = decompose_app_rel env evd t in + let ty = Retyping.get_type_of env evd rel in + let () = if not (Reduction.is_arity env ty) then error_no_relation () in + (rel, t1, t2) + +let decompose_applied_relation env sigma (c,l) = + let open Context.Rel.Declaration in + let ctype = Retyping.get_type_of env sigma c in + let find_rel ty = + let sigma, cl = Clenv.make_evar_clause env sigma ty in + let sigma = Clenv.solve_evar_clause env sigma true cl l in + let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in + let (equiv, c1, c2) = decompose_app_rel env sigma t in + let ty1 = Retyping.get_type_of env sigma c1 in + let ty2 = Retyping.get_type_of env sigma c2 in + match evd_convertible env sigma ty1 ty2 with + | None -> None + | Some sigma -> + let sort = sort_of_rel env sigma equiv in + let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in + let value = mkApp (c, args) in + Some (sigma, { prf=value; + car=ty1; rel = equiv; sort = Sorts.is_prop sort; + c1=c1; c2=c2; holes }) + in + match find_rel ctype with + | Some c -> c + | None -> + let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with + | Some c -> c + | None -> error "Cannot find an homogeneous relation to rewrite." + +let rewrite_db = "rewrite" + +let conv_transparent_state = (Id.Pred.empty, Cpred.full) + +let _ = + Hints.add_hints_init + (fun () -> + Hints.create_hint_db false rewrite_db conv_transparent_state true) + +let rewrite_transparent_state () = + Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) + +let rewrite_core_unif_flags = { + Unification.modulo_conv_on_closed_terms = None; + Unification.use_metas_eagerly_in_conv_on_closed_terms = true; + Unification.use_evars_eagerly_in_conv_on_closed_terms = true; + Unification.modulo_delta = empty_transparent_state; + Unification.modulo_delta_types = full_transparent_state; + Unification.check_applied_meta_types = true; + Unification.use_pattern_unification = true; + Unification.use_meta_bound_pattern_unification = true; + Unification.frozen_evars = Evar.Set.empty; + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = false; + Unification.modulo_eta = true; +} + +(* Flags used for the setoid variant of "rewrite" and for the strategies + "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing + evars in "rewrite" (see unify_abs) *) +let rewrite_unif_flags = + let flags = rewrite_core_unif_flags in { + Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +let rewrite_core_conv_unif_flags = { + rewrite_core_unif_flags with + Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; + Unification.modulo_delta_types = conv_transparent_state; + Unification.modulo_betaiota = true +} + +(* Fallback flags for the setoid variant of "rewrite" *) +let rewrite_conv_unif_flags = + let flags = rewrite_core_conv_unif_flags in { + Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *) +let general_rewrite_unif_flags () = + let ts = rewrite_transparent_state () in + let core_flags = + { rewrite_core_unif_flags with + Unification.modulo_conv_on_closed_terms = Some ts; + Unification.use_evars_eagerly_in_conv_on_closed_terms = false; + Unification.modulo_delta = ts; + Unification.modulo_delta_types = ts; + Unification.modulo_betaiota = true } + in { + Unification.core_unify_flags = core_flags; + Unification.merge_unify_flags = core_flags; + Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +let refresh_hypinfo env sigma (is, cb) = + let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in + let sigma, hypinfo = decompose_applied_relation env sigma cbl in + let { c1; c2; car; rel; prf; sort; holes } = hypinfo in + sigma, (car, rel, prf, c1, c2, holes, sort) + +(** FIXME: write this in the new monad interface *) +let solve_remaining_by env sigma holes by = + match by with + | None -> sigma + | Some tac -> + let map h = + if h.Clenv.hole_deps then None + else + let (evk, _) = destEvar (h.Clenv.hole_evar) in + Some evk + in + (** Only solve independent holes *) + let indep = List.map_filter map holes in + let solve_tac = Tacticals.New.tclCOMPLETE (Tacinterp.eval_tactic tac) in + let solve sigma evk = + let evi = + try Some (Evd.find_undefined sigma evk) + with Not_found -> None + in + match evi with + | None -> sigma + (** Evar should not be defined, but just in case *) + | Some evi -> + let env = Environ.reset_with_named_context evi.evar_hyps env in + let ty = evi.evar_concl in + let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in + Evd.define evk c sigma + in + List.fold_left solve sigma indep + +let no_constraints cstrs = + fun ev _ -> not (Evar.Set.mem ev cstrs) + +let all_constraints cstrs = + fun ev _ -> Evar.Set.mem ev cstrs + +let poly_inverse sort = + if sort then PropGlobal.inverse else TypeGlobal.inverse + +type rewrite_proof = + | RewPrf of constr * constr + (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) + | RewCast of cast_kind + (** A proof of convertibility (with casts) *) + +type rewrite_result_info = { + rew_car : constr ; + (** A type *) + rew_from : constr ; + (** A term of type rew_car *) + rew_to : constr ; + (** A term of type rew_car *) + rew_prf : rewrite_proof ; + (** A proof of rew_from == rew_to *) + rew_evars : evars; +} + +type rewrite_result = +| Fail +| Identity +| Success of rewrite_result_info + +type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) + env : Environ.env ; + unfresh : Id.t list ; (* Unfresh names *) + term1 : constr ; + ty1 : types ; (* first term and its type (convertible to rew_from) *) + cstr : (bool (* prop *) * constr option) ; + evars : evars } + +type 'a pure_strategy = { strategy : + 'a strategy_input -> + 'a * rewrite_result (* the updated state and the "result" *) } + +type strategy = unit pure_strategy + +let symmetry env sort rew = + let { rew_evars = evars; rew_car = car; } = rew in + let (rew_evars, rew_prf) = match rew.rew_prf with + | RewCast _ -> (rew.rew_evars, rew.rew_prf) + | RewPrf (rel, prf) -> + try + let evars, symprf = get_symmetric_proof sort env evars car rel in + let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in + (evars, RewPrf (rel, prf)) + with Not_found -> + let evars, rel = poly_inverse sort env evars car rel in + (evars, RewPrf (rel, prf)) + in + { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; } + +(* Matching/unifying the rewriting rule against [t] *) +let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t = + try + let left = if l2r then c1 else c2 in + let sigma = Unification.w_unify ~flags env sigma CONV left t in + let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) + ~fail:true env sigma in + let evd = solve_remaining_by env sigma holes by in + let nf c = Evarutil.nf_evar evd (Reductionops.nf_meta evd c) in + let c1 = nf c1 and c2 = nf c2 + and rew_car = nf car and rel = nf rel + and prf = nf prf in + let ty1 = Retyping.get_type_of env evd c1 in + let ty2 = Retyping.get_type_of env evd c2 in + let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in + let rew_evars = evd, cstrs in + let rew_prf = RewPrf (rel, prf) in + let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in + let rew = if l2r then rew else symmetry env sort rew in + Some rew + with + | e when Class_tactics.catchable e -> None + | Reduction.NotConvertible -> None + +let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = + try + let left = if l2r then c1 else c2 in + (* The pattern is already instantiated, so the next w_unify is + basically an eq_constr, except when preexisting evars occur in + either the lemma or the goal, in which case the eq_constr also + solved this evars *) + let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in + let rew_evars = sigma, cstrs in + let rew_prf = RewPrf (rel, prf) in + let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in + let rew = if l2r then rew else symmetry env sort rew in + Some rew + with + | e when Class_tactics.catchable e -> None + | Reduction.NotConvertible -> None + +type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } + +let default_flags = { under_lambdas = true; on_morphisms = true; } + +let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None + +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +let make_eq_refl () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + +let get_rew_prf r = match r.rew_prf with + | RewPrf (rel, prf) -> rel, prf + | RewCast c -> + let rel = mkApp (make_eq (), [| r.rew_car |]) in + rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), + c, mkApp (rel, [| r.rew_from; r.rew_to |])) + +let poly_subrelation sort = + if sort then PropGlobal.subrelation else TypeGlobal.subrelation + +let resolve_subrelation env avoid car rel sort prf rel' res = + if eq_constr rel rel' then res + else + let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in + let evars, subrel = new_cstr_evar evars env app in + let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in + { res with + rew_prf = RewPrf (rel', appsub); + rew_evars = evars } + +let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = + let evars, morph_instance, proj, sigargs, m', args, args' = + let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with + | Some i -> i + | None -> invalid_arg "resolve_morphism" in + let morphargs, morphobjs = Array.chop first args in + let morphargs', morphobjs' = Array.chop first args' in + let appm = mkApp(m, morphargs) in + let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in + let cstrs = List.map + (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) + (Array.to_list morphobjs') + in + (* Desired signature *) + let evars, appmtype', signature, sigargs = + if b then PropGlobal.build_signature evars env appmtype cstrs cstr + else TypeGlobal.build_signature evars env appmtype cstrs cstr + in + (* Actual signature found *) + let cl_args = [| appmtype' ; signature ; appm |] in + let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + cl_args in + let env' = + let dosub, appsub = + if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation + else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation + in + Environ.push_named + (LocalDef (Id.of_string "do_subrelation", + snd (app_poly_sort b env evars dosub [||]), + snd (app_poly_nocheck env evars appsub [||]))) + env + in + let evars, morph = new_cstr_evar evars env' app in + evars, morph, morph, sigargs, appm, morphobjs, morphobjs' + in + let projargs, subst, evars, respars, typeargs = + Array.fold_left2 + (fun (acc, subst, evars, sigargs, typeargs') x y -> + let (carrier, relation), sigargs = split_head sigargs in + match relation with + | Some relation -> + let carrier = substl subst carrier + and relation = substl subst relation in + (match y with + | None -> + let evars, proof = + (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) + env evars carrier relation x in + [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' + | Some r -> + [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + sigargs, r.rew_to :: typeargs') + | None -> + if not (Option.is_empty y) then + error "Cannot rewrite inside dependent arguments of a function"; + x :: acc, x :: subst, evars, sigargs, x :: typeargs') + ([], [], evars, sigargs, []) args args' + in + let proof = applistc proj (List.rev projargs) in + let newt = applistc m' (List.rev typeargs) in + match respars with + [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt + | _ -> assert(false) + +let apply_constraint env avoid car rel prf cstr res = + match snd cstr with + | None -> res + | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res + +let coerce env avoid cstr res = + let rel, prf = get_rew_prf res in + apply_constraint env avoid res.rew_car rel prf cstr res + +let apply_rule unify loccs : int pure_strategy = + let (nowhere_except_in,occs) = convert_occs loccs in + let is_occ occ = + if nowhere_except_in + then List.mem occ occs + else not (List.mem occ occs) + in + { strategy = fun { state = occ ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr ; evars } -> + let unif = if isEvar t then None else unify env evars t in + match unif with + | None -> (occ, Fail) + | Some rew -> + let occ = succ occ in + if not (is_occ occ) then (occ, Fail) + else if eq_constr t rew.rew_to then (occ, Identity) + else + let res = { rew with rew_car = ty } in + let rel, prf = get_rew_prf res in + let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in + (occ, res) + } + +let apply_lemma l2r flags oc by loccs : strategy = { strategy = + fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) -> + let sigma, c = oc sigma in + let sigma, hypinfo = decompose_applied_relation env sigma c in + let { c1; c2; car; rel; prf; sort; holes } = hypinfo in + let rew = (car, rel, prf, c1, c2, holes, sort) in + let evars = (sigma, cstrs) in + let unify env evars t = + let rew = unify_eqn rew l2r flags env evars by t in + match rew with + | None -> None + | Some rew -> Some rew + in + let _, res = (apply_rule unify loccs).strategy { input with + state = 0 ; + evars } in + (), res + } + +let e_app_poly env evars f args = + let evars', c = app_poly_nocheck env !evars f args in + evars := evars'; + c + +let make_leibniz_proof env c ty r = + let evars = ref r.rew_evars in + let prf = + match r.rew_prf with + | RewPrf (rel, prf) -> + let rel = e_app_poly env evars coq_eq [| ty |] in + let prf = + e_app_poly env evars coq_f_equal + [| r.rew_car; ty; + mkLambda (Anonymous, r.rew_car, c); + r.rew_from; r.rew_to; prf |] + in RewPrf (rel, prf) + | RewCast k -> r.rew_prf + in + { rew_car = ty; rew_evars = !evars; + rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } + +let reset_env env = + let env' = Global.env_of_context (Environ.named_context_val env) in + Environ.push_rel_context (Environ.rel_context env) env' + +let fold_match ?(force=false) env sigma c = + let (ci, p, c, brs) = destCase c in + let cty = Retyping.get_type_of env sigma c in + let dep, pred, exists, (sk,eff) = + let env', ctx, body = + let ctx, pred = decompose_lam_assum p in + let env' = Environ.push_rel_context ctx env in + env', ctx, pred + in + let sortp = Retyping.get_sort_family_of env' sigma body in + let sortc = Retyping.get_sort_family_of env sigma cty in + let dep = not (noccurn 1 body) in + let pred = if dep then p else + it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) + in + let sk = + if sortp == InProp then + if sortc == InProp then + if dep then case_dep_scheme_kind_from_prop + else case_scheme_kind_from_prop + else ( + if dep + then case_dep_scheme_kind_from_type_in_prop + else case_scheme_kind_from_type) + else ((* sortc <> InProp by typing *) + if dep + then case_dep_scheme_kind_from_type + else case_scheme_kind_from_type) + in + let exists = Ind_tables.check_scheme sk ci.ci_ind in + if exists || force then + dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind + else raise Not_found + in + let app = + let ind, args = Inductive.find_rectype env cty in + let pars, args = List.chop ci.ci_npar args in + let meths = List.map (fun br -> br) (Array.to_list brs) in + applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) + in + sk, (if exists then env else reset_env env), app, eff + +let unfold_match env sigma sk app = + match kind_of_term app with + | App (f', args) when eq_constant (fst (destConst f')) sk -> + let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in + Reductionops.whd_beta sigma (mkApp (v, args)) + | _ -> app + +let is_rew_cast = function RewCast _ -> true | _ -> false + +let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = + let rec aux { state ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = + let cstr' = Option.map (fun c -> (ty, Some c)) cstr in + match kind_of_term t with + | App (m, args) -> + let rewrite_args state success = + let state, (args', evars', progress) = + Array.fold_left + (fun (state, (acc, evars, progress)) arg -> + if not (Option.is_empty progress) && not all then + state, (None :: acc, evars, progress) + else + let argty = Retyping.get_type_of env (goalevars evars) arg in + let state, res = s.strategy { state ; env ; + unfresh ; + term1 = arg ; ty1 = argty ; + cstr = (prop,None) ; + evars } in + let res' = + match res with + | Identity -> + let progress = if Option.is_empty progress then Some false else progress in + (None :: acc, evars, progress) + | Success r -> + (Some r :: acc, r.rew_evars, Some true) + | Fail -> (None :: acc, evars, progress) + in state, res') + (state, ([], evars, success)) args + in + let res = + match progress with + | None -> Fail + | Some false -> Identity + | Some true -> + let args' = Array.of_list (List.rev args') in + if Array.exists + (function + | None -> false + | Some r -> not (is_rew_cast r.rew_prf)) args' + then + let evars', prf, car, rel, c1, c2 = + resolve_morphism env unfresh t m args args' (prop, cstr') evars' + in + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Success res + else + let args' = Array.map2 + (fun aorig anew -> + match anew with None -> aorig + | Some r -> r.rew_to) args args' + in + let res = { rew_car = ty; rew_from = t; + rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; + rew_evars = evars' } + in Success res + in state, res + in + if flags.on_morphisms then + let mty = Retyping.get_type_of env (goalevars evars) m in + let evars, cstr', m, mty, argsl, args = + let argsl = Array.to_list args in + let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in + match lift env evars argsl m mty None with + | Some (evars, cstr', m, mty, args) -> + evars, Some cstr', m, mty, args, Array.of_list args + | None -> evars, None, m, mty, argsl, args + in + let state, m' = s.strategy { state ; env ; unfresh ; + term1 = m ; ty1 = mty ; + cstr = (prop, cstr') ; evars } in + match m' with + | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) + | Identity -> rewrite_args state (Some false) + | Success r -> + (* We rewrote the function and get a proof of pointwise rel for the arguments. + We just apply it. *) + let prf = match r.rew_prf with + | RewPrf (rel, prf) -> + let app = if prop then PropGlobal.apply_pointwise + else TypeGlobal.apply_pointwise + in + RewPrf (app rel argsl, mkApp (prf, args)) + | x -> x + in + let res = + { rew_car = prod_appvect r.rew_car args; + rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); + rew_prf = prf; rew_evars = r.rew_evars } + in + let res = + match prf with + | RewPrf (rel, prf) -> + Success (apply_constraint env unfresh res.rew_car + rel prf (prop,cstr) res) + | _ -> Success res + in state, res + else rewrite_args state None + + | Prod (n, x, b) when noccurn 1 b -> + let b = subst1 mkProp b in + let tx = Retyping.get_type_of env (goalevars evars) x + and tb = Retyping.get_type_of env (goalevars evars) b in + let arr = if prop then PropGlobal.arrow_morphism + else TypeGlobal.arrow_morphism + in + let (evars', mor), unfold = arr env evars tx tb x b in + let state, res = aux { state ; env ; unfresh ; + term1 = mor ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold r.rew_to } + | Fail | Identity -> res + in state, res + + (* if x' = None && flags.under_lambdas then *) + (* let lam = mkLambda (n, x, b) in *) + (* let lam', occ = aux env lam occ None in *) + (* let res = *) + (* match lam' with *) + (* | None -> None *) + (* | Some (prf, (car, rel, c1, c2)) -> *) + (* Some (resolve_morphism env sigma t *) + (* ~fnewt:unfold_all *) + (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) + (* cstr evars) *) + (* in res, occ *) + (* else *) + + | Prod (n, dom, codom) -> + let lam = mkLambda (n, dom, codom) in + let (evars', app), unfold = + if eq_constr ty mkProp then + (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all + else + let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in + (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall + in + let state, res = aux { state ; env ; unfresh ; + term1 = app ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold r.rew_to } + | Fail | Identity -> res + in state, res + +(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with + H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. + B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing + dependent relations and using projections to get them out. + *) + (* | Lambda (n, t, b) when flags.under_lambdas -> *) + (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) + (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) + (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) + (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) + (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) + (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) + (* (match b' with *) + (* | Some (Some r) -> *) + (* let prf = match r.rew_prf with *) + (* | RewPrf (rel, prf) -> *) + (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) + (* let prf = mkLambda (n', t, prf) in *) + (* RewPrf (rel, prf) *) + (* | x -> x *) + (* in *) + (* Some (Some { r with *) + (* rew_prf = prf; *) + (* rew_car = mkProd (n, t, r.rew_car); *) + (* rew_from = mkLambda(n, t, r.rew_from); *) + (* rew_to = mkLambda (n, t, r.rew_to) }) *) + (* | _ -> b') *) + + | Lambda (n, t, b) when flags.under_lambdas -> + let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let open Context.Rel.Declaration in + let env' = Environ.push_rel (LocalAssum (n', t)) env in + let bty = Retyping.get_type_of env' (goalevars evars) b in + let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in + let state, b' = s.strategy { state ; env = env' ; unfresh ; + term1 = b ; ty1 = bty ; + cstr = (prop, unlift env evars cstr) ; + evars } in + let res = + match b' with + | Success r -> + let r = match r.rew_prf with + | RewPrf (rel, prf) -> + let point = if prop then PropGlobal.pointwise_or_dep_relation else + TypeGlobal.pointwise_or_dep_relation + in + let evars, rel = point env r.rew_evars n' t r.rew_car rel in + let prf = mkLambda (n', t, prf) in + { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } + | x -> r + in + Success { r with + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) } + | Fail | Identity -> b' + in state, res + + | Case (ci, p, c, brs) -> + let cty = Retyping.get_type_of env (goalevars evars) c in + let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in + let cstr' = Some eqty in + let state, c' = s.strategy { state ; env ; unfresh ; + term1 = c ; ty1 = cty ; + cstr = (prop, cstr') ; evars = evars' } in + let state, res = + match c' with + | Success r -> + let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let res = make_leibniz_proof env case ty r in + state, Success (coerce env unfresh (prop,cstr) res) + | Fail | Identity -> + if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then + let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in + let cstr = Some eqty in + let state, found, brs' = Array.fold_left + (fun (state, found, acc) br -> + if not (Option.is_empty found) then + (state, found, fun x -> lift 1 br :: acc x) + else + let state, res = s.strategy { state ; env ; unfresh ; + term1 = br ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + match res with + | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) + | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) + (state, None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in + state, Success (make_leibniz_proof env ctxc ty r) + | None -> state, c' + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> state, c' + | Some (cst, _, t', eff (*FIXME*)) -> + let state, res = aux { state ; env ; unfresh ; + term1 = t' ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + let res = + match res with + | Success prf -> + Success { prf with + rew_from = t; + rew_to = unfold_match env (goalevars evars) cst prf.rew_to } + | x' -> c' + in state, res + in + let res = + match res with + | Success r -> + let rel, prf = get_rew_prf r in + Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) + | Fail | Identity -> res + in state, res + | _ -> state, Fail + in { strategy = aux } + +let all_subterms = subterm true default_flags +let one_subterm = subterm false default_flags + +(** Requires transitivity of the rewrite step, if not a reduction. + Not tail-recursive. *) + +let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : + 'a * rewrite_result = + let state, nextres = + next.strategy { state ; env ; unfresh ; + term1 = res.rew_to ; ty1 = res.rew_car ; + cstr = (prop, get_opt_rew_rel res.rew_prf) ; + evars = res.rew_evars } + in + let res = + match nextres with + | Fail -> Fail + | Identity -> Success res + | Success res' -> + match res.rew_prf with + | RewCast c -> Success { res' with rew_from = res.rew_from } + | RewPrf (rew_rel, rew_prf) -> + match res'.rew_prf with + | RewCast _ -> Success { res with rew_to = res'.rew_to } + | RewPrf (res'_rel, res'_prf) -> + let trans = + if prop then PropGlobal.transitive_type + else TypeGlobal.transitive_type + in + let evars, prfty = + app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] + in + let evars, prf = new_cstr_evar evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Success { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } + in state, res + +(** Rewriting strategies. + + Inspired by ELAN's rewriting strategies: + http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 +*) + +module Strategies = + struct + + let fail : 'a pure_strategy = + { strategy = fun { state } -> state, Fail } + + let id : 'a pure_strategy = + { strategy = fun { state } -> state, Identity } + + let refl : 'a pure_strategy = + { strategy = + fun { state ; env ; + term1 = t ; ty1 = ty ; + cstr = (prop,cstr) ; evars } -> + let evars, rel = match cstr with + | None -> + let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in + let evars, rty = mkr env evars ty in + new_cstr_evar evars env rty + | Some r -> evars, r + in + let evars, proof = + let proxy = + if prop then PropGlobal.proper_proxy_type + else TypeGlobal.proper_proxy_type + in + let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in + new_cstr_evar evars env mty + in + let res = Success { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars } + in state, res + } + + let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = + fun input -> + let state, res = s.strategy input in + match res with + | Fail -> state, Fail + | Identity -> state, Fail + | Success r -> state, Success r + } + + let seq first snd : 'a pure_strategy = { strategy = + fun ({ env ; unfresh ; cstr } as input) -> + let state, res = first.strategy input in + match res with + | Fail -> state, Fail + | Identity -> snd.strategy { input with state } + | Success res -> transitivity state env unfresh (fst cstr) res snd + } + + let choice fst snd : 'a pure_strategy = { strategy = + fun input -> + let state, res = fst.strategy input in + match res with + | Fail -> snd.strategy { input with state } + | Identity | Success _ -> state, res + } + + let try_ str : 'a pure_strategy = choice str id + + let check_interrupt str input = + Control.check_for_interrupt (); + str input + + let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = + let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in + { strategy = aux } + + let any (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun any -> try_ (seq s any)) + + let repeat (s : 'a pure_strategy) : 'a pure_strategy = + seq s (any s) + + let bu (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) + + let td (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) + + let innermost (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun ins -> choice (one_subterm ins) s) + + let outermost (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun out -> choice s (one_subterm out)) + + let lemmas cs : 'a pure_strategy = + List.fold_left (fun tac (l,l2r,by) -> + choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) + fail cs + + let inj_open hint = (); fun sigma -> + let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in + let sigma = Evd.merge_universe_context sigma ctx in + (sigma, (hint.Autorewrite.rew_lemma, NoBindings)) + + let old_hints (db : string) : 'a pure_strategy = + let rules = Autorewrite.find_rewrites db in + lemmas + (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac)) rules) + + let hints (db : string) : 'a pure_strategy = { strategy = + fun ({ term1 = t } as input) -> + let rules = Autorewrite.find_matches db t in + let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac) in + let lems = List.map lemma rules in + (lemmas lems).strategy input + } + + let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = + fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> + let rfn, ckind = Redexpr.reduction_of_red_expr env r in + let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in + let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in + let evars' = Sigma.to_evar_map sigma in + if eq_constr t' t then + state, Identity + else + state, Success { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; + rew_evars = evars', cstrevars evars } + } + + let fold_glob c : 'a pure_strategy = { strategy = + fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) + let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in + let unfolded = + try Tacred.try_red_product env sigma c + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" + in + try + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in + let c' = Evarutil.nf_evar sigma c in + state, Success { rew_car = ty; rew_from = t; rew_to = c'; + rew_prf = RewCast DEFAULTcast; + rew_evars = (sigma, snd evars) } + with e when Errors.noncritical e -> state, Fail + } + + +end + +(** The strategy for a single rewrite, dealing with occurrences. *) + +(** A dummy initial clauseenv to avoid generating initial evars before + even finding a first application of the rewriting lemma, in setoid_rewrite + mode *) + +let rewrite_with l2r flags c occs : strategy = { strategy = + fun ({ state = () } as input) -> + let unify env evars t = + let (sigma, cstrs) = evars in + let ans = + try Some (refresh_hypinfo env sigma c) + with e when Class_tactics.catchable e -> None + in + match ans with + | None -> None + | Some (sigma, rew) -> + let rew = unify_eqn rew l2r flags env (sigma, cstrs) None t in + match rew with + | None -> None + | Some rew -> Some rew + in + let app = apply_rule unify occs in + let strat = + Strategies.fix (fun aux -> + Strategies.choice app (subterm true default_flags aux)) + in + let _, res = strat.strategy { input with state = 0 } in + ((), res) + } + +let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = + let ty = Retyping.get_type_of env (goalevars evars) concl in + let _, res = s.strategy { state = () ; env ; unfresh ; + term1 = concl ; ty1 = ty ; + cstr = (prop, Some cstr) ; evars } in + res + +let solve_constraints env (evars,cstrs) = + let filter = all_constraints cstrs in + Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true + (Typeclasses.mark_resolvables ~filter evars) + +let nf_zeta = + Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + +exception RewriteFailure of Pp.std_ppcmds + +type result = (evar_map * constr option * types) option option + +let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = + let evdref = ref sigma in + let sort = Typing.e_sort_of env evdref concl in + let evars = (!evdref, Evar.Set.empty) in + let evars, cstr = + let prop, (evars, arrow) = + if is_prop_sort sort then true, app_poly_sort true env evars impl [||] + else false, app_poly_sort false env evars TypeGlobal.arrow [||] + in + match is_hyp with + | None -> + let evars, t = poly_inverse prop env evars (mkSort sort) arrow in + evars, (prop, t) + | Some _ -> evars, (prop, arrow) + in + let eq = apply_strategy strat env avoid concl cstr evars in + match eq with + | Fail -> None + | Identity -> Some None + | Success res -> + let (_, cstrs) = res.rew_evars in + let evars' = solve_constraints env res.rew_evars in + let newt = Evarutil.nf_evar evars' res.rew_to in + let evars = (* Keep only original evars (potentially instantiated) and goal evars, + the rest has been defined and substituted already. *) + Evar.Set.fold + (fun ev acc -> + if not (Evd.is_defined acc ev) then + errorlabstrm "rewrite" + (str "Unsolved constraint remaining: " ++ spc () ++ + Evd.pr_evar_info (Evd.find acc ev)) + else Evd.remove acc ev) + cstrs evars' + in + let res = match res.rew_prf with + | RewCast c -> None + | RewPrf (rel, p) -> + let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in + let term = + match abs with + | None -> p + | Some (t, ty) -> + let t = Evarutil.nf_evar evars' t in + let ty = Evarutil.nf_evar evars' ty in + mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + in + let proof = match is_hyp with + | None -> term + | Some id -> mkApp (term, [| mkVar id |]) + in Some proof + in Some (Some (evars, res, newt)) + +(** Insert a declaration after the last declaration it depends on *) +let rec insert_dependent env decl accu hyps = match hyps with +| [] -> List.rev_append accu [decl] +| ndecl :: rem -> + if occur_var_in_decl env (get_id ndecl) decl then + List.rev_append accu (decl :: hyps) + else + insert_dependent env decl (ndecl :: accu) rem + +let assert_replacing id newt tac = + let prf = Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let ctx = Environ.named_context env in + let after, before = List.split_when (Id.equal id % get_id) ctx in + let nc = match before with + | [] -> assert false + | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem + in + let env' = Environ.reset_with_named_context (val_of_named_context nc) env in + Refine.refine ~unsafe:false { run = begin fun sigma -> + let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in + let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in + let map d = + let n = get_id d in + if Id.equal n id then ev' else mkVar n + in + let (e, _) = destEvar ev in + Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) + end } + end } in + Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) + +let newfail n s = + Proofview.tclZERO (Refiner.FailError (n, lazy s)) + +let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = + let open Proofview.Notations in + let treat sigma res = + match res with + | None -> newfail 0 (str "Nothing to rewrite") + | Some None -> if progress then newfail 0 (str"Failed to progress") + else Proofview.tclUNIT () + | Some (Some res) -> + let (undef, prf, newt) = res in + let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in + let gls = List.rev (Evd.fold_undefined fold undef []) in + match clause, prf with + | Some id, Some p -> + let tac = Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in + Proofview.Unsafe.tclEVARS undef <*> + assert_replacing id newt tac + | Some id, None -> + Proofview.Unsafe.tclEVARS undef <*> + convert_hyp_no_check (LocalAssum (id, newt)) + | None, Some p -> + Proofview.Unsafe.tclEVARS undef <*> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let make = { run = begin fun sigma -> + let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in + Sigma (mkApp (p, [| ev |]), sigma, q) + end } in + Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls + end } + | None, None -> + Proofview.Unsafe.tclEVARS undef <*> + convert_concl_no_check newt DEFAULTcast + in + let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in + let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in + let opt_beta = match clause with + | None -> Proofview.tclUNIT () + | Some id -> Tactics.reduct_in_hyp beta_red (id, InHyp) + in + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ty = match clause with + | None -> concl + | Some id -> Environ.named_type id env + in + let env = match clause with + | None -> env + | Some id -> + (** Only consider variables not depending on [id] *) + let ctx = Environ.named_context env in + let filter decl = not (occur_var_in_decl env id decl) in + let nctx = List.filter filter ctx in + Environ.reset_with_named_context (Environ.val_of_named_context nctx) env + in + try + let res = + cl_rewrite_clause_aux ?abs strat env [] sigma ty clause + in + let sigma = match origsigma with None -> sigma | Some sigma -> sigma in + treat sigma res <*> + (** For compatibility *) + beta <*> opt_beta <*> Proofview.shelve_unifiable + with + | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> + raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) + end } + +let tactic_init_setoid () = + try init_setoid (); tclIDTAC + with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded") + +let cl_rewrite_clause_strat progress strat clause = + tclTHEN (tactic_init_setoid ()) + ((if progress then tclWEAK_PROGRESS else fun x -> x) + (fun gl -> + try Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~progress strat clause) gl + with RewriteFailure e -> + errorlabstrm "" (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)) + +(** Setoid rewriting when called with "setoid_rewrite" *) +let cl_rewrite_clause l left2right occs clause gl = + let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in + cl_rewrite_clause_strat true strat clause gl + +(** Setoid rewriting when called with "rewrite_strat" *) +let cl_rewrite_clause_strat strat clause = + cl_rewrite_clause_strat false strat clause + +let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> + let c sigma = + let (sigma, c) = Pretyping.understand_tcc env sigma c in + (sigma, (c, NoBindings)) + in + let flags = general_rewrite_unif_flags () in + (apply_lemma l2r flags c None occs).strategy input + +let interp_glob_constr_list env = + let make c = (); fun sigma -> + let sigma, c = Pretyping.understand_tcc env sigma c in + (sigma, (c, NoBindings)) + in + List.map (fun c -> make c, true, None) + +(* Syntax for rewriting with strategies *) + +type unary_strategy = + Subterms | Subterm | Innermost | Outermost + | Bottomup | Topdown | Progress | Try | Any | Repeat + +type binary_strategy = + | Compose | Choice + +type ('constr,'redexpr) strategy_ast = + | StratId | StratFail | StratRefl + | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast + | StratBinary of binary_strategy + * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast + | StratConstr of 'constr * bool + | StratTerms of 'constr list + | StratHints of bool * string + | StratEval of 'redexpr + | StratFold of 'constr + +let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function + | StratId | StratFail | StratRefl as s -> s + | StratUnary (s, str) -> StratUnary (s, map_strategy f g str) + | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str') + | StratConstr (c, b) -> StratConstr (f c, b) + | StratTerms l -> StratTerms (List.map f l) + | StratHints (b, id) -> StratHints (b, id) + | StratEval r -> StratEval (g r) + | StratFold c -> StratFold (f c) + +let rec strategy_of_ast = function + | StratId -> Strategies.id + | StratFail -> Strategies.fail + | StratRefl -> Strategies.refl + | StratUnary (f, s) -> + let s' = strategy_of_ast s in + let f' = match f with + | Subterms -> all_subterms + | Subterm -> one_subterm + | Innermost -> Strategies.innermost + | Outermost -> Strategies.outermost + | Bottomup -> Strategies.bu + | Topdown -> Strategies.td + | Progress -> Strategies.progress + | Try -> Strategies.try_ + | Any -> Strategies.any + | Repeat -> Strategies.repeat + in f' s' + | StratBinary (f, s, t) -> + let s' = strategy_of_ast s in + let t' = strategy_of_ast t in + let f' = match f with + | Compose -> Strategies.seq + | Choice -> Strategies.choice + in f' s' t' + | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } + | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id + | StratTerms l -> { strategy = + (fun ({ state = () ; env } as input) -> + let l' = interp_glob_constr_list env (List.map fst l) in + (Strategies.lemmas l').strategy input) + } + | StratEval r -> { strategy = + (fun ({ state = () ; env ; evars } as input) -> + let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in + (Strategies.reduce r_interp).strategy { input with + evars = (sigma,cstrevars evars) }) } + | StratFold c -> Strategies.fold_glob (fst c) + + +(* By default the strategy for "rewrite_db" is top-down *) + +let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) + +let declare_an_instance n s args = + (((Loc.ghost,Name n),None), Explicit, + CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), + args)) + +let declare_instance a aeq n s = declare_an_instance n s [a;aeq] + +let anew_instance global binders instance fields = + new_instance (Flags.is_universe_polymorphism ()) + binders instance (Some (true, CRecord (Loc.ghost,fields))) + ~global ~generalize:false None + +let declare_instance_refl global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] + +let declare_instance_sym global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] + +let declare_instance_trans global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] + +let declare_relation ?(binders=[]) a aeq n refl symm trans = + init_setoid (); + let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" + in ignore(anew_instance global binders instance []); + match (refl,symm,trans) with + (None, None, None) -> () + | (Some lemma1, None, None) -> + ignore (declare_instance_refl global binders a aeq n lemma1) + | (None, Some lemma2, None) -> + ignore (declare_instance_sym global binders a aeq n lemma2) + | (None, None, Some lemma3) -> + ignore (declare_instance_trans global binders a aeq n lemma3) + | (Some lemma1, Some lemma2, None) -> + ignore (declare_instance_refl global binders a aeq n lemma1); + ignore (declare_instance_sym global binders a aeq n lemma2) + | (Some lemma1, None, Some lemma3) -> + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) + | (None, Some lemma2, Some lemma3) -> + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) + | (Some lemma1, Some lemma2, Some lemma3) -> + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) + +let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) + +let proper_projection r ty = + let ctx, inst = decompose_prod_assum ty in + let mor, args = destApp inst in + let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in + let app = mkApp (Lazy.force PropGlobal.proper_proj, + Array.append args [| instarg |]) in + it_mkLambda_or_LetIn app ctx + +let declare_projection n instance_id r = + let poly = Global.is_polymorphic r in + let env = Global.env () in + let sigma = Evd.from_env env in + let evd,c = Evd.fresh_global env sigma r in + let ty = Retyping.get_type_of env sigma c in + let term = proper_projection c ty in + let typ = Typing.unsafe_type_of env sigma term in + let ctx, typ = decompose_prod_assum typ in + let typ = + let n = + let rec aux t = + match kind_of_term t with + | App (f, [| a ; a' ; rel; rel' |]) + when Globnames.is_global (PropGlobal.respectful_ref ()) f -> + succ (aux rel') + | _ -> 0 + in + let init = + match kind_of_term typ with + App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> + mkApp (f, fst (Array.chop (Array.length args - 2) args)) + | _ -> typ + in aux init + in + let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ + in it_mkProd_or_LetIn ccl ctx + in + let typ = it_mkProd_or_LetIn typ ctx in + let pl, ctx = Evd.universe_context sigma in + let cst = + Declare.definition_entry ~types:typ ~poly ~univs:ctx term + in + ignore(Declare.declare_constant n + (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + +let build_morphism_signature m = + let env = Global.env () in + let sigma = Evd.from_env env in + let m,ctx = Constrintern.interp_constr env sigma m in + let sigma = Evd.from_ctx ctx in + let t = Typing.unsafe_type_of env sigma m in + let cstrs = + let rec aux t = + match kind_of_term t with + | Prod (na, a, b) -> + None :: aux b + | _ -> [] + in aux t + in + let evars, t', sig_, cstrs = + PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in + let evd = ref evars in + let _ = List.iter + (fun (ty, rel) -> + Option.iter (fun rel -> + let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in + ignore(e_new_cstr_evar env evd default)) + rel) + cstrs + in + let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in + let evd = solve_constraints env !evd in + let m = Evarutil.nf_evar evd morph in + Pretyping.check_evars env Evd.empty evd m; m + +let default_morphism sign m = + let env = Global.env () in + let sigma = Evd.from_env env in + let t = Typing.unsafe_type_of env sigma m in + let evars, _, sign, cstrs = + PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) + in + let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in + let evars, mor = resolve_one_typeclass env (goalevars evars) morph in + mor, proper_projection mor morph + +let add_setoid global binders a aeq t n = + init_setoid (); + let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + + +let make_tactic name = + let open Tacexpr in + let loc = Loc.ghost in + let tacpath = Libnames.qualid_of_string name in + let tacname = Qualid (loc, tacpath) in + TacArg (loc, TacCall (loc, tacname, [])) + +let add_morphism_infer glob m n = + init_setoid (); + let poly = Flags.is_universe_polymorphism () in + let instance_id = add_suffix n "_Proper" in + let instance = build_morphism_signature m in + let evd = Evd.from_env (Global.env ()) in + if Lib.is_modtype () then + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id + (Entries.ParameterEntry + (None,poly,(instance,Univ.UContext.empty),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) + in + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None glob + poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + else + let kind = Decl_kinds.Global, poly, + Decl_kinds.DefinitionBody Decl_kinds.Instance + in + let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in + let hook _ = function + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) None + glob poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false + in + let hook = Lemmas.mk_hook hook in + Flags.silently + (fun () -> + Lemmas.start_proof instance_id kind evd instance hook; + ignore (Pfedit.by (Tacinterp.interp tac))) () + +let add_morphism glob binders m s n = + init_setoid (); + let poly = Flags.is_universe_polymorphism () in + let instance_id = add_suffix n "_Proper" in + let instance = + (((Loc.ghost,Name instance_id),None), Explicit, + CAppExpl (Loc.ghost, + (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), + [cHole; s; m])) + in + let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in + ignore(new_instance ~global:glob poly binders instance + (Some (true, CRecord (Loc.ghost,[]))) + ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) + +(** Bind to "rewrite" too *) + +(** Taken from original setoid_replace, to emulate the old rewrite semantics where + lemmas are first instantiated and then rewrite proceeds. *) + +let check_evar_map_of_evars_defs evd = + let metas = Evd.meta_list evd in + let check_freemetas_is_empty rebus = + Evd.Metaset.iter + (fun m -> + if Evd.meta_defined evd m then () else + raise + (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) + in + List.iter + (fun (_,binding) -> + match binding with + Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> + check_freemetas_is_empty rebus freemetas + | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), + {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> + check_freemetas_is_empty rebus1 freemetas1 ; + check_freemetas_is_empty rebus2 freemetas2 + ) metas + +(* Find a subterm which matches the pattern to rewrite for "rewrite" *) +let unification_rewrite l2r c1 c2 sigma prf car rel but env = + let (sigma,c') = + try + (* ~flags:(false,true) to allow to mark occurrences that must not be + rewritten simply by replacing them with let-defined definitions + in the context *) + Unification.w_unify_to_subterm + ~flags:rewrite_unif_flags + env sigma ((if l2r then c1 else c2),but) + with + | ex when Pretype_errors.precatchable_exception ex -> + (* ~flags:(true,true) to make Ring work (since it really + exploits conversion) *) + Unification.w_unify_to_subterm + ~flags:rewrite_conv_unif_flags + env sigma ((if l2r then c1 else c2),but) + in + let nf c = Evarutil.nf_evar sigma c in + let c1 = if l2r then nf c' else nf c1 + and c2 = if l2r then nf c2 else nf c' + and car = nf car and rel = nf rel in + check_evar_map_of_evars_defs sigma; + let prf = nf prf in + let prfty = nf (Retyping.get_type_of env sigma prf) in + let sort = sort_of_rel env sigma but in + let abs = prf, prfty in + let prf = mkRel 1 in + let res = (car, rel, prf, c1, c2) in + abs, sigma, res, Sorts.is_prop sort + +let get_hyp gl (c,l) clause l2r = + let evars = project gl in + let env = pf_env gl in + let sigma, hi = decompose_applied_relation env evars (c,l) in + let but = match clause with + | Some id -> pf_get_hyp_typ gl id + | None -> Evarutil.nf_evar evars (pf_concl gl) + in + unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env + +let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } + +(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) +(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) + +(** Setoid rewriting when called with "rewrite" *) +let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = + let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in + let unify env evars t = unify_abs res l2r sort env evars t in + let app = apply_rule unify occs in + let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in + let substrat = Strategies.fix recstrat in + let strat = { strategy = fun ({ state = () } as input) -> + let _, res = substrat.strategy { input with state = 0 } in + (), res + } + in + let origsigma = project gl in + init_setoid (); + try + tclWEAK_PROGRESS + (tclTHEN + (Refiner.tclEVARS evd) + (Proofview.V82.of_tactic + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) gl + with RewriteFailure e -> + tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl + +let general_s_rewrite_clause x = + match x with + | None -> general_s_rewrite None + | Some id -> general_s_rewrite (Some id) + +let general_s_rewrite_clause x y z w ~new_goals = + Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals) + +let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite_clause + +(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let not_declared env ty rel = + Tacticals.New.tclFAIL 0 + (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") + +let setoid_proof ty fn fallback = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + Proofview.tclORELSE + begin + try + let rel, _, _ = decompose_app_rel env sigma concl in + let open Context.Rel.Declaration in + let (sigma, t) = Typing.type_of env sigma rel in + let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in + (try init_relation_classes () with _ -> raise Not_found); + fn env sigma car rel + with e -> Proofview.tclZERO e + end + begin function + | e -> + Proofview.tclORELSE + fallback + begin function (e', info) -> match e' with + | Hipattern.NoEquationFound -> + begin match e with + | (Not_found, _) -> + let rel, _, _ = decompose_app_rel env sigma concl in + not_declared env ty rel + | (e, info) -> Proofview.tclZERO ~info e + end + | e' -> Proofview.tclZERO ~info e' + end + end + end } + +let tac_open ((evm,_), c) tac = + Proofview.V82.tactic + (tclTHEN (Refiner.tclEVARS evm) (tac c)) + +let poly_proof getp gett env evm car rel = + if Sorts.is_prop (sort_of_rel env evm rel) then + getp env (evm,Evar.Set.empty) car rel + else gett env (evm,Evar.Set.empty) car rel + +let setoid_reflexivity = + setoid_proof "reflexive" + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_reflexive_proof + TypeGlobal.get_reflexive_proof + env evm car rel) + (fun c -> tclCOMPLETE (Proofview.V82.of_tactic (apply c)))) + (reflexivity_red true) + +let setoid_symmetry = + setoid_proof "symmetric" + (fun env evm car rel -> + tac_open + (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof + env evm car rel) + (fun c -> Proofview.V82.of_tactic (apply c))) + (symmetry_red true) + +let setoid_transitivity c = + setoid_proof "transitive" + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof + env evm car rel) + (fun proof -> match c with + | None -> Proofview.V82.of_tactic (eapply proof) + | Some c -> Proofview.V82.of_tactic (apply_with_bindings (proof,ImplicitBindings [ c ])))) + (transitivity_red true c) + +let setoid_symmetry_in id = + Proofview.V82.tactic (fun gl -> + let ctype = pf_unsafe_type_of gl (mkVar id) in + let binders,concl = decompose_prod_assum ctype in + let (equiv, args) = decompose_app concl in + let rec split_last_two = function + | [c1;c2] -> [],(c1, c2) + | x::y::z -> let l,res = split_last_two (y::z) in x::l, res + | _ -> error "Cannot find an equivalence relation to rewrite." + in + let others,(c1,c2) = split_last_two args in + let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in + let new_hyp' = mkApp (he, [| c2 ; c1 |]) in + let new_hyp = it_mkProd_or_LetIn new_hyp' binders in + Proofview.V82.of_tactic + (Tacticals.New.tclTHENLAST + (Tactics.assert_after_replacing id new_hyp) + (Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) + gl) + +let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity +let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry +let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in +let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity + +let get_lemma_proof f env evm x y = + let (evm, _), c = f env (evm,Evar.Set.empty) x y in + evm, c + +let get_reflexive_proof = + get_lemma_proof PropGlobal.get_reflexive_proof + +let get_symmetric_proof = + get_lemma_proof PropGlobal.get_symmetric_proof + +let get_transitive_proof = + get_lemma_proof PropGlobal.get_transitive_proof + diff --git a/ltac/rewrite.mli b/ltac/rewrite.mli new file mode 100644 index 0000000000..01709f29fb --- /dev/null +++ b/ltac/rewrite.mli @@ -0,0 +1,114 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* strategy + +val map_strategy : ('a -> 'b) -> ('c -> 'd) -> + ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast + +(** Entry point for user-level "rewrite_strat" *) +val cl_rewrite_clause_strat : strategy -> Id.t option -> tactic + +(** Entry point for user-level "setoid_rewrite" *) +val cl_rewrite_clause : + interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> + bool -> Locus.occurrences -> Id.t option -> tactic + +val is_applied_rewrite_relation : + env -> evar_map -> Context.Rel.t -> constr -> types option + +val declare_relation : + ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t -> + constr_expr option -> constr_expr option -> constr_expr option -> unit + +val add_setoid : + bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr -> + Id.t -> unit + +val add_morphism_infer : bool -> constr_expr -> Id.t -> unit + +val add_morphism : + bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit + +val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val default_morphism : + (types * constr option) option list * (types * types option) option -> + constr -> constr * constr + +val setoid_symmetry : unit Proofview.tactic + +val setoid_symmetry_in : Id.t -> unit Proofview.tactic + +val setoid_reflexivity : unit Proofview.tactic + +val setoid_transitivity : constr option -> unit Proofview.tactic + + +val apply_strategy : + strategy -> + Environ.env -> + Names.Id.t list -> + Term.constr -> + bool * Term.constr -> + evars -> rewrite_result diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml new file mode 100644 index 0000000000..711cd8d9d0 --- /dev/null +++ b/ltac/tacentries.ml @@ -0,0 +1,263 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* GramTerminal s + | TacNonTerm (loc, nt, (_, sep)) -> + let EntryName (etyp, e) = interp_entry_name lev nt sep in + GramNonTerminal (loc, etyp, e) + +let make_terminal_status = function + | GramTerminal s -> Some s + | GramNonTerminal _ -> None + +let make_fresh_key = + let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in + fun () -> + let cur = incr id; !id in + let lbl = Id.of_string ("_" ^ string_of_int cur) in + let kn = Lib.make_kn lbl in + let (mp, dir, _) = KerName.repr kn in + (** We embed the full path of the kernel name in the label so that the + identifier should be unique. This ensures that including two modules + together won't confuse the corresponding labels. *) + let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" + (ModPath.to_string mp) (DirPath.to_string dir) cur) + in + KerName.make mp dir (Label.of_id lbl) + +type tactic_grammar_obj = { + tacobj_key : KerName.t; + tacobj_local : locality_flag; + tacobj_tacgram : tactic_grammar; + tacobj_tacpp : Pptactic.pp_tactic; + tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; +} + +let check_key key = + if Tacenv.check_alias key then + error "Conflicting tactic notations keys. This can happen when including \ + twice the same module." + +let cache_tactic_notation (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + Tacenv.register_alias key tobj.tacobj_body; + Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram; + Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp + +let open_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + if Int.equal i 1 && not tobj.tacobj_local then + Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram + +let load_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + (** Only add the printing and interpretation rules. *) + Tacenv.register_alias key tobj.tacobj_body; + Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp; + if Int.equal i 1 && not tobj.tacobj_local then + Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram + +let subst_tactic_notation (subst, tobj) = + let (ids, body) = tobj.tacobj_body in + { tobj with + tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; + tacobj_body = (ids, Tacsubst.subst_tactic subst body); + } + +let classify_tactic_notation tacobj = Substitute tacobj + +let inTacticGrammar : tactic_grammar_obj -> obj = + declare_object {(default_object "TacticGrammar") with + open_function = open_tactic_notation; + load_function = load_tactic_notation; + cache_function = cache_tactic_notation; + subst_function = subst_tactic_notation; + classify_function = classify_tactic_notation} + +let cons_production_parameter = function +| TacTerm _ -> None +| TacNonTerm (_, _, (id, _)) -> Some id + +let add_tactic_notation (local,n,prods,e) = + let ids = List.map_filter cons_production_parameter prods in + let prods = List.map (interp_prod_item n) prods in + let pprule = { + Pptactic.pptac_level = n; + pptac_prods = prods; + } in + let tac = Tacintern.glob_tactic_env ids (Global.env()) e in + let parule = { + tacgram_level = n; + tacgram_prods = prods; + } in + let tacobj = { + tacobj_key = make_fresh_key (); + tacobj_local = local; + tacobj_tacgram = parule; + tacobj_tacpp = pprule; + tacobj_body = (ids, tac); + } in + Lib.add_anonymous_leaf (inTacticGrammar tacobj) + +(**********************************************************************) +(* ML Tactic entries *) + +type ml_tactic_grammar_obj = { + mltacobj_name : Tacexpr.ml_tactic_name; + (** ML-side unique name *) + mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list; + (** Grammar rules generating the ML tactic. *) +} + +exception NonEmptyArgument + +(** ML tactic notations whose use can be restricted to an identifier are added + as true Ltac entries. *) +let extend_atomic_tactic name entries = + let open Tacexpr in + let map_prod prods = + let (hd, rem) = match prods with + | GramTerminal s :: rem -> (s, rem) + | _ -> assert false (** Not handled by the ML extension syntax *) + in + let empty_value = function + | GramTerminal s -> raise NonEmptyArgument + | GramNonTerminal (_, typ, e) -> + let Genarg.Rawwit wit = typ in + let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in + let default = epsilon_value inj e in + match default with + | None -> raise NonEmptyArgument + | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + in + try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None + in + let entries = List.map map_prod entries in + let add_atomic i args = match args with + | None -> () + | Some (id, args) -> + let args = List.map (fun a -> Tacexp a) args in + let entry = { mltac_name = name; mltac_index = i } in + let body = TacML (Loc.ghost, entry, args) in + Tacenv.register_ltac false false (Names.Id.of_string id) body + in + List.iteri add_atomic entries + +let cache_ml_tactic_notation (_, obj) = + extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod + +let open_ml_tactic_notation i obj = + if Int.equal i 1 then cache_ml_tactic_notation obj + +let inMLTacticGrammar : ml_tactic_grammar_obj -> obj = + declare_object { (default_object "MLTacticGrammar") with + open_function = open_ml_tactic_notation; + cache_function = cache_ml_tactic_notation; + classify_function = (fun o -> Substitute o); + subst_function = (fun (_, o) -> o); + } + +let add_ml_tactic_notation name prods = + let obj = { + mltacobj_name = name; + mltacobj_prod = prods; + } in + Lib.add_anonymous_leaf (inMLTacticGrammar obj); + extend_atomic_tactic name prods + +(** Command *) + + +type tacdef_kind = + | NewTac of Id.t + | UpdateTac of Nametab.ltac_constant + +let is_defined_tac kn = + try ignore (Tacenv.interp_ltac kn); true with Not_found -> false + +let register_ltac local tacl = + let map tactic_body = + match tactic_body with + | TacticDefinition ((loc,id), body) -> + let kn = Lib.make_kn id in + let id_pp = pr_id id in + let () = if is_defined_tac kn then + Errors.user_err_loc (loc, "", + str "There is already an Ltac named " ++ id_pp ++ str".") + in + let is_primitive = + try + match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with + | Tacexpr.TacArg _ -> false + | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) + with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) + in + let () = if is_primitive then + msg_warning (str "The Ltac name " ++ id_pp ++ + str " may be unusable because of a conflict with a notation.") + in + NewTac id, body + | TacticRedefinition (ident, body) -> + let loc = loc_of_reference ident in + let kn = + try Nametab.locate_tactic (snd (qualid_of_reference ident)) + with Not_found -> + Errors.user_err_loc (loc, "", + str "There is no Ltac named " ++ pr_reference ident ++ str ".") + in + UpdateTac kn, body + in + let rfun = List.map map tacl in + let recvars = + let fold accu (op, _) = match op with + | UpdateTac _ -> accu + | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu + in + List.fold_left fold [] rfun + in + let ist = Tacintern.make_empty_glob_sign () in + let map (name, body) = + let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in + (name, body) + in + let defs () = + (** Register locally the tactic to handle recursivity. This function affects + the whole environment, so that we transactify it afterwards. *) + let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in + let () = List.iter iter_rec recvars in + List.map map rfun + in + let defs = Future.transactify defs () in + let iter (def, tac) = match def with + | NewTac id -> + Tacenv.register_ltac false local id tac; + Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined") + | UpdateTac kn -> + Tacenv.redefine_ltac local kn tac; + let name = Nametab.shortest_qualid_of_tactic kn in + Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined") + in + List.iter iter defs diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli new file mode 100644 index 0000000000..3cf0bc5cc9 --- /dev/null +++ b/ltac/tacentries.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + unit + +val add_ml_tactic_notation : ml_tactic_name -> + Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit + +val register_ltac : bool -> Vernacexpr.tacdef_body list -> unit diff --git a/ltac/tacenv.ml b/ltac/tacenv.ml new file mode 100644 index 0000000000..d2d3f3117f --- /dev/null +++ b/ltac/tacenv.ml @@ -0,0 +1,145 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Errors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) + +let check_alias key = KNmap.mem key !alias_map + +(** ML tactic extensions (TacML) *) + +type ml_tactic = + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic + +module MLName = +struct + type t = ml_tactic_name + let compare tac1 tac2 = + let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in + if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin + else c +end + +module MLTacMap = Map.Make(MLName) + +let pr_tacname t = + str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic + +let tac_tab = ref MLTacMap.empty + +let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) = + let () = + if MLTacMap.mem s !tac_tab then + if overwrite then + let () = tac_tab := MLTacMap.remove s !tac_tab in + msg_warning (str "Overwriting definition of tactic " ++ pr_tacname s) + else + Errors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") + in + tac_tab := MLTacMap.add s t !tac_tab + +let interp_ml_tactic { mltac_name = s; mltac_index = i } = + try + let tacs = MLTacMap.find s !tac_tab in + let () = if Array.length tacs <= i then raise Not_found in + tacs.(i) + with Not_found -> + Errors.errorlabstrm "" + (str "The tactic " ++ pr_tacname s ++ str " is not installed.") + +(***************************************************************************) +(* Tactic registration *) + +(* Summary and Object declaration *) + +open Nametab +open Libobject + +type ltac_entry = { + tac_for_ml : bool; + tac_body : glob_tactic_expr; + tac_redef : ModPath.t list; +} + +let mactab = + Summary.ref (KNmap.empty : ltac_entry KNmap.t) + ~name:"tactic-definition" + +let ltac_entries () = !mactab + +let interp_ltac r = (KNmap.find r !mactab).tac_body + +let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml + +let add kn b t = + let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in + mactab := KNmap.add kn entry !mactab + +let replace kn path t = + let (path, _, _) = KerName.repr path in + let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in + mactab := KNmap.modify kn entry !mactab + +let load_md i ((sp, kn), (local, id, b, t)) = match id with +| None -> + let () = if not local then Nametab.push_tactic (Until i) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let open_md i ((sp, kn), (local, id, b, t)) = match id with +| None -> + let () = if not local then Nametab.push_tactic (Exactly i) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let cache_md ((sp, kn), (local, id ,b, t)) = match id with +| None -> + let () = Nametab.push_tactic (Until 1) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let subst_kind subst id = match id with +| None -> None +| Some kn -> Some (Mod_subst.subst_kn subst kn) + +let subst_md (subst, (local, id, b, t)) = + (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t) + +let classify_md (local, _, _, _ as o) = Substitute o + +let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = + declare_object {(default_object "TAC-DEFINITION") with + cache_function = cache_md; + load_function = load_md; + open_function = open_md; + subst_function = subst_md; + classify_function = classify_md} + +let register_ltac for_ml local id tac = + ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac))) + +let redefine_ltac local kn tac = + Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) diff --git a/ltac/tacenv.mli b/ltac/tacenv.mli new file mode 100644 index 0000000000..88b54993b1 --- /dev/null +++ b/ltac/tacenv.mli @@ -0,0 +1,74 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* alias_tactic -> unit +(** Register a tactic alias. *) + +val interp_alias : alias -> alias_tactic +(** Recover the the body of an alias. Raises an anomaly if it does not exist. *) + +val check_alias : alias -> bool +(** Returns [true] if an alias is defined, false otherwise. *) + +(** {5 Coq tactic definitions} *) + +val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit +(** Register a new Ltac with the given name and body. + + The first boolean indicates whether this is done from ML side, rather than + Coq side. If the second boolean flag is set to true, then this is a local + definition. It also puts the Ltac name in the nametab, so that it can be + used unqualified. *) + +val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit +(** Replace a Ltac with the given name and body. If the boolean flag is set + to true, then this is a local redefinition. *) + +val interp_ltac : KerName.t -> glob_tactic_expr +(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *) + +val is_ltac_for_ml_tactic : KerName.t -> bool +(** Whether the tactic is defined from ML-side *) + +type ltac_entry = { + tac_for_ml : bool; + (** Whether the tactic is defined from ML-side *) + tac_body : glob_tactic_expr; + (** The current body of the tactic *) + tac_redef : ModPath.t list; + (** List of modules redefining the tactic in reverse chronological order *) +} + +val ltac_entries : unit -> ltac_entry KNmap.t +(** Low-level access to all Ltac entries currently defined. *) + +(** {5 ML tactic extensions} *) + +type ml_tactic = + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic +(** Type of external tactics, used by [TacML]. *) + +val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit +(** Register an external tactic. *) + +val interp_ml_tactic : ml_tactic_entry -> ml_tactic +(** Get the named tactic. Raises a user error if it does not exist. *) diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml new file mode 100644 index 0000000000..a75805b4f8 --- /dev/null +++ b/ltac/tacintern.ml @@ -0,0 +1,821 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Anonymous + | Name id -> Name (intern_ident l ist id) + +let strict_check = ref false + +let adjust_loc loc = if !strict_check then dloc else loc + +(* Globalize a name which must be bound -- actually just check it is bound *) +let intern_hyp ist (loc,id as locid) = + if not !strict_check then + locid + else if find_ident id ist then + (dloc,id) + else + Pretype_errors.error_var_not_found_loc loc id + +let intern_or_var f ist = function + | ArgVar locid -> ArgVar (intern_hyp ist locid) + | ArgArg x -> ArgArg (f x) + +let intern_int_or_var = intern_or_var (fun (n : int) -> n) +let intern_string_or_var = intern_or_var (fun (s : string) -> s) + +let intern_global_reference ist = function + | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) + | r -> + let loc,_ as lqid = qualid_of_reference r in + try ArgArg (loc,locate_global_with_alias lqid) + with Not_found -> error_global_not_found_loc lqid + +let intern_ltac_variable ist = function + | Ident (loc,id) -> + if find_var id ist then + (* A local variable of any type *) + ArgVar (loc,id) + else raise Not_found + | _ -> + raise Not_found + +let intern_constr_reference strict ist = function + | Ident (_,id) as r when not strict && find_hyp id ist -> + GVar (dloc,id), Some (CRef (r,None)) + | Ident (_,id) as r when find_var id ist -> + GVar (dloc,id), if strict then None else Some (CRef (r,None)) + | r -> + let loc,_ as lqid = qualid_of_reference r in + GRef (loc,locate_global_with_alias lqid,None), + if strict then None else Some (CRef (r,None)) + +let intern_move_location ist = function + | MoveAfter id -> MoveAfter (intern_hyp ist id) + | MoveBefore id -> MoveBefore (intern_hyp ist id) + | MoveFirst -> MoveFirst + | MoveLast -> MoveLast + +(* Internalize an isolated reference in position of tactic *) + +let intern_isolated_global_tactic_reference r = + let (loc,qid) = qualid_of_reference r in + TacCall (loc,ArgArg (loc,locate_tactic qid),[]) + +let intern_isolated_tactic_reference strict ist r = + (* An ltac reference *) + try Reference (intern_ltac_variable ist r) + with Not_found -> + (* A global tactic *) + try intern_isolated_global_tactic_reference r + with Not_found -> + (* Tolerance for compatibility, allow not to use "constr:" *) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + with Not_found -> + (* Reference not found *) + error_global_not_found_loc (qualid_of_reference r) + +(* Internalize an applied tactic reference *) + +let intern_applied_global_tactic_reference r = + let (loc,qid) = qualid_of_reference r in + ArgArg (loc,locate_tactic qid) + +let intern_applied_tactic_reference ist r = + (* An ltac reference *) + try intern_ltac_variable ist r + with Not_found -> + (* A global tactic *) + try intern_applied_global_tactic_reference r + with Not_found -> + (* Reference not found *) + error_global_not_found_loc (qualid_of_reference r) + +(* Intern a reference parsed in a non-tactic entry *) + +let intern_non_tactic_reference strict ist r = + (* An ltac reference *) + try Reference (intern_ltac_variable ist r) + with Not_found -> + (* A constr reference *) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + with Not_found -> + (* Tolerance for compatibility, allow not to use "ltac:" *) + try intern_isolated_global_tactic_reference r + with Not_found -> + (* By convention, use IntroIdentifier for unbound ident, when not in a def *) + match r with + | Ident (loc,id) when not strict -> + let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in + TacGeneric ipat + | _ -> + (* Reference not found *) + error_global_not_found_loc (qualid_of_reference r) + +let intern_message_token ist = function + | (MsgString _ | MsgInt _ as x) -> x + | MsgIdent id -> MsgIdent (intern_hyp ist id) + +let intern_message ist = List.map (intern_message_token ist) + +let intern_quantified_hypothesis ist = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + (* Uncomment to disallow "intros until n" in ltac when n is not bound *) + NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) + +let intern_binding_name ist x = + (* We use identifier both for variables and binding names *) + (* Todo: consider the body of the lemma to which the binding refer + and if a term w/o ltac vars, check the name is indeed quantified *) + x + +let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c = + let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in + let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in + let ltacvars = { + Constrintern.ltac_vars = lfun; + ltac_bound = Id.Set.empty; + } in + let c' = + warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c + in + (c',if !strict_check then None else Some c) + +let intern_constr = intern_constr_gen false false +let intern_type = intern_constr_gen false true + +(* Globalize bindings *) +let intern_binding ist (loc,b,c) = + (loc,intern_binding_name ist b,intern_constr ist c) + +let intern_bindings ist = function + | NoBindings -> NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l) + | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l) + +let intern_constr_with_bindings ist (c,bl) = + (intern_constr ist c, intern_bindings ist bl) + +let intern_constr_with_bindings_arg ist (clear,c) = + (clear,intern_constr_with_bindings ist c) + +let rec intern_intro_pattern lf ist = function + | loc, IntroNaming pat -> + loc, IntroNaming (intern_intro_pattern_naming lf ist pat) + | loc, IntroAction pat -> + loc, IntroAction (intern_intro_pattern_action lf ist pat) + | loc, IntroForthcoming _ as x -> x + +and intern_intro_pattern_naming lf ist = function + | IntroIdentifier id -> + IntroIdentifier (intern_ident lf ist id) + | IntroFresh id -> + IntroFresh (intern_ident lf ist id) + | IntroAnonymous as x -> x + +and intern_intro_pattern_action lf ist = function + | IntroOrAndPattern l -> + IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) + | IntroInjection l -> + IntroInjection (List.map (intern_intro_pattern lf ist) l) + | IntroWildcard | IntroRewrite _ as x -> x + | IntroApplyOn (c,pat) -> + IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) + +and intern_or_and_intro_pattern lf ist = function + | IntroAndPattern l -> + IntroAndPattern (List.map (intern_intro_pattern lf ist) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) + +let intern_or_and_intro_pattern_loc lf ist = function + | ArgVar (_,id) as x -> + if find_var id ist then x + else error "Disjunctive/conjunctive introduction pattern expected." + | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) + +let intern_intro_pattern_naming_loc lf ist (loc,pat) = + (loc,intern_intro_pattern_naming lf ist pat) + + (* TODO: catch ltac vars *) +let intern_induction_arg ist = function + | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c) + | clear,ElimOnAnonHyp n as x -> x + | clear,ElimOnIdent (loc,id) -> + if !strict_check then + (* If in a defined tactic, no intros-until *) + match intern_constr ist (CRef (Ident (dloc,id), None)) with + | GVar (loc,id),_ -> clear,ElimOnIdent (loc,id) + | c -> clear,ElimOnConstr (c,NoBindings) + else + clear,ElimOnIdent (loc,id) + +let short_name = function + | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id) + | _ -> None + +let intern_evaluable_global_reference ist r = + let lqid = qualid_of_reference r in + try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) + with Not_found -> + match r with + | Ident (loc,id) when not !strict_check -> EvalVarRef id + | _ -> error_global_not_found_loc lqid + +let intern_evaluable_reference_or_by_notation ist = function + | AN r -> intern_evaluable_global_reference ist r + | ByNotation (loc,ntn,sc) -> + evaluable_of_global_reference ist.genv + (Notation.interp_notation_as_global_reference loc + (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) + +(* Globalize a reduction expression *) +let intern_evaluable ist = function + | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) + | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist -> + ArgArg (EvalVarRef id, Some (loc,id)) + | r -> + let e = intern_evaluable_reference_or_by_notation ist r in + let na = short_name r in + ArgArg (e,na) + +let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) + +let intern_flag ist red = + { red with rConst = List.map (intern_evaluable ist) red.rConst } + +let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c) + +let intern_constr_pattern ist ~as_type ~ltacvars pc = + let ltacvars = { + Constrintern.ltac_vars = ltacvars; + ltac_bound = Id.Set.empty; + } in + let metas,pat = Constrintern.intern_constr_pattern + ist.genv ~as_type ~ltacvars pc + in + let c = intern_constr_gen true false ist pc in + metas,(c,pat) + +let dummy_pat = PRel 0 + +let intern_typed_pattern ist p = + (* we cannot ensure in non strict mode that the pattern is closed *) + (* keeping a constr_expr copy is too complicated and we want anyway to *) + (* type it, so we remember the pattern as a glob_constr only *) + (intern_constr_gen true false ist p,dummy_pat) + +let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = + let interp_ref r = + try Inl (intern_evaluable ist r) + with e when Logic.catchable_exception e -> + (* Compatibility. In practice, this means that the code above + is useless. Still the idea of having either an evaluable + ref or a pattern seems interesting, with "head" reduction + in case of an evaluable ref, and "strong" reduction in the + subterm matched when a pattern *) + let loc = loc_of_smart_reference r in + let r = match r with + | AN r -> r + | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in + let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in + let c = Constrintern.interp_reference sign r in + match c with + | GRef (_,r,None) -> + Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) + | GVar (_,id) -> + let r = evaluable_of_global_reference ist.genv (VarRef id) in + Inl (ArgArg (r,None)) + | _ -> + Inr ((c,None),dummy_pat) in + (l, match p with + | Inl r -> interp_ref r + | Inr (CAppExpl(_,(None,r,None),[])) -> + (* We interpret similarly @ref and ref *) + interp_ref (AN r) + | Inr c -> + Inr (intern_typed_pattern ist c)) + +(* This seems fairly hacky, but it's the first way I've found to get proper + globalization of [unfold]. --adamc *) +let dump_glob_red_expr = function + | Unfold occs -> List.iter (fun (_, r) -> + try + Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + (Smartlocate.smart_global r) + with e when Errors.noncritical e -> ()) occs + | Cbv grf | Lazy grf -> + List.iter (fun r -> + try + Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + (Smartlocate.smart_global r) + with e when Errors.noncritical e -> ()) grf.rConst + | _ -> () + +let intern_red_expr ist = function + | Unfold l -> Unfold (List.map (intern_unfold ist) l) + | Fold l -> Fold (List.map (intern_constr ist) l) + | Cbv f -> Cbv (intern_flag ist f) + | Cbn f -> Cbn (intern_flag ist f) + | Lazy f -> Lazy (intern_flag ist f) + | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) + | Simpl (f,o) -> + Simpl (intern_flag ist f, + Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r + +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) + +let intern_hyp_list ist = List.map (intern_hyp ist) + +let intern_inversion_strength lf ist = function + | NonDepInversion (k,idl,ids) -> + NonDepInversion (k,intern_hyp_list ist idl, + Option.map (intern_or_and_intro_pattern_loc lf ist) ids) + | DepInversion (k,copt,ids) -> + DepInversion (k, Option.map (intern_constr ist) copt, + Option.map (intern_or_and_intro_pattern_loc lf ist) ids) + | InversionUsing (c,idl) -> + InversionUsing (intern_constr ist c, intern_hyp_list ist idl) + +(* Interprets an hypothesis name *) +let intern_hyp_location ist ((occs,id),hl) = + ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs, + intern_hyp ist id), hl) + +(* Reads a pattern *) +let intern_pattern ist ?(as_type=false) ltacvars = function + | Subterm (b,ido,pc) -> + let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in + ido, metas, Subterm (b,ido,pc) + | Term pc -> + let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in + None, metas, Term pc + +let intern_constr_may_eval ist = function + | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) + | ConstrContext (locid,c) -> + ConstrContext (intern_hyp ist locid,intern_constr ist c) + | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) + | ConstrTerm c -> ConstrTerm (intern_constr ist c) + +let name_cons accu = function +| Anonymous -> accu +| Name id -> Id.Set.add id accu + +let opt_cons accu = function +| None -> accu +| Some id -> Id.Set.add id accu + +(* Reads the hypotheses of a "match goal" rule *) +let rec intern_match_goal_hyps ist lfun = function + | (Hyp ((_,na) as locna,mp))::tl -> + let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in + let lfun' = name_cons (opt_cons lfun ido) na in + lfun', metas1@metas2, Hyp (locna,pat)::hyps + | (Def ((_,na) as locna,mv,mp))::tl -> + let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in + let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in + let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in + lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps + | [] -> lfun, [], [] + +(* Utilities *) +let extract_let_names lrc = + let fold accu ((loc, name), _) = + if Id.Set.mem name accu then user_err_loc + (loc, "glob_tactic", str "This variable is bound several times.") + else Id.Set.add name accu + in + List.fold_left fold Id.Set.empty lrc + +let clause_app f = function + { onhyps=None; concl_occs=nl } -> + { onhyps=None; concl_occs=nl } + | { onhyps=Some l; concl_occs=nl } -> + { onhyps=Some(List.map f l); concl_occs=nl} + +let map_raw wit f ist x = + in_gen (glbwit wit) (f ist (out_gen (rawwit wit) x)) + +(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) +let rec intern_atomic lf ist x = + match (x:raw_atomic_tactic_expr) with + (* Basic tactics *) + | TacIntroPattern l -> + TacIntroPattern (List.map (intern_intro_pattern lf ist) l) + | TacIntroMove (ido,hto) -> + TacIntroMove (Option.map (intern_ident lf ist) ido, + intern_move_location ist hto) + | TacExact c -> TacExact (intern_constr ist c) + | TacApply (a,ev,cb,inhyp) -> + TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, + Option.map (intern_in_hyp_as ist lf) inhyp) + | TacElim (ev,cb,cbo) -> + TacElim (ev,intern_constr_with_bindings_arg ist cb, + Option.map (intern_constr_with_bindings ist) cbo) + | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) + | TacMutualFix (id,n,l) -> + let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in + TacMutualFix (intern_ident lf ist id, n, List.map f l) + | TacMutualCofix (id,l) -> + let f (id,c) = (intern_ident lf ist id,intern_type ist c) in + TacMutualCofix (intern_ident lf ist id, List.map f l) + | TacAssert (b,otac,ipat,c) -> + TacAssert (b,Option.map (intern_pure_tactic ist) otac, + Option.map (intern_intro_pattern lf ist) ipat, + intern_constr_gen false (not (Option.is_empty otac)) ist c) + | TacGeneralize cl -> + TacGeneralize (List.map (fun (c,na) -> + intern_constr_with_occurrences ist c, + intern_name lf ist na) cl) + | TacLetTac (na,c,cls,b,eqpat) -> + let na = intern_name lf ist na in + TacLetTac (na,intern_constr ist c, + (clause_app (intern_hyp_location ist) cls),b, + (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) + + (* Derived basic tactics *) + | TacInductionDestruct (ev,isrec,(l,el)) -> + TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> + (intern_induction_arg ist c, + (Option.map (intern_intro_pattern_naming_loc lf ist) ipato, + Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), + Option.map (clause_app (intern_hyp_location ist)) cls)) l, + Option.map (intern_constr_with_bindings ist) el)) + | TacDoubleInduction (h1,h2) -> + let h1 = intern_quantified_hypothesis ist h1 in + let h2 = intern_quantified_hypothesis ist h2 in + TacDoubleInduction (h1,h2) + (* Context management *) + | TacRename l -> + TacRename (List.map (fun (id1,id2) -> + intern_hyp ist id1, + intern_hyp ist id2) l) + + (* Conversion *) + | TacReduce (r,cl) -> + dump_glob_red_expr r; + TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) + | TacChange (None,c,cl) -> + let is_onhyps = match cl.onhyps with + | None | Some [] -> true + | _ -> false + in + let is_onconcl = match cl.concl_occs with + | AllOccurrences | NoOccurrences -> true + | _ -> false + in + TacChange (None, + (if is_onhyps && is_onconcl + then intern_type ist c else intern_constr ist c), + clause_app (intern_hyp_location ist) cl) + | TacChange (Some p,c,cl) -> + TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, + clause_app (intern_hyp_location ist) cl) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + TacRewrite + (ev, + List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, + clause_app (intern_hyp_location ist) cl, + Option.map (intern_pure_tactic ist) by) + | TacInversion (inv,hyp) -> + TacInversion (intern_inversion_strength lf ist inv, + intern_quantified_hypothesis ist hyp) + +and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) + +and intern_tactic_seq onlytac ist = function + | TacAtom (loc,t) -> + let lf = ref ist.ltacvars in + let t = intern_atomic lf ist t in + !lf, TacAtom (adjust_loc loc, t) + | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) + | TacLetIn (isrec,l,u) -> + let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in + let ist' = { ist with ltacvars } in + let l = List.map (fun (n,b) -> + (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in + ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) + + | TacMatchGoal (lz,lr,lmr) -> + ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr) + | TacMatch (lz,c,lmr) -> + ist.ltacvars, + TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) + | TacId l -> ist.ltacvars, TacId (intern_message ist l) + | TacFail (g,n,l) -> + ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l) + | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac) + | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac) + | TacAbstract (tac,s) -> + ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s) + | TacThen (t1,t2) -> + let lfun', t1 = intern_tactic_seq onlytac ist t1 in + let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in + lfun'', TacThen (t1,t2) + | TacDispatch tl -> + ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl) + | TacExtendTac (tf,t,tl) -> + ist.ltacvars , + TacExtendTac (Array.map (intern_pure_tactic ist) tf, + intern_pure_tactic ist t, + Array.map (intern_pure_tactic ist) tl) + | TacThens3parts (t1,tf,t2,tl) -> + let lfun', t1 = intern_tactic_seq onlytac ist t1 in + let ist' = { ist with ltacvars = lfun' } in + (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) + lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, + Array.map (intern_pure_tactic ist') tl) + | TacThens (t,tl) -> + let lfun', t = intern_tactic_seq true ist t in + let ist' = { ist with ltacvars = lfun' } in + (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) + lfun', TacThens (t, List.map (intern_pure_tactic ist') tl) + | TacDo (n,tac) -> + ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac) + | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac) + | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac) + | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac) + | TacTimeout (n,tac) -> + ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac) + | TacTime (s,tac) -> + ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac) + | TacOr (tac1,tac2) -> + ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) + | TacOnce tac -> + ist.ltacvars, TacOnce (intern_pure_tactic ist tac) + | TacExactlyOnce tac -> + ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac) + | TacIfThenCatch (tac,tact,tace) -> + ist.ltacvars, + TacIfThenCatch ( + intern_pure_tactic ist tac, + intern_pure_tactic ist tact, + intern_pure_tactic ist tace) + | TacOrelse (tac1,tac2) -> + ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) + | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) + | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) + | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) + | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + + (* For extensions *) + | TacAlias (loc,s,l) -> + let l = List.map (intern_tacarg !strict_check false ist) l in + ist.ltacvars, TacAlias (loc,s,l) + | TacML (loc,opn,l) -> + let _ignore = Tacenv.interp_ml_tactic opn in + ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) + +and intern_tactic_as_arg loc onlytac ist a = + match intern_tacarg !strict_check onlytac ist a with + | TacCall _ | Reference _ + | TacGeneric _ as a -> TacArg (loc,a) + | Tacexp a -> a + | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> + if onlytac then error_tactic_expected loc else TacArg (loc,a) + +and intern_tactic_or_tacarg ist = intern_tactic false ist + +and intern_pure_tactic ist = intern_tactic true ist + +and intern_tactic_fun ist (var,body) = + let lfun = List.fold_left opt_cons ist.ltacvars var in + (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) + +and intern_tacarg strict onlytac ist = function + | Reference r -> intern_non_tactic_reference strict ist r + | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) + | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f + | TacCall (loc,f,l) -> + TacCall (loc, + intern_applied_tactic_reference ist f, + List.map (intern_tacarg !strict_check false ist) l) + | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) + | TacPretype c -> TacPretype (intern_constr ist c) + | TacNumgoals -> TacNumgoals + | Tacexp t -> Tacexp (intern_tactic onlytac ist t) + | TacGeneric arg -> + let arg = intern_genarg ist arg in + TacGeneric arg + +(* Reads the rules of a Match Context or a Match *) +and intern_match_rule onlytac ist = function + | (All tc)::tl -> + All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl) + | (Pat (rl,mp,tc))::tl -> + let {ltacvars=lfun; genv=env} = ist in + let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in + let ido,metas2,pat = intern_pattern ist lfun mp in + let fold accu x = Id.Set.add x accu in + let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in + let ltacvars = List.fold_left fold ltacvars metas2 in + let ist' = { ist with ltacvars } in + Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl) + | [] -> [] + +and intern_genarg ist (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = intern_genarg ist (in_gen (rawwit wit) x) in + out_gen (glbwit wit) ans + in + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with + | None -> in_gen (glbwit (wit_opt wit)) None + | Some x -> + let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in + in_gen (glbwit (wit_opt wit)) (Some s) + in + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in + let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) + +(** Other entry points *) + +let glob_tactic x = + Flags.with_option strict_check + (intern_pure_tactic (make_empty_glob_sign ())) x + +let glob_tactic_env l env x = + let ltacvars = + List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in + Flags.with_option strict_check + (intern_pure_tactic + { ltacvars; genv = env }) + x + +let split_ltac_fun = function + | TacFun (l,t) -> (l,t) + | t -> ([],t) + +let pr_ltac_fun_arg = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + +let print_ltac id = + try + let kn = Nametab.locate_tactic id in + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + let filter mp = + try Some (Nametab.shortest_qualid_of_module mp) + with Not_found -> None + in + let mods = List.map_filter filter tac.Tacenv.tac_redef in + let redefined = match mods with + | [] -> mt () + | mods -> + let redef = prlist_with_sep fnl pr_qualid mods in + fnl () ++ str "Redefined by:" ++ fnl () ++ redef + in + let l,t = split_ltac_fun tac.Tacenv.tac_body in + hv 2 ( + hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ + prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") + ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined + with + Not_found -> + errorlabstrm "print_ltac" + (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") + +(** Registering *) + +let lift intern = (); fun ist x -> (ist, intern ist x) + +let () = + let intern_intro_pattern ist pat = + let lf = ref Id.Set.empty in + let ans = intern_intro_pattern lf ist pat in + let ist = { ist with ltacvars = !lf } in + (ist, ans) + in + Genintern.register_intern0 wit_intro_pattern intern_intro_pattern + +let () = + let intern_clause ist cl = + let ans = clause_app (intern_hyp_location ist) cl in + (ist, ans) + in + Genintern.register_intern0 wit_clause_dft_concl intern_clause + +let intern_ident' ist id = + let lf = ref Id.Set.empty in + (ist, intern_ident lf ist id) + +let () = + Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_ref (lift intern_global_reference); + Genintern.register_intern0 wit_ident intern_ident'; + Genintern.register_intern0 wit_var (lift intern_hyp); + Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); + Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); + Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_red_expr (lift intern_red_expr); + Genintern.register_intern0 wit_bindings (lift intern_bindings); + Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); + Genintern.register_intern0 wit_constr_may_eval (lift intern_constr_may_eval); + () + +(***************************************************************************) +(* Backwarding recursive needs of tactic glob/interp/eval functions *) + +let _ = + let f l = + let ltacvars = + List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l + in + Flags.with_option strict_check + (intern_pure_tactic { (make_empty_glob_sign()) with ltacvars }) + in + Hook.set Hints.extern_intern_tac f diff --git a/ltac/tacintern.mli b/ltac/tacintern.mli new file mode 100644 index 0000000000..71ca354fa1 --- /dev/null +++ b/ltac/tacintern.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glob_sign + (** same as [fully_empty_glob_sign], but with [Global.env()] as + environment *) + +(** Main globalization functions *) + +val glob_tactic : raw_tactic_expr -> glob_tactic_expr + +val glob_tactic_env : + Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr + +(** Low-level variants *) + +val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr + +val intern_tactic_or_tacarg : + glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr + +val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr + +val intern_constr_with_bindings : + glob_sign -> constr_expr * constr_expr bindings -> + glob_constr_and_expr * glob_constr_and_expr bindings + +val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located + +(** Adds a globalization function for extra generic arguments *) + +val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument + +(** printing *) +val print_ltac : Libnames.qualid -> std_ppcmds + +(** Reduction expressions *) + +val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr +val dump_glob_red_expr : raw_red_expr -> unit + +(* Hooks *) +val strict_check : bool ref diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml new file mode 100644 index 0000000000..4506f81596 --- /dev/null +++ b/ltac/tacinterp.ml @@ -0,0 +1,2216 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + +let val_tag wit = val_tag (topwit wit) + +let pr_argument_type arg = + let Val.Dyn (tag, _) = arg in + Val.repr tag + +let safe_msgnl s = + Proofview.NonLogical.catch + (Proofview.NonLogical.print_debug (s++fnl())) + (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) + +type value = Val.t + +(** Abstract application, to print ltac functions *) +type appl = + | UnnamedAppl (** For generic applications: nothing is printed *) + | GlbAppl of (Names.kernel_name * Val.t list) list + (** For calls to global constants, some may alias other. *) +let push_appl appl args = + match appl with + | UnnamedAppl -> UnnamedAppl + | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) +let pr_generic arg = (** FIXME *) + let Val.Dyn (tag, _) = arg in + str"<" ++ Val.repr tag ++ str ">" +let pr_appl h vs = + Pptactic.pr_ltac_constant h ++ spc () ++ + Pp.prlist_with_sep spc pr_generic vs +let rec name_with_list appl t = + match appl with + | [] -> t + | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) +let name_if_glob appl t = + match appl with + | UnnamedAppl -> t + | GlbAppl l -> name_with_list l t +let combine_appl appl1 appl2 = + match appl1,appl2 with + | UnnamedAppl,a | a,UnnamedAppl -> a + | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1) + +(* Values for interpretation *) +type tacvalue = + | VFun of appl*ltac_trace * value Id.Map.t * + Id.t option list * glob_tactic_expr + | VRec of value Id.Map.t ref * glob_tactic_expr + +let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = + Genarg.create_arg "tacvalue" + +let of_tacvalue v = in_gen (topwit wit_tacvalue) v +let to_tacvalue v = out_gen (topwit wit_tacvalue) v + +(** More naming applications *) +let name_vfun appl vle = + let vle = Value.normalize vle in + if has_type vle (topwit wit_tacvalue) then + match to_tacvalue vle with + | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) + | _ -> vle + else vle + +module TacStore = Geninterp.TacStore + +let f_avoid_ids : Id.t list TacStore.field = TacStore.field () +(* ids inherited from the call context (needed to get fresh ids) *) +let f_debug : debug_info TacStore.field = TacStore.field () +let f_trace : ltac_trace TacStore.field = TacStore.field () + +(* Signature for interpretation: val_interp and interpretation functions *) +type interp_sign = Geninterp.interp_sign = { + lfun : value Id.Map.t; + extra : TacStore.t } + +let extract_trace ist = match TacStore.get ist.extra f_trace with +| None -> [] +| Some l -> l + +module Value = struct + + include Taccoerce.Value + + let of_closure ist tac = + let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in + of_tacvalue closure + + let cast_error wit v = + let pr_v = mt () in (** FIXME *) + let Val.Dyn (tag, _) = v in + let tag = Val.repr tag in + errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ tag + ++ str " while type " ++ Genarg.pr_argument_type (unquote (rawwit wit)) ++ str " was expected.") + + let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + + let try_prj wit v = match prj (val_tag wit) v with + | None -> cast_error wit v + | Some x -> x + + let rec val_cast : type a b c. (a, b, c) genarg_type -> Val.t -> c = + fun wit v -> match wit with + | ExtraArg _ -> try_prj wit v + | ListArg t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.List tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + List.map map v + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + | OptArg t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Opt tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + Option.map map v + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + | PairArg (t1, t2) -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Pair (tag1, tag2) -> + let (v1, v2) = v in + let v1 = Val.Dyn (tag1, v1) in + let v2 = Val.Dyn (tag2, v2) in + (val_cast t1 v1, val_cast t2 v2) + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + + let cast (Topwit wit) v = val_cast wit v + +end + +let print_top_val env v = mt () (** FIXME *) + +let dloc = Loc.ghost + +let catching_error call_trace fail (e, info) = + let inner_trace = + Option.default [] (Exninfo.get info ltac_trace_info) + in + if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info) + else begin + assert (Errors.noncritical e); (* preserved invariant *) + let new_trace = inner_trace @ call_trace in + let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in + fail located_exc + end + +let catch_error call_trace f x = + try f x + with e when Errors.noncritical e -> + let e = Errors.push e in + catching_error call_trace iraise e + +let catch_error_tac call_trace tac = + Proofview.tclORELSE + tac + (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) + +let curr_debug ist = match TacStore.get ist.extra f_debug with +| None -> DebugOff +| Some level -> level + +(** TODO: unify printing of generic Ltac values in case of coercion failure. *) + +(* Displays a value *) +let pr_value env v = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then str "a tactic" + else if has_type v (topwit wit_constr_context) then + let c = out_gen (topwit wit_constr_context) v in + match env with + | Some (env,sigma) -> pr_lconstr_env env sigma c + | _ -> str "a term" + else if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + match env with + | Some (env,sigma) -> pr_lconstr_env env sigma c + | _ -> str "a term" + else if has_type v (topwit wit_constr_under_binders) then + let c = out_gen (topwit wit_constr_under_binders) v in + match env with + | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c + | _ -> str "a term" + else + str "a value of type" ++ spc () ++ pr_argument_type v + +let pr_closure env ist body = + let pp_body = Pptactic.pr_glob_tactic env body in + let pr_sep () = fnl () in + let pr_iarg (id, arg) = + let arg = pr_argument_type arg in + hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) + in + let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in + pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs + +let pr_inspect env expr result = + let pp_expr = Pptactic.pr_glob_tactic env expr in + let pp_result = + if has_type result (topwit wit_tacvalue) then + match to_tacvalue result with + | VFun (_,_, ist, ul, b) -> + let body = if List.is_empty ul then b else (TacFun (ul, b)) in + str "a closure with body " ++ fnl() ++ pr_closure env ist body + | VRec (ist, body) -> + str "a recursive closure" ++ fnl () ++ pr_closure env !ist body + else + let pp_type = pr_argument_type result in + str "an object of type" ++ spc () ++ pp_type + in + pp_expr ++ fnl() ++ str "this is " ++ pp_result + +(* Transforms an id into a constr if possible, or fails with Not_found *) +let constr_of_id env id = + Term.mkVar (let _ = Environ.lookup_named id env in id) + +(** Generic arguments : table of interpretation functions *) + +let push_trace call ist = match TacStore.get ist.extra f_trace with +| None -> [call] +| Some trace -> call :: trace + +let propagate_trace ist loc id v = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + let tacv = to_tacvalue v in + match tacv with + | VFun (appl,_,lfun,it,b) -> + let t = if List.is_empty it then b else TacFun (it,b) in + let ans = VFun (appl,push_trace(loc,LtacVarCall (id,t)) ist,lfun,it,b) in + of_tacvalue ans + | _ -> v + else v + +let append_trace trace v = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + match to_tacvalue v with + | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b)) + | _ -> v + else v + +(* Dynamically check that an argument is a tactic *) +let coerce_to_tactic loc id v = + let v = Value.normalize v in + let fail () = user_err_loc + (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") + in + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + let tacv = to_tacvalue v in + match tacv with + | VFun _ -> v + | _ -> fail () + else fail () + +let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) +let value_of_ident id = + in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) + +let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 + +let extend_values_with_bindings (ln,lm) lfun = + let of_cub c = match c with + | [], c -> Value.of_constr c + | _ -> in_gen (topwit wit_constr_under_binders) c + in + (* For compatibility, bound variables are visible only if no other + binding of the same name exists *) + let accu = Id.Map.map value_of_ident ln in + let accu = lfun +++ accu in + Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu + +(***************************************************************************) +(* Evaluation/interpretation *) + +let is_variable env id = + Id.List.mem id (ids_of_named_context (Environ.named_context env)) + +(* Debug reference *) +let debug = ref DebugOff + +(* Sets the debugger mode *) +let set_debug pos = debug := pos + +(* Gives the state of debug *) +let get_debug () = !debug + +let debugging_step ist pp = match curr_debug ist with + | DebugOn lev -> + safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl()) + | _ -> Proofview.NonLogical.return () + +let debugging_exception_step ist signal_anomaly e pp = + let explain_exc = + if signal_anomaly then explain_logic_error + else explain_logic_error_no_anomaly in + debugging_step ist (fun () -> + pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) + +let error_ltac_variable loc id env v s = + user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ + strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ + strbrk "which cannot be coerced to " ++ str s ++ str".") + +(* Raise Not_found if not in interpretation sign *) +let try_interp_ltac_var coerce ist env (loc,id) = + let v = Id.Map.find id ist.lfun in + try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s + +let interp_ltac_var coerce ist env locid = + try try_interp_ltac_var coerce ist env locid + with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") + +let interp_ident ist env sigma id = + try try_interp_ltac_var (coerce_to_ident false env) ist (Some (env,sigma)) (dloc,id) + with Not_found -> id + +let pf_interp_ident id gl = interp_ident id (pf_env gl) (project gl) + +(* Interprets an optional identifier, bound or fresh *) +let interp_name ist env sigma = function + | Anonymous -> Anonymous + | Name id -> Name (interp_ident ist env sigma id) + +let interp_intro_pattern_var loc ist env sigma id = + try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id) + with Not_found -> IntroNaming (IntroIdentifier id) + +let interp_intro_pattern_naming_var loc ist env sigma id = + try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) + with Not_found -> IntroIdentifier id + +let interp_int ist locid = + try try_interp_ltac_var coerce_to_int ist None locid + with Not_found -> + user_err_loc(fst locid,"interp_int", + str "Unbound variable " ++ pr_id (snd locid) ++ str".") + +let interp_int_or_var ist = function + | ArgVar locid -> interp_int ist locid + | ArgArg n -> n + +let interp_int_or_var_as_list ist = function + | ArgVar (_,id as locid) -> + (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) + | ArgArg n as x -> [x] + +let interp_int_or_var_list ist l = + List.flatten (List.map (interp_int_or_var_as_list ist) l) + +(* Interprets a bound variable (especially an existing hypothesis) *) +let interp_hyp ist env sigma (loc,id as locid) = + (* Look first in lfun for a value coercible to a variable *) + try try_interp_ltac_var (coerce_to_hyp env) ist (Some (env,sigma)) locid + with Not_found -> + (* Then look if bound in the proof context at calling time *) + if is_variable env id then id + else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id)) + +let interp_hyp_list_as_list ist env sigma (loc,id as x) = + try coerce_to_hyp_list env (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x] + +let interp_hyp_list ist env sigma l = + List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l) + +let interp_move_location ist env sigma = function + | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id) + | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id) + | MoveFirst -> MoveFirst + | MoveLast -> MoveLast + +let interp_reference ist env sigma = function + | ArgArg (_,r) -> r + | ArgVar (loc, id) -> + try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id) + with Not_found -> + try + VarRef (get_id (Environ.lookup_named id env)) + with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + +let try_interp_evaluable env (loc, id) = + let v = Environ.lookup_named id env in + match v with + | LocalDef _ -> EvalVarRef id + | _ -> error_not_evaluable (VarRef id) + +let interp_evaluable ist env sigma = function + | ArgArg (r,Some (loc,id)) -> + (* Maybe [id] has been introduced by Intro-like tactics *) + begin + try try_interp_evaluable env (loc, id) + with Not_found -> + match r with + | EvalConstRef _ -> r + | _ -> error_global_not_found_loc loc (qualid_of_ident id) + end + | ArgArg (r,None) -> r + | ArgVar (loc, id) -> + try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) + with Not_found -> + try try_interp_evaluable env (loc, id) + with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) + +(* Interprets an hypothesis name *) +let interp_occurrences ist occs = + Locusops.occurrences_map (interp_int_or_var_list ist) occs + +let interp_hyp_location ist env sigma ((occs,id),hl) = + ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl) + +let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) = + match occs,hl with + | AllOccurrences,InHyp -> + List.map (fun id -> ((AllOccurrences,id),InHyp)) + (interp_hyp_list_as_list ist env sigma id) + | _,_ -> [interp_hyp_location ist env sigma x] + +let interp_hyp_location_list ist env sigma l = + List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l) + +let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause = + { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol; + concl_occs=interp_occurrences ist occs } + +(* Interpretation of constructions *) + +(* Extract the constr list from lfun *) +let extract_ltac_constr_values ist env = + let fold id v accu = + try + let c = coerce_to_constr env v in + Id.Map.add id c accu + with CannotCoerceTo _ -> accu + in + Id.Map.fold fold ist.lfun Id.Map.empty +(** ppedrot: I have changed the semantics here. Before this patch, closure was + implemented as a list and a variable could be bound several times with + different types, resulting in its possible appearance on both sides. This + could barely be defined as a feature... *) + +(* Extract the identifier list from lfun: join all branches (what to do else?)*) +let rec intropattern_ids (loc,pat) = match pat with + | IntroNaming (IntroIdentifier id) -> [id] + | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> + List.flatten (List.map intropattern_ids (List.flatten ll)) + | IntroAction (IntroInjection l) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat + | IntroNaming (IntroAnonymous | IntroFresh _) + | IntroAction (IntroWildcard | IntroRewrite _) + | IntroForthcoming _ -> [] + +let extract_ids ids lfun = + let fold id v accu = + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + let (_, ipat) = out_gen (topwit wit_intro_pattern) v in + if Id.List.mem id ids then accu + else accu @ intropattern_ids (dloc, ipat) + else accu + in + Id.Map.fold fold lfun [] + +let default_fresh_id = Id.of_string "H" + +let interp_fresh_id ist env sigma l = + let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in + let avoid = match TacStore.get ist.extra f_avoid_ids with + | None -> [] + | Some l -> l + in + let avoid = (extract_ids ids ist.lfun) @ avoid in + let id = + if List.is_empty l then default_fresh_id + else + let s = + String.concat "" (List.map (function + | ArgArg s -> s + | ArgVar (_,id) -> Id.to_string (interp_ident ist env sigma id)) l) in + let s = if Lexer.is_keyword s then s^"0" else s in + Id.of_string s in + Tactics.fresh_id_in_env avoid id env + +(* Extract the uconstr list from lfun *) +let extract_ltac_constr_context ist env = + let open Glob_term in + let add_uconstr id env v map = + try Id.Map.add id (coerce_to_uconstr env v) map + with CannotCoerceTo _ -> map + in + let add_constr id env v map = + try Id.Map.add id (coerce_to_constr env v) map + with CannotCoerceTo _ -> map + in + let add_ident id env v map = + try Id.Map.add id (coerce_to_ident false env v) map + with CannotCoerceTo _ -> map + in + let fold id v {idents;typed;untyped} = + let idents = add_ident id env v idents in + let typed = add_constr id env v typed in + let untyped = add_uconstr id env v untyped in + { idents ; typed ; untyped } + in + let empty = { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in + Id.Map.fold fold ist.lfun empty + +(** Significantly simpler than [interp_constr], to interpret an + untyped constr, it suffices to adjoin a closure environment. *) +let interp_uconstr ist env = function + | (term,None) -> + { closure = extract_ltac_constr_context ist env ; term } + | (_,Some ce) -> + let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env in + let ltacvars = { + Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); + ltac_bound = Id.Map.domain ist.lfun; + } in + { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } + +let interp_gen kind ist allow_patvar flags env sigma (c,ce) = + let constrvars = extract_ltac_constr_context ist env in + let vars = { + Pretyping.ltac_constrs = constrvars.typed; + Pretyping.ltac_uconstrs = constrvars.untyped; + Pretyping.ltac_idents = constrvars.idents; + Pretyping.ltac_genargs = ist.lfun; + } in + let c = match ce with + | None -> c + (* If at toplevel (ce<>None), the error can be due to an incorrect + context at globalization time: we retype with the now known + intros/lettac/inversion hypothesis names *) + | Some c -> + let constr_context = + Id.Set.union + (Id.Map.domain constrvars.typed) + (Id.Set.union + (Id.Map.domain constrvars.untyped) + (Id.Map.domain constrvars.idents)) + in + let ltacvars = { + ltac_vars = constr_context; + ltac_bound = Id.Map.domain ist.lfun; + } in + let kind_for_intern = + match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in + intern_gen kind_for_intern ~allow_patvar ~ltacvars env c + in + let trace = + push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist in + let (evd,c) = + catch_error trace (understand_ltac flags env sigma vars kind) c + in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (db_constr (curr_debug ist) env c); + (evd,c) + +let constr_flags = { + use_typeclasses = true; + use_unif_heuristics = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = true; + expand_evars = true } + +(* Interprets a constr; expects evars to be solved *) +let interp_constr_gen kind ist env sigma c = + interp_gen kind ist false constr_flags env sigma c + +let interp_constr = interp_constr_gen WithoutTypeConstraint + +let interp_type = interp_constr_gen IsType + +let open_constr_use_classes_flags = { + use_typeclasses = true; + use_unif_heuristics = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true } + +let open_constr_no_classes_flags = { + use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true } + +let pure_open_constr_flags = { + use_typeclasses = false; + use_unif_heuristics = true; + use_hook = None; + fail_evar = false; + expand_evars = false } + +(* Interprets an open constr *) +let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist = + let flags = + if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags + else open_constr_use_classes_flags in + interp_gen expected_type ist false flags + +let interp_pure_open_constr ist = + interp_gen WithoutTypeConstraint ist false pure_open_constr_flags + +let interp_typed_pattern ist env sigma (c,_) = + let sigma, c = + interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in + pattern_of_constr env sigma c + +(* Interprets a constr expression casted by the current goal *) +let pf_interp_casted_constr ist gl c = + interp_constr_gen (OfType (pf_concl gl)) ist (pf_env gl) (project gl) c + +(* Interprets a constr expression *) +let pf_interp_constr ist gl = + interp_constr ist (pf_env gl) (project gl) + +let new_interp_constr ist c k = + let open Proofview in + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let (sigma, c) = interp_constr ist (Goal.env gl) (project gl) c in + Sigma.Unsafe.of_pair (k c, sigma) + end } + +let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = + let try_expand_ltac_var sigma x = + try match dest_fun x with + | GVar (_,id), _ -> + let v = Id.Map.find id ist.lfun in + sigma, List.map inj_fun (coerce_to_constr_list env v) + | _ -> + raise Not_found + with CannotCoerceTo _ | Not_found -> + (* dest_fun, List.assoc may raise Not_found *) + let sigma, c = interp_fun ist env sigma x in + sigma, [c] in + let sigma, l = List.fold_map try_expand_ltac_var sigma l in + sigma, List.flatten l + +let interp_constr_list ist env sigma c = + interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c + +let interp_open_constr_list = + interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr + +(* Interprets a type expression *) +let pf_interp_type ist env sigma = + interp_type ist env sigma + +(* Fully evaluate an untyped constr *) +let type_uconstr ?(flags = constr_flags) + ?(expected_type = WithoutTypeConstraint) ist c = + { delayed = begin fun env sigma -> + let open Pretyping in + let { closure; term } = c in + let vars = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = ist.lfun; + } in + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = understand_ltac flags env sigma vars expected_type term in + Sigma.Unsafe.of_pair (c, sigma) + end } + + +(* Interprets a reduction expression *) +let interp_unfold ist env sigma (occs,qid) = + (interp_occurrences ist occs,interp_evaluable ist env sigma qid) + +let interp_flag ist env sigma red = + { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst } + +let interp_constr_with_occurrences ist env sigma (occs,c) = + let (sigma,c_interp) = interp_constr ist env sigma c in + sigma , (interp_occurrences ist occs, c_interp) + +let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = + let p = match a with + | Inl (ArgVar (loc,id)) -> + (* This is the encoding of an ltac var supposed to be bound + prioritary to an evaluable reference and otherwise to a constr + (it is an encoding to satisfy the "union" type given to Simpl) *) + let coerce_eval_ref_or_constr x = + try Inl (coerce_to_evaluable_ref env x) + with CannotCoerceTo _ -> + let c = coerce_to_closed_constr env x in + Inr (pattern_of_constr env sigma c) in + (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) + with Not_found -> + error_global_not_found_loc loc (qualid_of_ident id)) + | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) + | Inr c -> Inr (interp_typed_pattern ist env sigma c) in + interp_occurrences ist occs, p + +let interp_constr_with_occurrences_and_name_as_list = + interp_constr_in_compound_list + (fun c -> ((AllOccurrences,c),Anonymous)) + (function ((occs,c),Anonymous) when occs == AllOccurrences -> c + | _ -> raise Not_found) + (fun ist env sigma (occ_c,na) -> + let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in + sigma, (c_interp, + interp_name ist env sigma na)) + +let interp_red_expr ist env sigma = function + | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l) + | Fold l -> + let (sigma,l_interp) = interp_constr_list ist env sigma l in + sigma , Fold l_interp + | Cbv f -> sigma , Cbv (interp_flag ist env sigma f) + | Cbn f -> sigma , Cbn (interp_flag ist env sigma f) + | Lazy f -> sigma , Lazy (interp_flag ist env sigma f) + | Pattern l -> + let (sigma,l_interp) = + Evd.MonadR.List.map_right + (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma + in + sigma , Pattern l_interp + | Simpl (f,o) -> + sigma , Simpl (interp_flag ist env sigma f, + Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | CbvVm o -> + sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | CbvNative o -> + sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | (Red _ | Hnf | ExtraRedExpr _ as r) -> sigma , r + +let interp_may_eval f ist env sigma = function + | ConstrEval (r,c) -> + let (sigma,redexp) = interp_red_expr ist env sigma r in + let (sigma,c_interp) = f ist env sigma c in + let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in + (Sigma.to_evar_map sigma, c) + | ConstrContext ((loc,s),c) -> + (try + let (sigma,ic) = f ist env sigma c in + let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in + let evdref = ref sigma in + let c = subst_meta [Constr_matching.special_meta,ic] ctxt in + let c = Typing.e_solve_evars env evdref c in + !evdref , c + with + | Not_found -> + user_err_loc (loc, "interp_may_eval", + str "Unbound context identifier" ++ pr_id s ++ str".")) + | ConstrTypeOf c -> + let (sigma,c_interp) = f ist env sigma c in + Typing.type_of ~refresh:true env sigma c_interp + | ConstrTerm c -> + try + f ist env sigma c + with reraise -> + let reraise = Errors.push reraise in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> + str"interpretation of term " ++ pr_glob_constr_env env (fst c))); + iraise reraise + +(* Interprets a constr expression possibly to first evaluate *) +let interp_constr_may_eval ist env sigma c = + let (sigma,csr) = + try + interp_may_eval interp_constr ist env sigma c + with reraise -> + let reraise = Errors.push reraise in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term")); + iraise reraise + in + begin + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (db_constr (curr_debug ist) env csr); + sigma , csr + end + +(** TODO: should use dedicated printers *) +let rec message_of_value v = + let v = Value.normalize v in + let open Ftactic in + if has_type v (topwit wit_tacvalue) then + Ftactic.return (str "") + else if has_type v (topwit wit_constr) then + let v = out_gen (topwit wit_constr) v in + Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) v) end } + else if has_type v (topwit wit_constr_under_binders) then + let c = out_gen (topwit wit_constr_under_binders) v in + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) + end } + else if has_type v (topwit wit_unit) then + Ftactic.return (str "()") + else if has_type v (topwit wit_int) then + Ftactic.return (int (out_gen (topwit wit_int) v)) + else if has_type v (topwit wit_intro_pattern) then + let p = out_gen (topwit wit_intro_pattern) v in + let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) + end } + else if has_type v (topwit wit_constr_context) then + let c = out_gen (topwit wit_constr_context) v in + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) c) end } + else if has_type v (topwit wit_uconstr) then + let c = out_gen (topwit wit_uconstr) v in + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (pr_closed_glob_env (pf_env gl) + (project gl) c) + end } + else match Value.to_list v with + | Some l -> + Ftactic.List.map message_of_value l >>= fun l -> + Ftactic.return (prlist_with_sep spc (fun x -> x) l) + | None -> + let tag = pr_argument_type v in + Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) + +let interp_message_token ist = function + | MsgString s -> Ftactic.return (str s) + | MsgInt n -> Ftactic.return (int n) + | MsgIdent (loc,id) -> + let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in + match v with + | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found.")) + | Some v -> message_of_value v + +let interp_message ist l = + let open Ftactic in + Ftactic.List.map (interp_message_token ist) l >>= fun l -> + Ftactic.return (prlist_with_sep spc (fun x -> x) l) + +let rec interp_intro_pattern ist env sigma = function + | loc, IntroAction pat -> + let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in + sigma, (loc, IntroAction pat) + | loc, IntroNaming (IntroIdentifier id) -> + sigma, (loc, interp_intro_pattern_var loc ist env sigma id) + | loc, IntroNaming pat -> + sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat)) + | loc, IntroForthcoming _ as x -> sigma, x + +and interp_intro_pattern_naming loc ist env sigma = function + | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) + | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id + | IntroAnonymous as x -> x + +and interp_intro_pattern_action ist env sigma = function + | IntroOrAndPattern l -> + let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in + sigma, IntroOrAndPattern l + | IntroInjection l -> + let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in + sigma, IntroInjection l + | IntroApplyOn (c,ipat) -> + let c = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } in + let sigma,ipat = interp_intro_pattern ist env sigma ipat in + sigma, IntroApplyOn (c,ipat) + | IntroWildcard | IntroRewrite _ as x -> sigma, x + +and interp_or_and_intro_pattern ist env sigma = function + | IntroAndPattern l -> + let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in + sigma, IntroAndPattern l + | IntroOrPattern ll -> + let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in + sigma, IntroOrPattern ll + +and interp_intro_pattern_list_as_list ist env sigma = function + | [loc,IntroNaming (IntroIdentifier id)] as l -> + (try sigma, coerce_to_intro_pattern_list loc env (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> + List.fold_map (interp_intro_pattern ist env) sigma l) + | l -> List.fold_map (interp_intro_pattern ist env) sigma l + +let interp_intro_pattern_naming_option ist env sigma = function + | None -> None + | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat) + +let interp_or_and_intro_pattern_option ist env sigma = function + | None -> sigma, None + | Some (ArgVar (loc,id)) -> + (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with + | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) + | _ -> + raise (CannotCoerceTo "a disjunctive/conjunctive introduction pattern")) + | Some (ArgArg (loc,l)) -> + let sigma,l = interp_or_and_intro_pattern ist env sigma l in + sigma, Some (loc,l) + +let interp_intro_pattern_option ist env sigma = function + | None -> sigma, None + | Some ipat -> + let sigma, ipat = interp_intro_pattern ist env sigma ipat in + sigma, Some ipat + +let interp_in_hyp_as ist env sigma (id,ipat) = + let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in + sigma,(interp_hyp ist env sigma id,ipat) + +let interp_quantified_hypothesis ist = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) + with Not_found -> NamedHyp id + +let interp_binding_name ist = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + (* If a name is bound, it has to be a quantified hypothesis *) + (* user has to use other names for variables if these ones clash with *) + (* a name intented to be used as a (non-variable) identifier *) + try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) + with Not_found -> NamedHyp id + +let interp_declared_or_quantified_hypothesis ist env sigma = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + try try_interp_ltac_var + (coerce_to_decl_or_quant_hyp env) ist (Some (env,sigma)) (dloc,id) + with Not_found -> NamedHyp id + +let interp_binding ist env sigma (loc,b,c) = + let sigma, c = interp_open_constr ist env sigma c in + sigma, (loc,interp_binding_name ist b,c) + +let interp_bindings ist env sigma = function +| NoBindings -> + sigma, NoBindings +| ImplicitBindings l -> + let sigma, l = interp_open_constr_list ist env sigma l in + sigma, ImplicitBindings l +| ExplicitBindings l -> + let sigma, l = List.fold_map (interp_binding ist env) sigma l in + sigma, ExplicitBindings l + +let interp_constr_with_bindings ist env sigma (c,bl) = + let sigma, bl = interp_bindings ist env sigma bl in + let sigma, c = interp_open_constr ist env sigma c in + sigma, (c,bl) + +let interp_open_constr_with_bindings ist env sigma (c,bl) = + let sigma, bl = interp_bindings ist env sigma bl in + let sigma, c = interp_open_constr ist env sigma c in + sigma, (c, bl) + +let loc_of_bindings = function +| NoBindings -> Loc.ghost +| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) +| ExplicitBindings l -> pi1 (List.last l) + +let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = + let loc1 = loc_of_glob_constr c in + let loc2 = loc_of_bindings bl in + let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in + Sigma.Unsafe.of_pair (c, sigma) + } in + (loc,f) + +let interp_induction_arg ist gl arg = + match arg with + | keep,ElimOnConstr c -> + keep,ElimOnConstr { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr_with_bindings ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } + | keep,ElimOnAnonHyp n as x -> x + | keep,ElimOnIdent (loc,id) -> + let error () = user_err_loc (loc, "", + strbrk "Cannot coerce " ++ pr_id id ++ + strbrk " neither to a quantified hypothesis nor to a term.") + in + let try_cast_id id' = + if Tactics.is_quantified_hypothesis id' gl + then keep,ElimOnIdent (loc,id') + else + (keep, ElimOnConstr { delayed = begin fun env sigma -> + try Sigma.here (constr_of_id env id', NoBindings) sigma + with Not_found -> + user_err_loc (loc, "interp_induction_arg", + pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") + end }) + in + try + (** FIXME: should be moved to taccoerce *) + let v = Id.Map.find id ist.lfun in + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + let v = out_gen (topwit wit_intro_pattern) v in + match v with + | _, IntroNaming (IntroIdentifier id) -> try_cast_id id + | _ -> error () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + try_cast_id id + else if has_type v (topwit wit_int) then + keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) + else match Value.to_constr v with + | None -> error () + | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } + with Not_found -> + (* We were in non strict (interactive) mode *) + if Tactics.is_quantified_hypothesis id gl then + keep,ElimOnIdent (loc,id) + else + let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma,c) = interp_open_constr ist env sigma c in + Sigma.Unsafe.of_pair ((c,NoBindings), sigma) + } in + keep,ElimOnConstr f + +(* Associates variables with values and gives the remaining variables and + values *) +let head_with_value (lvar,lval) = + let rec head_with_value_rec lacc = function + | ([],[]) -> (lacc,[],[]) + | (vr::tvr,ve::tve) -> + (match vr with + | None -> head_with_value_rec lacc (tvr,tve) + | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) + | (vr,[]) -> (lacc,vr,[]) + | ([],ve) -> (lacc,[],ve) + in + head_with_value_rec [] (lvar,lval) + +(** [interp_context ctxt] interprets a context (as in + {!Matching.matching_result}) into a context value of Ltac. *) +let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt + +(* Reads a pattern by substituting vars of lfun *) +let use_types = false + +let eval_pattern lfun ist env sigma ((glob,_),pat as c) = + let bound_names = bound_glob_vars glob in + if use_types then + (bound_names,interp_typed_pattern ist env sigma c) + else + (bound_names,instantiate_pattern env sigma lfun pat) + +let read_pattern lfun ist env sigma = function + | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) + | Term c -> Term (eval_pattern lfun ist env sigma c) + +(* Reads the hypotheses of a Match Context rule *) +let cons_and_check_name id l = + if Id.List.mem id l then + user_err_loc (dloc,"read_match_goal_hyps", + str "Hypothesis pattern-matching variable " ++ pr_id id ++ + str " used twice in the same pattern.") + else id::l + +let rec read_match_goal_hyps lfun ist env sigma lidh = function + | (Hyp ((loc,na) as locna,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Hyp (locna,read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | (Def ((loc,na) as locna,mv,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | [] -> [] + +(* Reads the rules of a Match Context or a Match *) +let rec read_match_rule lfun ist env sigma = function + | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl) + | (Pat (rl,mp,tc))::tl -> + Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc) + :: read_match_rule lfun ist env sigma tl + | [] -> [] + + +(* misc *) + +let interp_focussed wit f v = + Ftactic.nf_enter { enter = begin fun gl -> + let v = Genarg.out_gen (glbwit wit) v in + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let v = in_gen (topwit wit) (f env sigma v) in + Ftactic.return v + end } + +(* Interprets an l-tac expression into a value *) +let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = + (* The name [appl] of applied top-level Ltac names is ignored in + [value_interp]. It is installed in the second step by a call to + [name_vfun], because it gives more opportunities to detect a + [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never + register its name since it is syntactically a let, not a + function. *) + let value_interp ist = match tac with + | TacFun (it, body) -> + Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body))) + | TacLetIn (true,l,u) -> interp_letrec ist l u + | TacLetIn (false,l,u) -> interp_letin ist l u + | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr + | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr + | TacArg (loc,a) -> interp_tacarg ist a + | t -> + (** Delayed evaluation *) + Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) + in + let open Ftactic in + Control.check_for_interrupt (); + match curr_debug ist with + | DebugOn lev -> + let eval v = + let ist = { ist with extra = TacStore.set ist.extra f_debug v } in + value_interp ist >>= fun v -> return (name_vfun appl v) + in + Tactic_debug.debug_prompt lev tac eval + | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) + + +and eval_tactic ist tac : unit Proofview.tactic = match tac with + | TacAtom (loc,t) -> + let call = LtacAtomCall t in + catch_error_tac (push_trace(loc,call) ist) (interp_atomic ist t) + | TacFun _ | TacLetIn _ -> assert false + | TacMatchGoal _ | TacMatch _ -> assert false + | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) + | TacId s -> + let msgnl = + let open Ftactic in + interp_message ist s >>= fun msg -> + return (hov 0 msg , hov 0 msg) + in + let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in + let log (msg,_) = Proofview.Trace.log (fun () -> msg) in + let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in + Ftactic.run msgnl begin fun msgnl -> + print msgnl <*> log msgnl <*> break + end + | TacFail (g,n,s) -> + let msg = interp_message ist s in + let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in + let tac = + match g with + | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l) + | TacGlobal -> tac + in + Ftactic.run msg tac + | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac) + | TacShowHyps tac -> + Proofview.V82.tactic begin + tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) + end + | TacAbstract (tac,ido) -> + Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT + (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) + end } + | TacThen (t1,t) -> + Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) + | TacDispatch tl -> + Proofview.tclDISPATCH (List.map (interp_tactic ist) tl) + | TacExtendTac (tf,t,tl) -> + Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf) + (interp_tactic ist t) + (Array.map_to_list (interp_tactic ist) tl) + | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) + | TacThens3parts (t1,tf,t,tl) -> + Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1) + (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) + | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac) + | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) + | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac) + | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac) + | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac) + | TacOr (tac1,tac2) -> + Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2) + | TacOnce tac -> + Tacticals.New.tclONCE (interp_tactic ist tac) + | TacExactlyOnce tac -> + Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac) + | TacIfThenCatch (t,tt,te) -> + Tacticals.New.tclIFCATCH + (interp_tactic ist t) + (fun () -> interp_tactic ist tt) + (fun () -> interp_tactic ist te) + | TacOrelse (tac1,tac2) -> + Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) + | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) + | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) + | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) + | TacArg a -> interp_tactic ist (TacArg a) + | TacInfo tac -> + msg_warning + (strbrk "The general \"info\" tactic is currently not working." ++ spc()++ + strbrk "There is an \"Info\" command to replace it." ++fnl () ++ + strbrk "Some specific verbose tactics may also exist, such as info_eauto."); + eval_tactic ist tac + (* For extensions *) + | TacAlias (loc,s,l) -> + let (ids, body) = Tacenv.interp_alias s in + let (>>=) = Ftactic.bind in + let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in + let tac l = + let addvar x v accu = Id.Map.add x v accu in + let lfun = List.fold_right2 addvar ids l ist.lfun in + let trace = push_trace (loc,LtacNotationCall s) ist in + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace trace; } in + val_interp ist body >>= fun v -> + Ftactic.lift (tactic_of_value ist v) + in + let tac = + Ftactic.with_env interp_vars >>= fun (env, lr) -> + let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + Proofview.Trace.name_tactic name (tac lr) + (* spiwack: this use of name_tactic is not robust to a + change of implementation of [Ftactic]. In such a situation, + some more elaborate solution will have to be used. *) + in + let tac = + let len1 = List.length ids in + let len2 = List.length l in + if len1 = len2 then tac + else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ + expected " ++ int len1 ++ str ", found " ++ int len2) + in + Ftactic.run tac (fun () -> Proofview.tclUNIT ()) + + | TacML (loc,opn,l) -> + let open Ftactic.Notations in + let trace = push_trace (loc,LtacMLCall tac) ist in + let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in + let tac = Tacenv.interp_ml_tactic opn in + let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in + let tac args = + let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + in + Ftactic.run args tac + +and force_vrec ist v : Val.t Ftactic.t = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + let v = to_tacvalue v in + match v with + | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body + | v -> Ftactic.return (of_tacvalue v) + else Ftactic.return v + +and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = + match r with + | ArgVar (loc,id) -> + let v = + try Id.Map.find id ist.lfun + with Not_found -> in_gen (topwit wit_var) id + in + Ftactic.bind (force_vrec ist v) begin fun v -> + let v = propagate_trace ist loc id v in + if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v + end + | ArgArg (loc,r) -> + let ids = extract_ids [] ist.lfun in + let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in + let extra = TacStore.set ist.extra f_avoid_ids ids in + let extra = TacStore.set extra f_trace (push_trace loc_info ist) in + let ist = { lfun = Id.Map.empty; extra = extra; } in + let appl = GlbAppl[r,[]] in + val_interp ~appl ist (Tacenv.interp_ltac r) + +and interp_tacarg ist arg : Val.t Ftactic.t = + match arg with + | TacGeneric arg -> interp_genarg ist arg + | Reference r -> interp_ltac_reference dloc false ist r + | ConstrMayEval c -> + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in + Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) + end } + | TacCall (loc,r,[]) -> + interp_ltac_reference loc true ist r + | TacCall (loc,f,l) -> + let (>>=) = Ftactic.bind in + interp_ltac_reference loc true ist f >>= fun fv -> + Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> + interp_app loc ist fv largs + | TacFreshId l -> + Ftactic.enter { enter = begin fun gl -> + let id = interp_fresh_id ist (pf_env gl) (project gl) l in + Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) + end } + | TacPretype c -> + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let c = interp_uconstr ist env c in + let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in + Sigma (Ftactic.return (Value.of_constr c), sigma, p) + end } + | TacNumgoals -> + Ftactic.lift begin + let open Proofview.Notations in + Proofview.numgoals >>= fun i -> + Proofview.tclUNIT (Value.of_int i) + end + | Tacexp t -> val_interp ist t + +(* Interprets an application node *) +and interp_app loc ist fv largs : Val.t Ftactic.t = + let (>>=) = Ftactic.bind in + let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in + let fv = Value.normalize fv in + if has_type fv (topwit wit_tacvalue) then + match to_tacvalue fv with + (* if var=[] and body has been delayed by val_interp, then body + is not a tactic that expects arguments. + Otherwise Ltac goes into an infinite loop (val_interp puts + a VFun back on body, and then interp_app is called again...) *) + | (VFun(appl,trace,olfun,(_::_ as var),body) + |VFun(appl,trace,olfun,([] as var), + (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> + let (extfun,lvar,lval)=head_with_value (var,largs) in + let fold accu (id, v) = Id.Map.add id v accu in + let newlfun = List.fold_left fold olfun extfun in + if List.is_empty lvar then + begin Proofview.tclORELSE + begin + let ist = { + lfun = newlfun; + extra = TacStore.set ist.extra f_trace []; } in + catch_error_tac trace (val_interp ist body) >>= fun v -> + Ftactic.return (name_vfun (push_appl appl largs) v) + end + begin fun (e, info) -> + Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*> + Proofview.tclZERO ~info e + end + end >>= fun v -> + (* No errors happened, we propagate the trace *) + let v = append_trace trace v in + Proofview.tclLIFT begin + debugging_step ist + (fun () -> + str"evaluation returns"++fnl()++pr_value None v) + end <*> + if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval + else + Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) + | _ -> fail + else fail + +(* Gives the tactic corresponding to the tactic value *) +and tactic_of_value ist vle = + let vle = Value.normalize vle in + if has_type vle (topwit wit_tacvalue) then + match to_tacvalue vle with + | VFun (appl,trace,lfun,[],t) -> + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace []; } in + let tac = name_if_glob appl (eval_tactic ist t) in + catch_error_tac trace tac + | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") + else if has_type vle (topwit wit_tactic) then + let tac = out_gen (topwit wit_tactic) vle in + tactic_of_value ist tac + else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") + +(* Interprets the clauses of a recursive LetIn *) +and interp_letrec ist llc u = + Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) + let lref = ref ist.lfun in + let fold accu ((_, id), b) = + let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in + Id.Map.add id v accu + in + let lfun = List.fold_left fold ist.lfun llc in + let () = lref := lfun in + let ist = { ist with lfun } in + val_interp ist u + +(* Interprets the clauses of a LetIn *) +and interp_letin ist llc u = + let rec fold lfun = function + | [] -> + let ist = { ist with lfun } in + val_interp ist u + | ((_, id), body) :: defs -> + Ftactic.bind (interp_tacarg ist body) (fun v -> + fold (Id.Map.add id v lfun) defs) + in + fold ist.lfun llc + +(** [interp_match_success lz ist succ] interprets a single matching success + (of type {!Tactic_matching.t}). *) +and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = + let (>>=) = Ftactic.bind in + let lctxt = Id.Map.map interp_context context in + let hyp_subst = Id.Map.map Value.of_constr terms in + let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in + let ist = { ist with lfun } in + val_interp ist lhs >>= fun v -> + if has_type v (topwit wit_tacvalue) then match to_tacvalue v with + | VFun (appl,trace,lfun,[],t) -> + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace trace; } in + let tac = eval_tactic ist t in + let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in + catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) + | _ -> Ftactic.return v + else Ftactic.return v + + +(** [interp_match_successes lz ist s] interprets the stream of + matching of successes [s]. If [lz] is set to true, then only the + first success is considered, otherwise further successes are tried + if the left-hand side fails. *) +and interp_match_successes lz ist s = + let general = + let break (e, info) = match e with + | FailError (0, _) -> None + | FailError (n, s) -> Some (FailError (pred n, s), info) + | _ -> None + in + Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans + in + match lz with + | General -> + general + | Select -> + begin + (** Only keep the first matching result, we don't backtrack on it *) + let s = Proofview.tclONCE s in + s >>= fun ans -> interp_match_success ist ans + end + | Once -> + (** Once a tactic has succeeded, do not backtrack anymore *) + Proofview.tclONCE general + +(* Interprets the Match expressions *) +and interp_match ist lz constr lmr = + let (>>=) = Ftactic.bind in + begin Proofview.tclORELSE + (interp_ltac_constr ist constr) + begin function + | (e, info) -> + Proofview.tclLIFT (debugging_exception_step ist true e + (fun () -> str "evaluation of the matched expression")) <*> + Proofview.tclZERO ~info e + end + end >>= fun constr -> + Ftactic.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in + interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) + end } + +(* Interprets the Match Context expressions *) +and interp_match_goal ist lz lr lmr = + Ftactic.nf_enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let hyps = Proofview.Goal.hyps gl in + let hyps = if lr then List.rev hyps else hyps in + let concl = Proofview.Goal.concl gl in + let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in + interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) + end } + +(* Interprets extended tactic generic arguments *) +and interp_genarg ist x : Val.t Ftactic.t = + let open Ftactic.Notations in + (** Ad-hoc handling of some types. *) + let tag = genarg_tag x in + if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then + interp_genarg_var_list ist x + else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then + interp_genarg_constr_list ist x + else + let GenArg (Glbwit wit, x) = x in + match wit with + | ListArg wit -> + let map x = + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Value.cast (topwit wit) x) + in + Ftactic.List.map map x >>= fun l -> + Ftactic.return (Value.of_list (val_tag wit) l) + | OptArg wit -> + let ans = match x with + | None -> Ftactic.return (Value.of_option (val_tag wit) None) + | Some x -> + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + let x = Value.cast (topwit wit) x in + Ftactic.return (Value.of_option (val_tag wit) (Some x)) + in + ans + | PairArg (wit1, wit2) -> + let (p, q) = x in + interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> + interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> + let p = Value.cast (topwit wit1) p in + let q = Value.cast (topwit wit2) q in + Ftactic.return (Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q))) + | ExtraArg s -> + Geninterp.generic_interp ist (Genarg.in_gen (glbwit wit) x) + +(** returns [true] for genargs which have the same meaning + independently of goals. *) + +and interp_genarg_constr_list ist x = + Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in + let (sigma,lc) = interp_constr_list ist env sigma lc in + let lc = Value.of_list (val_tag wit_constr) lc in + Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) + end } + +and interp_genarg_var_list ist x = + Ftactic.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in + let lc = interp_hyp_list ist env sigma lc in + Ftactic.return (Value.of_list (val_tag wit_var) lc) + end } + +(* Interprets tactic expressions : returns a "constr" *) +and interp_ltac_constr ist e : constr Ftactic.t = + let (>>=) = Ftactic.bind in + begin Proofview.tclORELSE + (val_interp ist e) + begin function (err, info) -> match err with + | Not_found -> + Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + Proofview.tclLIFT begin + debugging_step ist (fun () -> + str "evaluation failed for" ++ fnl() ++ + Pptactic.pr_glob_tactic env e) + end + <*> Proofview.tclZERO Not_found + end } + | err -> Proofview.tclZERO ~info err + end + end >>= fun result -> + Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let result = Value.normalize result in + try + let cresult = coerce_to_closed_constr env result in + Proofview.tclLIFT begin + debugging_step ist (fun () -> + Pptactic.pr_glob_tactic env e ++ fnl() ++ + str " has value " ++ fnl() ++ + pr_constr_env env sigma cresult) + end <*> + Ftactic.return cresult + with CannotCoerceTo _ -> + let env = Proofview.Goal.env gl in + Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ + str "offending expression: " ++ fnl() ++ pr_inspect env e result) + end } + + +(* Interprets tactic expressions : returns a "tactic" *) +and interp_tactic ist tac : unit Proofview.tactic = + Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v) + +(* Provides a "name" for the trace to atomic tactics *) +and name_atomic ?env tacexpr tac : unit Proofview.tactic = + begin match env with + | Some e -> Proofview.tclUNIT e + | None -> Proofview.tclENV + end >>= fun env -> + let name () = Pptactic.pr_tactic env (TacAtom (Loc.ghost,tacexpr)) in + Proofview.Trace.name_tactic name tac + +(* Interprets a primitive tactic *) +and interp_atomic ist tac : unit Proofview.tactic = + match tac with + (* Basic tactics *) + | TacIntroPattern l -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacIntroPattern l) + (* spiwack: print uninterpreted, not sure if it is the + expected behaviour. *) + (Tactics.intro_patterns l')) sigma + end } + | TacIntroMove (ido,hto) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let mloc = interp_move_location ist env sigma hto in + let ido = Option.map (interp_ident ist env sigma) ido in + name_atomic ~env + (TacIntroMove(ido,mloc)) + (Tactics.intro_move ido mloc) + end } + | TacExact c -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let (sigma, c_interp) = pf_interp_casted_constr ist gl c in + Sigma.Unsafe.of_pair (Proofview.V82.tactic (Tactics.exact_no_check c_interp), sigma) + end } + end + | TacApply (a,ev,cb,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let l = List.map (fun (k,c) -> + let loc, f = interp_open_constr_with_bindings_loc ist c in + (k,(loc,f))) cb + in + let sigma,tac = match cl with + | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l + | Some cl -> + let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in + sigma, Tactics.apply_delayed_in a ev id l cl in + Tacticals.New.tclWITHHOLES ev tac sigma + end } + end + | TacElim (ev,(keep,cb),cbo) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in + let named_tac = + let tac = Tactics.elim ev keep cb cbo in + name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac + in + Tacticals.New.tclWITHHOLES ev named_tac sigma + end } + | TacCase (ev,(keep,cb)) -> + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let named_tac = + let tac = Tactics.general_case_analysis ev keep cb in + name_atomic ~env (TacCase(ev,(keep,cb))) tac + in + Tacticals.New.tclWITHHOLES ev named_tac sigma + end } + | TacMutualFix (id,n,l) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = pf_env gl in + let f sigma (id,n,c) = + let (sigma,c_interp) = pf_interp_type ist env sigma c in + sigma , (interp_ident ist env sigma id,n,c_interp) in + let (sigma,l_interp) = + Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) + in + let tac = Proofview.V82.tactic (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) in + Sigma.Unsafe.of_pair (tac, sigma) + end } + end + | TacMutualCofix (id,l) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = pf_env gl in + let f sigma (id,c) = + let (sigma,c_interp) = pf_interp_type ist env sigma c in + sigma , (interp_ident ist env sigma id,c_interp) in + let (sigma,l_interp) = + Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) + in + let tac = Proofview.V82.tactic (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) in + Sigma.Unsafe.of_pair (tac, sigma) + end } + end + | TacAssert (b,t,ipat,c) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c) = + (if Option.is_empty t then interp_constr else interp_type) ist env sigma c + in + let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in + let tac = Option.map (interp_tactic ist) t in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacAssert(b,t,ipat,c)) + (Tactics.forward b tac ipat' c)) sigma + end } + | TacGeneralize cl -> + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacGeneralize cl) + (Proofview.V82.tactic (Tactics.generalize_gen cl))) sigma + end } + | TacLetTac (na,c,clp,b,eqpat) -> + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let clp = interp_clause ist env sigma clp in + let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in + if Locusops.is_nowhere clp then + (* We try to fully-typecheck the term *) + let (sigma,c_interp) = pf_interp_constr ist gl c in + let let_tac b na c cl eqpat = + let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in + let with_eq = if b then None else Some (true,id) in + Tactics.letin_tac with_eq na c None cl + in + let na = interp_name ist env sigma na in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacLetTac(na,c_interp,clp,b,eqpat)) + (let_tac b na c_interp clp eqpat)) sigma + else + (* We try to keep the pattern structure as much as possible *) + let let_pat_tac b na c cl eqpat = + let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in + let with_eq = if b then None else Some (true,id) in + Tactics.letin_pat_tac with_eq na c cl + in + let (sigma',c) = interp_pure_open_constr ist env sigma c in + name_atomic ~env + (TacLetTac(na,c,clp,b,eqpat)) + (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) + (let_pat_tac b (interp_name ist env sigma na) + ((sigma,sigma'),c) clp eqpat) sigma') + end } + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + (* spiwack: some unknown part of destruct needs the goal to be + prenormalised. *) + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma,l = + List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> + (* TODO: move sigma as a side-effect *) + (* spiwack: the [*p] variants are for printing *) + let cp = c in + let c = interp_induction_arg ist gl c in + let ipato = interp_intro_pattern_naming_option ist env sigma ipato in + let ipatsp = ipats in + let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in + let cls = Option.map (interp_clause ist env sigma) cls in + sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls)) + end sigma l + in + let l,lp = List.split l in + let sigma,el = + Option.fold_map (interp_constr_with_bindings ist env) sigma el in + let tac = name_atomic ~env + (TacInductionDestruct(isrec,ev,(lp,el))) + (Tactics.induction_destruct isrec ev (l,el)) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + | TacDoubleInduction (h1,h2) -> + let h1 = interp_quantified_hypothesis ist h1 in + let h2 = interp_quantified_hypothesis ist h2 in + name_atomic + (TacDoubleInduction (h1,h2)) + (Elim.h_double_induction h1 h2) + (* Context management *) + | TacRename l -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = pf_env gl in + let sigma = project gl in + let l = + List.map (fun (id1,id2) -> + interp_hyp ist env sigma id1, + interp_ident ist env sigma (snd id2)) l + in + name_atomic ~env + (TacRename l) + (Tactics.rename_hyp l) + end } + + (* Conversion *) + | TacReduce (r,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in + Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) + end } + end + | TacChange (None,c,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let is_onhyps = match cl.onhyps with + | None | Some [] -> true + | _ -> false + in + let is_onconcl = match cl.concl_occs with + | AllOccurrences | NoOccurrences -> true + | _ -> false + in + let c_interp patvars = { Sigma.run = begin fun sigma -> + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let sigma = Sigma.to_evar_map sigma in + let ist = { ist with lfun = lfun' } in + let (sigma, c) = + if is_onhyps && is_onconcl + then interp_type ist (pf_env gl) sigma c + else interp_constr ist (pf_env gl) sigma c + in + Sigma.Unsafe.of_pair (c, sigma) + end } in + Proofview.V82.tactic (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)) + end } + end + | TacChange (Some op,c,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"") begin + Proofview.V82.nf_evar_goals <*> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + Proofview.V82.tactic begin fun gl -> + let op = interp_typed_pattern ist env sigma op in + let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in + let c_interp patvars = { Sigma.run = begin fun sigma -> + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let ist = { ist with lfun = lfun' } in + try + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + with e when to_catch e (* Hack *) -> + errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") + end } in + (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) + gl + end + end } + end + + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + Proofview.Goal.enter { enter = begin fun gl -> + let l' = List.map (fun (b,m,(keep,c)) -> + let f = { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } in + (b,m,keep,f)) l in + let env = Proofview.Goal.env gl in + let sigma = project gl in + let cl = interp_clause ist env sigma cl in + name_atomic ~env + (TacRewrite (ev,l,cl,by)) + (Equality.general_multi_rewrite ev l' cl + (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), + Equality.Naive) + by)) + end } + | TacInversion (DepInversion (k,c,ids),hyp) -> + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c_interp) = + match c with + | None -> sigma , None + | Some c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + sigma , Some c_interp + in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) + (Inv.dinv k c_interp ids_interp dqhyps)) sigma + end } + | TacInversion (NonDepInversion (k,idl,ids),hyp) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let hyps = interp_hyp_list ist env sigma idl in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) + (Inv.inv_clause k ids_interp hyps dqhyps)) sigma + end } + | TacInversion (InversionUsing (c,idl),hyp) -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c_interp) = interp_constr ist env sigma c in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let hyps = interp_hyp_list ist env sigma idl in + let tac = name_atomic ~env + (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) + (Leminv.lemInv_clause dqhyps c_interp hyps) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + +(* Initial call for interpretation *) + +let default_ist () = + let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in + { lfun = Id.Map.empty; extra = extra } + +let eval_tactic t = + Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) + Proofview.tclLIFT db_initialize <*> + interp_tactic (default_ist ()) t + +let eval_tactic_ist ist t = + Proofview.tclLIFT db_initialize <*> + interp_tactic ist t + +(* globalization + interpretation *) + + +let interp_tac_gen lfun avoid_ids debug t = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let extra = TacStore.set TacStore.empty f_debug debug in + let extra = TacStore.set extra f_avoid_ids avoid_ids in + let ist = { lfun = lfun; extra = extra } in + let ltacvars = Id.Map.domain lfun in + interp_tactic ist + (intern_pure_tactic { + ltacvars; genv = env } t) + end } + +let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t +let _ = Proof_global.set_interp_tac interp + +(* Used to hide interpretation for pretty-print, now just launch tactics *) +(* [global] means that [t] should be internalized outside of goals. *) +let hide_interp global t ot = + let hide_interp env = + let ist = { ltacvars = Id.Set.empty; genv = env } in + let te = intern_pure_tactic ist t in + let t = eval_tactic te in + match ot with + | None -> t + | Some t' -> Tacticals.New.tclTHEN t t' + in + if global then + Proofview.tclENV >>= fun env -> + hide_interp env + else + Proofview.Goal.enter { enter = begin fun gl -> + hide_interp (Proofview.Goal.env gl) + end } + +(***************************************************************************) +(** Register standard arguments *) + +let def_intern ist x = (ist, x) +let def_subst _ x = x +let def_interp ist x = Ftactic.return x + +let declare_uniform t = + Genintern.register_intern0 t def_intern; + Genintern.register_subst0 t def_subst; + Geninterp.register_interp0 t def_interp + +let () = + declare_uniform wit_unit + +let () = + declare_uniform wit_int + +let () = + declare_uniform wit_bool + +let () = + declare_uniform wit_string + +let () = + declare_uniform wit_pre_ident + +let lift f = (); fun ist x -> Ftactic.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Ftactic.return (f ist env sigma x) +end } + +let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, v) = f ist env sigma x in + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) +end } + +let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> + let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in + Sigma.Unsafe.of_pair (bl, sigma) + } + +let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> + let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in + Sigma.Unsafe.of_pair (c, sigma) + } + +let () = + Geninterp.register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + Geninterp.register_interp0 wit_ref (lift interp_reference); + Geninterp.register_interp0 wit_ident (lift interp_ident); + Geninterp.register_interp0 wit_var (lift interp_hyp); + Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); + Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); + Geninterp.register_interp0 wit_constr (lifts interp_constr); + Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); + Geninterp.register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); + Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); + Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + Geninterp.register_interp0 wit_open_constr (lifts interp_open_constr); + Geninterp.register_interp0 wit_bindings interp_bindings'; + Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + Geninterp.register_interp0 wit_constr_may_eval (lifts interp_constr_may_eval); + () + +let () = + let interp ist tac = Ftactic.return (Value.of_closure ist tac) in + Geninterp.register_interp0 wit_tactic interp + +let () = + let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + Geninterp.register_interp0 wit_ltac interp + +let () = + Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) + end }) + +(***************************************************************************) +(* Other entry points *) + +let val_interp ist tac k = Ftactic.run (val_interp ist tac) k + +let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k + +let interp_redexp env sigma r = + let ist = default_ist () in + let gist = { fully_empty_glob_sign with genv = env; } in + interp_red_expr ist env sigma (intern_red_expr gist r) + +(***************************************************************************) +(* Backwarding recursive needs of tactic glob/interp/eval functions *) + +let _ = + let eval ty env sigma lfun arg = + let ist = { lfun = lfun; extra = TacStore.empty; } in + if Genarg.has_type arg (glbwit wit_tactic) then + let tac = Genarg.out_gen (glbwit wit_tactic) arg in + let tac = interp_tactic ist tac in + Pfedit.refine_by_tactic env sigma ty tac + else + failwith "not a tactic" + in + Hook.set Pretyping.genarg_interp_hook eval + +(** Used in tactic extension **) + +let dummy_id = Id.of_string "_" + +let lift_constr_tac_to_ml_tac vars tac = + let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let map = function + | None -> None + | Some id -> + let c = Id.Map.find id ist.lfun in + try Some (coerce_to_closed_constr env c) + with CannotCoerceTo ty -> + error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty + in + let args = List.map_filter map vars in + tac args ist + end } in + tac + +let vernac_debug b = + set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) + +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Ltac";"Debug"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + +let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/ltac/tacinterp.mli b/ltac/tacinterp.mli new file mode 100644 index 0000000000..31327873e9 --- /dev/null +++ b/ltac/tacinterp.mli @@ -0,0 +1,124 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* t + val to_constr : t -> constr option + val of_int : int -> t + val to_int : t -> int option + val to_list : t -> t list option + val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t + val cast : 'a typed_abstract_argument_type -> Val.t -> 'a +end + +(** Values for interpretation *) +type value = Value.t + +module TacStore : Store.S with + type t = Geninterp.TacStore.t + and type 'a field = 'a Geninterp.TacStore.field + +(** Signature for interpretation: val\_interp and interpretation functions *) +type interp_sign = Geninterp.interp_sign = { + lfun : value Id.Map.t; + extra : TacStore.t } + +val f_avoid_ids : Id.t list TacStore.field +val f_debug : debug_info TacStore.field + +val extract_ltac_constr_values : interp_sign -> Environ.env -> + Pattern.constr_under_binders Id.Map.t +(** Given an interpretation signature, extract all values which are coercible to + a [constr]. *) + +(** Sets the debugger mode *) +val set_debug : debug_info -> unit + +(** Gives the state of debug *) +val get_debug : unit -> debug_info + +(** Adds an interpretation function for extra generic arguments *) + +val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t + +(** Interprets any expression *) +val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic + +(** Interprets an expression that evaluates to a constr *) +val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic + +val type_uconstr : + ?flags:Pretyping.inference_flags -> + ?expected_type:Pretyping.typing_constraint -> + interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open + +(** Interprets redexp arguments *) +val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr + +(** Interprets tactic expressions *) + +val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> + Id.t Loc.located -> Id.t + +val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr bindings -> Evd.evar_map * constr bindings + +val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr with_bindings -> Evd.evar_map * constr with_bindings + +(** Initial call for interpretation *) + +val eval_tactic : glob_tactic_expr -> unit Proofview.tactic + +val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic +(** Same as [eval_tactic], but with the provided [interp_sign]. *) + +val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic + +(** Globalization + interpretation *) + +val interp_tac_gen : value Id.Map.t -> Id.t list -> + debug_info -> raw_tactic_expr -> unit Proofview.tactic + +val interp : raw_tactic_expr -> unit Proofview.tactic + +(** Hides interpretation for pretty-print *) + +val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic + +(** Internals that can be useful for syntax extensions. *) + +val interp_ltac_var : (value -> 'a) -> interp_sign -> + (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a + +val interp_int : interp_sign -> Id.t Loc.located -> int + +val interp_int_or_var : interp_sign -> int or_var -> int + +val error_ltac_variable : Loc.t -> Id.t -> + (Environ.env * Evd.evar_map) option -> value -> string -> 'a + +(** Transforms a constr-expecting tactic into a tactic finding its arguments in + the Ltac environment according to the given names. *) +val lift_constr_tac_to_ml_tac : Id.t option list -> + (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic + +val default_ist : unit -> Geninterp.interp_sign +(** Empty ist with debug set on the current value. *) diff --git a/ltac/tacsubst.ml b/ltac/tacsubst.ml new file mode 100644 index 0000000000..4059877b75 --- /dev/null +++ b/ltac/tacsubst.ml @@ -0,0 +1,313 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l) + | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l) + +let subst_glob_with_bindings subst (c,bl) = + (subst_glob_constr subst c, subst_bindings subst bl) + +let subst_glob_with_bindings_arg subst (clear,c) = + (clear,subst_glob_with_bindings subst c) + +let rec subst_intro_pattern subst = function + | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p) + | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x + +and subst_intro_pattern_action subst = function + | IntroApplyOn (t,pat) -> + IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) + | IntroOrAndPattern l -> + IntroOrAndPattern (subst_intro_or_and_pattern subst l) + | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) + | IntroWildcard | IntroRewrite _ as x -> x + +and subst_intro_or_and_pattern subst = function + | IntroAndPattern l -> + IntroAndPattern (List.map (subst_intro_pattern subst) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) + +let subst_induction_arg subst = function + | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) + | clear,ElimOnAnonHyp n as x -> x + | clear,ElimOnIdent id as x -> x + +let subst_and_short_name f (c,n) = +(* assert (n=None); *)(* since tacdef are strictly globalized *) + (f c,None) + +let subst_or_var f = function + | ArgVar _ as x -> x + | ArgArg x -> ArgArg (f x) + +let dloc = Loc.ghost + +let subst_located f (_loc,id) = (dloc,f id) + +let subst_reference subst = + subst_or_var (subst_located (subst_kn subst)) + +(*CSC: subst_global_reference is used "only" for RefArgType, that propagates + to the syntactic non-terminals "global", used in commands such as + Print. It is also used for non-evaluable references. *) +open Pp +open Printer + +let subst_global_reference subst = + let subst_global ref = + let ref',t' = subst_global subst ref in + if not (eq_constr (Universes.constr_of_global ref') t') then + msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ + str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ + pr_global ref') ; + ref' + in + subst_or_var (subst_located subst_global) + +let subst_evaluable subst = + let subst_eval_ref = subst_evaluable_reference subst in + subst_or_var (subst_and_short_name subst_eval_ref) + +let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) + +let subst_glob_constr_or_pattern subst (c,p) = + (subst_glob_constr subst c,subst_pattern subst p) + +let subst_redexp subst = + Miscops.map_red_expr_gen + (subst_glob_constr subst) + (subst_evaluable subst) + (subst_glob_constr_or_pattern subst) + +let subst_raw_may_eval subst = function + | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c) + | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c) + | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c) + | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c) + +let subst_match_pattern subst = function + | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc)) + | Term pc -> Term (subst_glob_constr_or_pattern subst pc) + +let rec subst_match_goal_hyps subst = function + | Hyp (locs,mp) :: tl -> + Hyp (locs,subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl + | Def (locs,mv,mp) :: tl -> + Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl + | [] -> [] + +let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with + (* Basic tactics *) + | TacIntroPattern l -> TacIntroPattern (List.map (subst_intro_pattern subst) l) + | TacIntroMove _ as x -> x + | TacExact c -> TacExact (subst_glob_constr subst c) + | TacApply (a,ev,cb,cl) -> + TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) + | TacElim (ev,cb,cbo) -> + TacElim (ev,subst_glob_with_bindings_arg subst cb, + Option.map (subst_glob_with_bindings subst) cbo) + | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) + | TacMutualFix (id,n,l) -> + TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) + | TacMutualCofix (id,l) -> + TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) + | TacAssert (b,otac,na,c) -> + TacAssert (b,Option.map (subst_tactic subst) otac,na,subst_glob_constr subst c) + | TacGeneralize cl -> + TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) + | TacLetTac (id,c,clp,b,eqpat) -> + TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + let l' = List.map (fun (c,ids,cls) -> + subst_induction_arg subst c, ids, cls) l in + let el' = Option.map (subst_glob_with_bindings subst) el in + TacInductionDestruct (isrec,ev,(l',el')) + | TacDoubleInduction (h1,h2) as x -> x + + (* Context management *) + | TacRename l as x -> x + + (* Conversion *) + | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) + | TacChange (op,c,cl) -> + TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + subst_glob_constr subst c, cl) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + TacRewrite (ev, + List.map (fun (b,m,c) -> + b,m,subst_glob_with_bindings_arg subst c) l, + cl,Option.map (subst_tactic subst) by) + | TacInversion (DepInversion (k,c,l),hyp) -> + TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) + | TacInversion (NonDepInversion _,_) as x -> x + | TacInversion (InversionUsing (c,cl),hyp) -> + TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) + +and subst_tactic subst (t:glob_tactic_expr) = match t with + | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) + | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) + | TacLetIn (r,l,u) -> + let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in + TacLetIn (r,l,subst_tactic subst u) + | TacMatchGoal (lz,lr,lmr) -> + TacMatchGoal(lz,lr, subst_match_rule subst lmr) + | TacMatch (lz,c,lmr) -> + TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr) + | TacId _ | TacFail _ as x -> x + | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr) + | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr) + | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s) + | TacThen (t1,t2) -> + TacThen (subst_tactic subst t1, subst_tactic subst t2) + | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl) + | TacExtendTac (tf,t,tl) -> + TacExtendTac (Array.map (subst_tactic subst) tf, + subst_tactic subst t, + Array.map (subst_tactic subst) tl) + | TacThens (t,tl) -> + TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) + | TacThens3parts (t1,tf,t2,tl) -> + TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf, + subst_tactic subst t2,Array.map (subst_tactic subst) tl) + | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) + | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) + | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac) + | TacTry tac -> TacTry (subst_tactic subst tac) + | TacInfo tac -> TacInfo (subst_tactic subst tac) + | TacRepeat tac -> TacRepeat (subst_tactic subst tac) + | TacOr (tac1,tac2) -> + TacOr (subst_tactic subst tac1,subst_tactic subst tac2) + | TacOnce tac -> + TacOnce (subst_tactic subst tac) + | TacExactlyOnce tac -> + TacExactlyOnce (subst_tactic subst tac) + | TacIfThenCatch (tac,tact,tace) -> + TacIfThenCatch ( + subst_tactic subst tac, + subst_tactic subst tact, + subst_tactic subst tace) + | TacOrelse (tac1,tac2) -> + TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2) + | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) + | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) + | TacComplete tac -> TacComplete (subst_tactic subst tac) + | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) + + (* For extensions *) + | TacAlias (_,s,l) -> + let s = subst_kn subst s in + TacAlias (dloc,s,List.map (subst_tacarg subst) l) + | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) + +and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) + +and subst_tacarg subst = function + | Reference r -> Reference (subst_reference subst r) + | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) + | TacCall (_loc,f,l) -> + TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) + | TacFreshId _ as x -> x + | TacPretype c -> TacPretype (subst_glob_constr subst c) + | TacNumgoals -> TacNumgoals + | Tacexp t -> Tacexp (subst_tactic subst t) + | TacGeneric arg -> TacGeneric (subst_genarg subst arg) + +(* Reads the rules of a Match Context or a Match *) +and subst_match_rule subst = function + | (All tc)::tl -> + (All (subst_tactic subst tc))::(subst_match_rule subst tl) + | (Pat (rl,mp,tc))::tl -> + let hyps = subst_match_goal_hyps subst rl in + let pat = subst_match_pattern subst mp in + Pat (hyps,pat,subst_tactic subst tc) + ::(subst_match_rule subst tl) + | [] -> [] + +and subst_genarg subst (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = subst_genarg subst (in_gen (glbwit wit) x) in + out_gen (glbwit wit) ans + in + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with + | None -> in_gen (glbwit (wit_opt wit)) None + | Some x -> + let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in + in_gen (glbwit (wit_opt wit)) (Some s) + in + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in + let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + Genintern.generic_substitute subst (in_gen (glbwit wit) x) + +(** Registering *) + +let () = + Genintern.register_subst0 wit_int_or_var (fun _ v -> v); + Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_ident (fun _ v -> v); + Genintern.register_subst0 wit_var (fun _ v -> v); + Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); + Genintern.register_subst0 wit_tactic subst_tactic; + Genintern.register_subst0 wit_ltac subst_tactic; + Genintern.register_subst0 wit_constr subst_glob_constr; + Genintern.register_subst0 wit_sort (fun _ v -> v); + Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); + Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_red_expr subst_redexp; + Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; + Genintern.register_subst0 wit_bindings subst_bindings; + Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; + Genintern.register_subst0 wit_constr_may_eval subst_raw_may_eval; + () diff --git a/ltac/tacsubst.mli b/ltac/tacsubst.mli new file mode 100644 index 0000000000..c1bf272579 --- /dev/null +++ b/ltac/tacsubst.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glob_tactic_expr -> glob_tactic_expr + +(** For generic arguments, we declare and store substitutions + in a table *) + +val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument + +(** Misc *) + +val subst_glob_constr_and_expr : + substitution -> glob_constr_and_expr -> glob_constr_and_expr + +val subst_glob_with_bindings : substitution -> + glob_constr_and_expr with_bindings -> + glob_constr_and_expr with_bindings diff --git a/ltac/tactic_debug.ml b/ltac/tactic_debug.ml new file mode 100644 index 0000000000..d661f9677c --- /dev/null +++ b/ltac/tactic_debug.ml @@ -0,0 +1,412 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Printer.pr_constr_pattern p) rl + +(* This module intends to be a beginning of debugger for tactic expressions. + Currently, it is quite simple and we can hope to have, in the future, a more + complete panel of commands dedicated to a proof assistant framework *) + +(* Debug information *) +type debug_info = + | DebugOn of int + | DebugOff + +(* An exception handler *) +let explain_logic_error e = + Errors.print (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) + +let explain_logic_error_no_anomaly e = + Errors.print_no_report (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) + +let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) + +(* Prints the goal *) + +let db_pr_goal gl = + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let penv = print_named_context env in + let pc = print_constr_env env concl in + str" " ++ hv 0 (penv ++ fnl () ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () + +let db_pr_goal = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let pg = db_pr_goal gl in + Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) + end } + + +(* Prints the commands *) +let help () = + msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ + str " h/? = Help" ++ fnl() ++ + str " r = Run times" ++ fnl() ++ + str " r = Run up to next idtac " ++ fnl() ++ + str " s = Skip" ++ fnl() ++ + str " x = Exit") + +(* Prints the goal and the command to be executed *) +let goal_com tac = + Proofview.tclTHEN + db_pr_goal + (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) + +(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] + expressions. It avoids parametrizing everything over a + reference. *) +let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) + +let rec drop_spaces inst i = + if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) + else i + +let possibly_unquote s = + if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then + String.sub s 1 (String.length s - 2) + else + s + +(* (Re-)initialize debugger *) +let db_initialize = + let open Proofview.NonLogical in + (skip:=0) >> (skipped:=0) >> (breakpoint:=None) + +let int_of_string s = + try Proofview.NonLogical.return (int_of_string s) + with e -> Proofview.NonLogical.raise e + +let string_get s i = + try Proofview.NonLogical.return (String.get s i) + with e -> Proofview.NonLogical.raise e + +(* Gives the number of steps or next breakpoint of a run command *) +let run_com inst = + let open Proofview.NonLogical in + string_get inst 0 >>= fun first_char -> + if first_char ='r' then + let i = drop_spaces inst 1 in + if String.length inst > i then + let s = String.sub inst i (String.length inst - i) in + if inst.[0] >= '0' && inst.[0] <= '9' then + int_of_string s >>= fun num -> + (if num<0 then invalid_arg "run_com" else return ()) >> + (skip:=num) >> (skipped:=0) + else + breakpoint:=Some (possibly_unquote s) + else + invalid_arg "run_com" + else + invalid_arg "run_com" + +(* Prints the run counter *) +let run ini = + let open Proofview.NonLogical in + if not ini then + begin + Proofview.NonLogical.print_notice (str"\b\r\b\r") >> + !skipped >>= fun skipped -> + msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) + end >> + !skipped >>= fun x -> + skipped := x+1 + else + return () + +(* Prints the prompt *) +let rec prompt level = + (* spiwack: avoid overriding by the open below *) + let runtrue = run true in + begin + let open Proofview.NonLogical in + Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> + let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in + Proofview.NonLogical.catch Proofview.NonLogical.read_line + begin function (e, info) -> match e with + | End_of_file -> exit + | e -> raise ~info e + end + >>= fun inst -> + match inst with + | "" -> return (DebugOn (level+1)) + | "s" -> return (DebugOff) + | "x" -> Proofview.NonLogical.print_char '\b' >> exit + | "h"| "?" -> + begin + help () >> + prompt level + end + | _ -> + Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) + begin function (e, info) -> match e with + | Failure _ | Invalid_argument _ -> prompt level + | e -> raise ~info e + end + end + +(* Prints the state and waits for an instruction *) +(* spiwack: the only reason why we need to take the continuation [f] + as an argument rather than returning the new level directly seems to + be that [f] is wrapped in with "explain_logic_error". I don't think + it serves any purpose in the current design, so we could just drop + that. *) +let debug_prompt lev tac f = + (* spiwack: avoid overriding by the open below *) + let runfalse = run false in + let open Proofview.NonLogical in + let (>=) = Proofview.tclBIND in + (* What to print and to do next *) + let newlevel = + Proofview.tclLIFT !skip >= fun initial_skip -> + if Int.equal initial_skip 0 then + Proofview.tclLIFT !breakpoint >= fun breakpoint -> + if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) + else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) + else Proofview.tclLIFT begin + (!skip >>= fun s -> skip:=s-1) >> + runfalse >> + !skip >>= fun new_skip -> + (if Int.equal new_skip 0 then skipped:=0 else return ()) >> + return (DebugOn (lev+1)) + end in + newlevel >= fun newlevel -> + (* What to execute *) + Proofview.tclOR + (f newlevel) + begin fun (reraise, info) -> + Proofview.tclTHEN + (Proofview.tclLIFT begin + (skip:=0) >> (skipped:=0) >> + if Logic.catchable_exception reraise then + msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) + else return () + end) + (Proofview.tclZERO ~info reraise) + end + +let is_debug db = + let open Proofview.NonLogical in + !breakpoint >>= fun breakpoint -> + match db, breakpoint with + | DebugOff, _ -> return false + | _, Some _ -> return false + | _ -> + !skip >>= fun skip -> + return (Int.equal skip 0) + +(* Prints a constr *) +let db_constr debug env c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) + else return () + +(* Prints the pattern rule *) +let db_pattern_rule debug num r = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ + str "|" ++ spc () ++ prmatchrl r) + end + else return () + +(* Prints the hypothesis pattern identifier if it exists *) +let hyp_bound = function + | Anonymous -> str " (unbound)" + | Name id -> str " (bound to " ++ pr_id id ++ str ")" + +(* Prints a matched hypothesis *) +let db_matched_hyp debug env (id,_,c) ido = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ + str " has been matched: " ++ print_constr_env env c) + else return () + +(* Prints the matched conclusion *) +let db_matched_concl debug env c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) + else return () + +(* Prints a success message when the goal has been matched *) +let db_mc_pattern_success debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ + str "Let us execute the right-hand side part..." ++ fnl()) + else return () + +(* Prints a failure message for an hypothesis pattern *) +let db_hyp_pattern_failure debug env sigma (na,hyp) = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ + str " cannot match: " ++ + prmatchpatt env sigma hyp) + else return () + +(* Prints a matching failure message for a rule *) +let db_matching_failure debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ + str "Let us try the next one...") + else return () + +(* Prints an evaluation failure message for a rule *) +let db_eval_failure debug s = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + let s = str "message \"" ++ s ++ str "\"" in + msg_tac_debug + (str "This rule has failed due to \"Fail\" tactic (" ++ + s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") + else return () + +(* Prints a logic failure message for a rule *) +let db_logic_failure debug err = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (explain_logic_error err) >> + msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ + str "Let us try the next one...") + end + else return () + +let is_breakpoint brkname s = match brkname, s with + | Some s, MsgString s'::_ -> String.equal s s' + | _ -> false + +let db_breakpoint debug s = + let open Proofview.NonLogical in + !breakpoint >>= fun opt_breakpoint -> + match debug with + | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> + breakpoint:=None + | _ -> + return () + +(** Extrating traces *) + +let is_defined_ltac trace = + let rec aux = function + | (_, Tacexpr.LtacNameCall f) :: tail -> + not (Tacenv.is_ltac_for_ml_tactic f) + | (_, Tacexpr.LtacAtomCall _) :: tail -> + false + | _ :: tail -> aux tail + | [] -> false in + aux (List.rev trace) + +let explain_ltac_call_trace last trace loc = + let calls = last :: List.rev_map snd trace in + let pr_call ck = match ck with + | Tacexpr.LtacNotationCall kn -> quote (KerName.print kn) + | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Tacexpr.LtacMLCall t -> + quote (Pptactic.pr_glob_tactic (Global.env()) t) + | Tacexpr.LtacVarCall (id,t) -> + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + | Tacexpr.LtacAtomCall te -> + quote (Pptactic.pr_glob_tactic (Global.env()) + (Tacexpr.TacAtom (Loc.ghost,te))) + | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> + quote (Printer.pr_glob_constr_env (Global.env()) c) ++ + (if not (Id.Map.is_empty vars) then + strbrk " (with " ++ + prlist_with_sep pr_comma + (fun (id,c) -> + pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + (List.rev (Id.Map.bindings vars)) ++ str ")" + else mt()) + in + match calls with + | [] -> mt () + | _ -> + let kind_of_last_call = match List.last calls with + | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." + | _ -> ", last call failed." + in + hov 0 (str "In nested Ltac calls to " ++ + pr_enum pr_call calls ++ strbrk kind_of_last_call) + +let skip_extensions trace = + let rec aux = function + | (_,Tacexpr.LtacNameCall f as tac) :: _ + when Tacenv.is_ltac_for_ml_tactic f -> [tac] + | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) + :: _ -> [tac] + | t :: tail -> t :: aux tail + | [] -> [] in + List.rev (aux (List.rev trace)) + +let extract_ltac_trace trace eloc = + let trace = skip_extensions trace in + let (loc,c),tail = List.sep_last trace in + if is_defined_ltac trace then + (* We entered a user-defined tactic, + we display the trace with location of the call *) + let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in + Some msg, loc + else + (* We entered a primitive tactic, we don't display trace but + report on the finest location *) + let best_loc = + if not (Loc.is_ghost eloc) then eloc else + (* trace is with innermost call coming first *) + let rec aux = function + | (loc,_)::tail when not (Loc.is_ghost loc) -> loc + | _::tail -> aux tail + | [] -> Loc.ghost in + aux trace in + None, best_loc + +let get_ltac_trace (_, info) = + let ltac_trace = Exninfo.get info ltac_trace_info in + let loc = Option.default Loc.ghost (Loc.get_loc info) in + match ltac_trace with + | None -> None + | Some trace -> Some (extract_ltac_trace trace loc) + +let () = Cerrors.register_additional_error_info get_ltac_trace diff --git a/ltac/tactic_debug.mli b/ltac/tactic_debug.mli new file mode 100644 index 0000000000..520fb41eff --- /dev/null +++ b/ltac/tactic_debug.mli @@ -0,0 +1,80 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic + +(** Initializes debugger *) +val db_initialize : unit Proofview.NonLogical.t + +(** Prints a constr *) +val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t + +(** Prints the pattern rule *) +val db_pattern_rule : + debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + +(** Prints a matched hypothesis *) +val db_matched_hyp : + debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t + +(** Prints the matched conclusion *) +val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t + +(** Prints a success message when the goal has been matched *) +val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t + +(** Prints a failure message for an hypothesis pattern *) +val db_hyp_pattern_failure : + debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t + +(** Prints a matching failure message for a rule *) +val db_matching_failure : debug_info -> unit Proofview.NonLogical.t + +(** Prints an evaluation failure message for a rule *) +val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t + +(** An exception handler *) +val explain_logic_error: exn -> Pp.std_ppcmds + +(** For use in the Ltac debugger: some exception that are usually + consider anomalies are acceptable because they are caught later in + the process that is being debugged. One should not require + from users that they report these anomalies. *) +val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds + +(** Prints a logic failure message for a rule *) +val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t + +(** Prints a logic failure message for a rule *) +val db_breakpoint : debug_info -> + Id.t Loc.located message_token list -> unit Proofview.NonLogical.t + +val extract_ltac_trace : + Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t diff --git a/ltac/tactic_option.ml b/ltac/tactic_option.ml new file mode 100644 index 0000000000..a5ba3b8371 --- /dev/null +++ b/ltac/tactic_option.ml @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* obj = + declare_object + { (default_object name) with + cache_function = cache; + load_function = (fun _ -> load); + open_function = (fun _ -> load); + classify_function = (fun (local, tac) -> + if local then Dispose else Substitute (local, tac)); + subst_function = subst} + in + let put local tac = + set_default_tactic local tac; + Lib.add_anonymous_leaf (input (local, tac)) + in + let get () = !locality, Tacinterp.eval_tactic !default_tactic in + let print () = + Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ + (if !locality then str" (locally defined)" else str" (globally defined)") + in + put, get, print diff --git a/ltac/tactic_option.mli b/ltac/tactic_option.mli new file mode 100644 index 0000000000..ed759a76db --- /dev/null +++ b/ltac/tactic_option.mli @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string -> + (* put *) (locality_flag -> glob_tactic_expr -> unit) * + (* get *) (unit -> locality_flag * unit Proofview.tactic) * + (* print *) (unit -> Pp.std_ppcmds) diff --git a/ltac/tauto.ml b/ltac/tauto.ml new file mode 100644 index 0000000000..a86fdb98a9 --- /dev/null +++ b/ltac/tauto.ml @@ -0,0 +1,282 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* c + | None -> failwith "tauto: anomaly" + +(** Parametrization of tauto *) + +type tauto_flags = { + +(* Whether conjunction and disjunction are restricted to binary connectives *) + binary_mode : bool; + +(* Whether compatibility for buggy detection of binary connective is on *) + binary_mode_bugged_detection : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* contravariant position in an hypothesis *) + strict_in_contravariant_hyp : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* an hypothesis and in the conclusion *) + strict_in_hyp_and_ccl : bool; + +(* Whether unit type includes equality types *) + strict_unit : bool; +} + +let wit_tauto_flags : tauto_flags uniform_genarg_type = + Genarg.create_arg "tauto_flags" + +let assoc_flags ist = + let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in + try Value.cast (topwit wit_tauto_flags) v with _ -> assert false + +(* Whether inner not are unfolded *) +let negation_unfolding = ref true + +(* Whether inner iff are unfolded *) +let iff_unfolding = ref false + +let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of not in intuition"; + optkey = ["Intuition";"Negation";"Unfolding"]; + optread = (fun () -> !negation_unfolding); + optwrite = (:=) negation_unfolding } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of iff in intuition"; + optkey = ["Intuition";"Iff";"Unfolding"]; + optread = (fun () -> !iff_unfolding); + optwrite = (:=) iff_unfolding } + +(** Base tactics *) + +let loc = Loc.ghost +let idtac = Proofview.tclUNIT () +let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) + +let intro = Tactics.intro + +let assert_ ?by c = + let tac = match by with + | None -> None + | Some tac -> Some (tclCOMPLETE tac) + in + Proofview.tclINDEPENDENT (Tactics.forward true tac None c) + +let apply c = Tactics.apply c + +let clear id = Proofview.V82.tactic (fun gl -> Tactics.clear [id] gl) + +let assumption = Tactics.assumption + +let split = Tactics.split_with_bindings false [Misctypes.NoBindings] + +(** Test *) + +let is_empty _ ist = + if is_empty_type (assoc_var "X1" ist) then idtac else fail + +(* Strictly speaking, this exceeds the propositional fragment as it + matches also equality types (and solves them if a reflexivity) *) +let is_unit_or_eq _ ist = + let flags = assoc_flags ist in + let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in + if test (assoc_var "X1" ist) then idtac else fail + +let bugged_is_binary t = + isApp t && + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind (ind,u) -> + let (mib,mip) = Global.lookup_inductive ind in + Int.equal mib.Declarations.mind_nparams 2 + | _ -> false + +(** Dealing with conjunction *) + +let is_conj _ ist = + let flags = assoc_flags ist in + let ind = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && + is_conjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode ind + then idtac + else fail + +let flatten_contravariant_conj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_conjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode typ + with + | Some (_,args) -> + let newtyp = List.fold_right mkArrow args c in + let intros = tclMAP (fun _ -> intro) args in + let by = tclTHENLIST [intros; apply hyp; split; assumption] in + tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] + | _ -> fail + +(** Dealing with disjunction *) + +let is_disj _ ist = + let flags = assoc_flags ist in + let t = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && + is_disjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode t + then idtac + else fail + +let flatten_contravariant_disj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_disjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode + typ with + | Some (_,args) -> + let map i arg = + let typ = mkArrow arg c in + let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in + let by = tclTHENLIST [intro; apply hyp; ci; assumption] in + assert_ ~by typ + in + let tacs = List.mapi map args in + let tac0 = clear (destVar hyp) in + tclTHEN (tclTHENLIST tacs) tac0 + | _ -> fail + +let make_unfold name = + let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in + let const = Constant.make2 (MPfile dir) (Label.make name) in + (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + +let u_iff = make_unfold "iff" +let u_not = make_unfold "not" + +let reduction_not_iff _ ist = + let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let tac = match !negation_unfolding, unfold_iff () with + | true, true -> make_reduce [u_not; u_iff] + | true, false -> make_reduce [u_not] + | false, true -> make_reduce [u_iff] + | false, false -> TacId [] + in + eval_tactic_ist ist tac + +let coq_nnpp_path = + let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in + Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") + +let apply_nnpp _ ist = + Proofview.tclBIND + (Proofview.tclUNIT ()) + begin fun () -> try + let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in + apply nnpp + with Not_found -> tclFAIL 0 (Pp.mt ()) + end + +(* This is the uniform mode dealing with ->, not, iff and types isomorphic to + /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. + For the moment not and iff are still always unfolded. *) +let tauto_uniform_unit_flags = { + binary_mode = true; + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = true; + strict_unit = false +} + +(* This is the compatibility mode (not used) *) +let tauto_legacy_flags = { + binary_mode = true; + binary_mode_bugged_detection = true; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +(* This is the improved mode *) +let tauto_power_flags = { + binary_mode = false; (* support n-ary connectives *) + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = false; (* supports non-regular connectives *) + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +let with_flags flags _ ist = + let f = (loc, Id.of_string "f") in + let x = (loc, Id.of_string "x") in + let arg = Val.Dyn (val_tag (topwit wit_tauto_flags), flags) in + let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in + eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) + +let register_tauto_tactic tac name0 args = + let ids = List.map (fun id -> Id.of_string id) args in + let ids = List.map (fun id -> Some id) ids in + let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let () = Tacenv.register_ml_tactic name [| tac |] in + let tac = TacFun (ids, TacML (loc, entry, [])) in + let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in + Mltop.declare_cache_obj obj tauto_plugin + +let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] +let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] +let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] +let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] diff --git a/ltac/tauto.mli b/ltac/tauto.mli new file mode 100644 index 0000000000..e69de29bb2 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 73ef7e1eda..ad1f8cbcc7 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -107,7 +107,7 @@ let core_libs = "engine/engine"; "pretyping/pretyping"; "interp/interp"; "proofs/proofs"; "parsing/parsing"; "printing/printing"; "tactics/tactics"; "stm/stm"; "toplevel/toplevel"; "parsing/highparsing"; - "tactics/hightactics"] + "ltac/ltac"] let core_cma = List.map (fun s -> s^".cma") core_libs let core_cmxa = List.map (fun s -> s^".cmxa") core_libs let core_mllib = List.map (fun s -> s^".mllib") core_libs diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml deleted file mode 100644 index ea598b61ca..0000000000 --- a/tactics/autorewrite.ml +++ /dev/null @@ -1,315 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - errorlabstrm "AutoRewrite" - (str "Rewriting base " ++ str bas ++ str " does not exist.") - -let find_rewrites bas = - List.rev_map snd (HintDN.find_all (find_base bas)) - -let find_matches bas pat = - let base = find_base bas in - let res = HintDN.search_pattern base pat in - List.map snd res - -let print_rewrite_hintdb bas = - (str "Database " ++ str bas ++ fnl () ++ - prlist_with_sep fnl - (fun h -> - str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ - Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ - Option.cata (fun tac -> str " then use tactic " ++ - Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) - (find_rewrites bas)) - -type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option - -(* Applies all the rules of one base *) -let one_base general_rewrite_maybe_in tac_main bas = - let lrul = find_rewrites bas in - let try_rewrite dir ctx c tc = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in - let c' = Vars.subst_univs_level_constr subst c in - let sigma = Sigma.to_evar_map sigma in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in - let tac = general_rewrite_maybe_in dir c' tc in - Sigma.Unsafe.of_pair (tac, sigma) - end } in - let lrul = List.map (fun h -> - let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in - (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> - Tacticals.New.tclTHEN tac - (Tacticals.New.tclREPEAT_MAIN - (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) - (Proofview.tclUNIT()) lrul)) - -(* The AutoRewrite tactic *) -let autorewrite ?(conds=Naive) tac_main lbas = - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS - (List.fold_left (fun tac bas -> - Tacticals.New.tclTHEN tac - (one_base (fun dir c tac -> - let tac = (tac, conds) in - general_rewrite dir AllOccurrences true false ~tac c) - tac_main bas)) - (Proofview.tclUNIT()) lbas)) - -let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = - Proofview.Goal.nf_enter { enter = begin fun gl -> - (* let's check at once if id exists (to raise the appropriate error) *) - let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in - let general_rewrite_in id = - let id = ref id in - let to_be_cleared = ref false in - fun dir cstr tac gl -> - let last_hyp_id = - match Tacmach.pf_hyps gl with - d :: _ -> Context.Named.Declaration.get_id d - | _ -> (* even the hypothesis id is missing *) - raise (Logic.RefinerError (Logic.NoSuchHyp !id)) - in - let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false) gl in - let gls = gl'.Evd.it in - match gls with - g::_ -> - (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with - d ::_ -> - let lastid = Context.Named.Declaration.get_id d in - if not (Id.equal last_hyp_id lastid) then - begin - let gl'' = - if !to_be_cleared then - tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl - else gl' in - id := lastid ; - to_be_cleared := true ; - gl'' - end - else - begin - to_be_cleared := false ; - gl' - end - | _ -> assert false) (* there must be at least an hypothesis *) - | _ -> assert false (* rewriting cannot complete a proof *) - in - let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in - Tacticals.New.tclMAP (fun id -> - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS - (List.fold_left (fun tac bas -> - Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) - idl - end } - -let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] - -let gen_auto_multi_rewrite conds tac_main lbas cl = - let try_do_hyps treat_id l = - autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas - in - if cl.concl_occs != AllOccurrences && - cl.concl_occs != NoOccurrences - then - Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") - else - let compose_tac t1 t2 = - match cl.onhyps with - | Some [] -> t1 - | _ -> Tacticals.New.tclTHENFIRST t1 t2 - in - compose_tac - (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) - (match cl.onhyps with - | Some l -> try_do_hyps (fun ((_,id),_) -> id) l - | None -> - (* try to rewrite in all hypothesis - (except maybe the rewritten one) *) - Proofview.Goal.nf_enter { enter = begin fun gl -> - let ids = Tacmach.New.pf_ids_of_hyps gl in - try_do_hyps (fun id -> id) ids - end }) - -let auto_multi_rewrite ?(conds=Naive) lems cl = - Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) - -let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = - let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in - match onconcl,cl.Locus.onhyps with - | false,Some [_] | true,Some [] | false,Some [] -> - (* autorewrite with .... in clause using tac n'est sur que - si clause represente soit le but soit UNE hypothese - *) - Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) - | _ -> - Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") - -(* Functions necessary to the library object declaration *) -let cache_hintrewrite (_,(rbase,lrl)) = - let base = try raw_find_base rbase with Not_found -> HintDN.empty in - let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 - in - let lrl = HintDN.refresh_metas lrl in - let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in - rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab - - -let subst_hintrewrite (subst,(rbase,list as node)) = - let list' = HintDN.subst subst list in - if list' == list then node else - (rbase,list') - -let classify_hintrewrite x = Libobject.Substitute x - - -(* Declaration of the Hint Rewrite library object *) -let inHintRewrite : string * HintDN.t -> Libobject.obj = - Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with - Libobject.cache_function = cache_hintrewrite; - Libobject.load_function = (fun _ -> cache_hintrewrite); - Libobject.subst_function = subst_hintrewrite; - Libobject.classify_function = classify_hintrewrite } - - -open Clenv - -type hypinfo = { - hyp_cl : clausenv; - hyp_prf : constr; - hyp_ty : types; - hyp_car : constr; - hyp_rel : constr; - hyp_l2r : bool; - hyp_left : constr; - hyp_right : constr; -} - -let decompose_applied_relation metas env sigma c ctype left2right = - let find_rel ty = - let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in - let eqclause = - if metas then eqclause - else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) - in - let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res - | _ -> raise Not_found - in - try - let others,(c1,c2) = split_last_two args in - let ty1, ty2 = - Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 - in -(* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) -(* else *) - Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; - hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); - hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } - with Not_found -> None - in - match find_rel ctype with - | Some c -> Some c - | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' ctx) with - | Some c -> Some c - | None -> None - -let find_applied_relation metas loc env sigma c left2right = - let ctype = Typing.unsafe_type_of env sigma c in - match decompose_applied_relation metas env sigma c ctype left2right with - | Some c -> c - | None -> - user_err_loc (loc, "decompose_applied_relation", - str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ - spc () ++ str"of this term does not end with an applied relation.") - -(* To add rewriting rules to a base *) -let add_rew_rules base lrul = - let counter = ref 0 in - let env = Global.env () in - let sigma = Evd.from_env env in - let lrul = - List.fold_left - (fun dn (loc,(c,ctx),b,t) -> - let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in - let info = find_applied_relation false loc env sigma c b in - let pat = if b then info.hyp_left else info.hyp_right in - let rul = { rew_lemma = c; rew_type = info.hyp_ty; - rew_pat = pat; rew_ctx = ctx; rew_l2r = b; - rew_tac = Option.map Tacintern.glob_tactic t} - in incr counter; - HintDN.add pat (!counter, rul) dn) HintDN.empty lrul - in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) - diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli deleted file mode 100644 index 6196b04e18..0000000000 --- a/tactics/autorewrite.mli +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_rew_rule list -> unit - -(** The AutoRewrite tactic. - The optional conditions tell rewrite how to handle matching and side-condition solving. - Default is Naive: first match in the clause, don't look at the side-conditions to - tell if the rewrite succeeded. *) -val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic -val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic - -(** Rewriting rules *) -type rew_rule = { rew_lemma: constr; - rew_type: types; - rew_pat: constr; - rew_ctx: Univ.universe_context_set; - rew_l2r: bool; - rew_tac: glob_tactic_expr option } - -val find_rewrites : string -> rew_rule list - -val find_matches : string -> constr -> rew_rule list - -val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic - -val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic - -val print_rewrite_hintdb : string -> Pp.std_ppcmds - -open Clenv - - -type hypinfo = { - hyp_cl : clausenv; - hyp_prf : constr; - hyp_ty : types; - hyp_car : constr; - hyp_rel : constr; - hyp_l2r : bool; - hyp_left : constr; - hyp_right : constr; -} - -val find_applied_relation : bool -> - Loc.t -> - Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo - diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml deleted file mode 100644 index 4855598989..0000000000 --- a/tactics/class_tactics.ml +++ /dev/null @@ -1,903 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - if Evar.Map.mem ev !tosee then - visit ev (Evar.Map.find ev !tosee)) evs; - tosee := Evar.Map.remove ev !tosee; - l' := ev :: !l'; - in - while not (Evar.Map.is_empty !tosee) do - let ev, evi = Evar.Map.min_binding !tosee in - visit ev evi - done; - List.rev !l' - -let evars_to_goals p evm = - let goals = ref Evar.Map.empty in - let map ev evi = - let evi, goal = p evm ev evi in - let () = if goal then goals := Evar.Map.add ev evi !goals in - evi - in - let evm = Evd.raw_map_undefined map evm in - if Evar.Map.is_empty !goals then None - else Some (!goals, evm) - -(** Typeclasses instance search tactic / eauto *) - -open Auto - -open Unification - -let auto_core_unif_flags st freeze = { - modulo_conv_on_closed_terms = Some st; - use_metas_eagerly_in_conv_on_closed_terms = true; - use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = st; - modulo_delta_types = st; - check_applied_meta_types = false; - use_pattern_unification = true; - use_meta_bound_pattern_unification = true; - frozen_evars = freeze; - restrict_conv_on_strict_subterms = false; (* ? *) - modulo_betaiota = true; - modulo_eta = !typeclasses_modulo_eta; -} - -let auto_unif_flags freeze st = - let fl = auto_core_unif_flags st freeze in - { core_unify_flags = fl; - merge_unify_flags = fl; - subterm_unify_flags = fl; - allow_K_in_toplevel_higher_order_unification = false; - resolve_evars = false -} - -let rec eq_constr_mod_evars x y = - match kind_of_term x, kind_of_term y with - | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true - | _, _ -> compare_constr eq_constr_mod_evars x y - -let progress_evars t = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let check = - Proofview.Goal.nf_enter { enter = begin fun gl' -> - let newconcl = Proofview.Goal.concl gl' in - if eq_constr_mod_evars concl newconcl - then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)") - else Proofview.tclUNIT () - end } - in t <*> check - end } - - -let e_give_exact flags poly (c,clenv) gl = - let (c, _, _) = c in - let c, gl = - if poly then - let clenv', subst = Clenv.refresh_undefined_univs clenv in - let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in - let c = Vars.subst_univs_level_constr subst c in - c, {gl with sigma = evd} - else c, gl - in - let t1 = pf_unsafe_type_of gl c in - tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl - -let unify_e_resolve poly flags = { enter = begin fun gls (c,clenv) -> - let clenv', c = connect_hint_clenv poly c clenv gls in - let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in - Clenvtac.clenv_refine true ~with_classes:false clenv' - end } - -let unify_resolve poly flags = { enter = begin fun gls (c,clenv) -> - let clenv', _ = connect_hint_clenv poly c clenv gls in - let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in - Clenvtac.clenv_refine false ~with_classes:false clenv' - end } - -let clenv_of_prods poly nprods (c, clenv) gl = - let (c, _, _) = c in - if poly || Int.equal nprods 0 then Some clenv - else - let ty = Tacmach.New.pf_unsafe_type_of gl c in - let diff = nb_prod ty - nprods in - if Pervasives.(>=) diff 0 then - (* Was Some clenv... *) - Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) - else None - -let with_prods nprods poly (c, clenv) f = - Proofview.Goal.nf_enter { enter = begin fun gl -> - match clenv_of_prods poly nprods (c, clenv) gl with - | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some clenv' -> f.enter gl (c, clenv') - end } - -(** Hack to properly solve dependent evars that are typeclasses *) - -let rec e_trivial_fail_db db_list local_db goal = - let tacl = - Proofview.V82.of_tactic Eauto.registered_e_assumption :: - (tclTHEN (Proofview.V82.of_tactic Tactics.intro) - (function g'-> - let d = pf_last_hyp g' in - let hintl = make_resolve_hyp (pf_env g') (project g') d in - (e_trivial_fail_db db_list - (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: - (List.map (fun (x,_,_,_,_) -> x) - (e_trivial_resolve db_list local_db (project goal) (pf_concl goal))) - in - tclFIRST (List.map tclCOMPLETE tacl) goal - -and e_my_find_search db_list local_db hdc complete sigma concl = - let prods, concl = decompose_prod_assum concl in - let nprods = List.length prods in - let freeze = - try - let cl = Typeclasses.class_info (fst hdc) in - if cl.cl_strict then - Evd.evars_of_term concl - else Evar.Set.empty - with e when Errors.noncritical e -> Evar.Set.empty - in - let hintl = - List.map_append - (fun db -> - let tacs = - if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto hdc concl db - else Hint_db.map_existential hdc concl db - in - let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in - List.map (fun x -> (flags, x)) tacs) - (local_db::db_list) - in - let tac_of_hint = - fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> - let tac = function - | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) - | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) - | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) - | Res_pf_THEN_trivial_fail (term,cl) -> - Proofview.V82.tactic (tclTHEN - (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) - (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) - | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]))) - | Extern tacast -> conclPattern concl p tacast - in - let tac = Proofview.V82.of_tactic (run_hint t tac) in - let tac = if complete then tclCOMPLETE tac else tac in - match repr_hint t with - | Extern _ -> (tac,b,true, name, lazy (pr_hint t)) - | _ -> -(* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) - (tac,b,false, name, lazy (pr_hint t)) - in List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db sigma concl = - try - e_my_find_search db_list local_db - (decompose_app_bound concl) true sigma concl - with Bound | Not_found -> [] - -let e_possible_resolve db_list local_db sigma concl = - try - e_my_find_search db_list local_db - (decompose_app_bound concl) false sigma concl - with Bound | Not_found -> [] - -let catchable = function - | Refiner.FailError _ -> true - | e -> Logic.catchable_exception e - -let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) - -let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) - -type autoinfo = { hints : hint_db; is_evar: existential_key option; - only_classes: bool; unique : bool; - auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; - auto_path : global_reference option list; - auto_cut : hints_path } -type autogoal = goal * autoinfo -type failure = NotApplicable | ReachedLimit -type 'ans fk = failure -> 'ans -type ('a,'ans) sk = 'a -> 'ans fk -> 'ans -type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } - -type auto_result = autogoal list sigma - -type atac = auto_result tac - -(* Some utility types to avoid the need of -rectypes *) - -type 'a optionk = - | Nonek - | Somek of 'a * 'a optionk fk - -type ('a,'b) optionk2 = - | Nonek2 of failure - | Somek2 of 'a * 'b * ('a,'b) optionk2 fk - -let make_resolve_hyp env sigma st flags only_classes pri decl = - let open Context.Named.Declaration in - let id = get_id decl in - let cty = Evarutil.nf_evar sigma (get_type decl) in - let rec iscl env ty = - let ctx, ar = decompose_prod_assum ty in - match kind_of_term (fst (decompose_app ar)) with - | Const (c,_) -> is_class (ConstRef c) - | Ind (i,_) -> is_class (IndRef i) - | _ -> - let env' = Environ.push_rel_context ctx env in - let ty' = whd_betadeltaiota env' ar in - if not (Term.eq_constr ty' ar) then iscl env' ty' - else false - in - let is_class = iscl env cty in - let keep = not only_classes || is_class in - if keep then - let c = mkVar id in - let name = PathHints [VarRef id] in - let hints = - if is_class then - let hints = build_subclasses ~check:false env sigma (VarRef id) None in - (List.map_append - (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) - (true,false,Flags.is_verbose()) pri false - (IsConstr (c,Univ.ContextSet.empty))) - hints) - else [] - in - (hints @ List.map_filter - (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) - with Failure _ | UserError _ -> None) - [make_exact_entry ~name env sigma pri false; - make_apply_entry ~name env sigma flags pri false]) - else [] - -let pf_filtered_hyps gls = - Goal.V82.hyps gls.Evd.sigma (sig_it gls) - -let make_hints g st only_classes sign = - let paths, hintlist = - List.fold_left - (fun (paths, hints) hyp -> - let consider = - let open Context.Named.Declaration in - try let t = Global.lookup_named (get_id hyp) |> get_type in - (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (get_type hyp)) - with Not_found -> true - in - if consider then - let path, hint = - PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp - in - (PathOr (paths, path), hint @ hints) - else (paths, hints)) - (PathEmpty, []) sign - in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) - -let make_autogoal_hints = - let cache = ref (true, Environ.empty_named_context_val, - Hint_db.empty full_transparent_state true) - in - fun only_classes ?(st=full_transparent_state) g -> - let sign = pf_filtered_hyps g in - let (onlyc, sign', cached_hints) = !cache in - if onlyc == only_classes && - (sign == sign' || Environ.eq_named_context_val sign sign') - && Hint_db.transparent_state cached_hints == st - then - cached_hints - else - let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in - cache := (only_classes, sign, hints); hints - -let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = - { skft = fun sk fk {it = gl,hints; sigma=s;} -> - let res = try Some (tac {it=gl; sigma=s;}) - with e when catchable e -> None in - match res with - | Some gls -> sk (f gls hints) fk - | None -> fk NotApplicable } - -let intro_tac : atac = - lift_tactic (Proofview.V82.of_tactic Tactics.intro) - (fun {it = gls; sigma = s} info -> - let gls' = - List.map (fun g' -> - let env = Goal.V82.env s g' in - let context = Environ.named_context_of_val (Goal.V82.hyps s g') in - let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) - (true,false,false) info.only_classes None (List.hd context) in - let ldb = Hint_db.add_list env s hint info.hints in - (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls - in {it = gls'; sigma = s;}) - -let normevars_tac : atac = - { skft = fun sk fk {it = (gl, info); sigma = s;} -> - let gl', sigma' = Goal.V82.nf_evar s gl in - let info' = { info with auto_last_tac = lazy (str"normevars") } in - sk {it = [gl', info']; sigma = sigma';} fk } - -let merge_failures x y = - match x, y with - | _, ReachedLimit - | ReachedLimit, _ -> ReachedLimit - | NotApplicable, NotApplicable -> NotApplicable - -let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft sk - (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls } - -let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft sk - (fun f -> (y f).skft sk fk gls) gls } - -let is_Prop env sigma concl = - let ty = Retyping.get_type_of env sigma concl in - match kind_of_term ty with - | Sort (Prop Null) -> true - | _ -> false - -let is_unique env concl = - try - let (cl,u), args = dest_class_app env concl in - cl.cl_unique - with e when Errors.noncritical e -> false - -let needs_backtrack env evd oev concl = - if Option.is_empty oev || is_Prop env evd concl then - occur_existential concl - else true - -let hints_tac hints = - { skft = fun sk fk {it = gl,info; sigma = s;} -> - let env = Goal.V82.env s gl in - let concl = Goal.V82.concl s gl in - let tacgl = {it = gl; sigma = s;} in - let poss = e_possible_resolve hints info.hints s concl in - let unique = is_unique env concl in - let rec aux i foundone = function - | (tac, _, b, name, pp) :: tl -> - let derivs = path_derivate info.auto_cut name in - let res = - try - if path_matches derivs [] then None else Some (tac tacgl) - with e when catchable e -> None - in - (match res with - | None -> aux i foundone tl - | Some {it = gls; sigma = s';} -> - if !typeclasses_debug then - msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev s gl); - let sgls = - evars_to_goals - (fun evm ev evi -> - if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && - (not info.only_classes || Typeclasses.is_class_evar evm evi) - then Typeclasses.mark_unresolvable evi, true - else evi, false) s' - in - let newgls, s' = - let gls' = List.map (fun g -> (None, g)) gls in - match sgls with - | None -> gls', s' - | Some (evgls, s') -> - if not !typeclasses_dependency_order then - (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') - else - (* Reorder with dependent subgoals. *) - let evm = List.fold_left - (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in - let gls = top_sort s' evm in - (List.map (fun ev -> Some ev, ev) gls, s') - in - let gls' = List.map_i - (fun j (evar, g) -> - let info = - { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; - is_evar = evar; - hints = - if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) - (Goal.V82.hyps s' gl)) - then make_autogoal_hints info.only_classes - ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s';} - else info.hints; - auto_cut = derivs } - in g, info) 1 newgls in - let glsv = {it = gls'; sigma = s';} in - let fk' = - (fun e -> - let do_backtrack = - if unique then occur_existential concl - else if info.unique then true - else if List.is_empty gls' then - needs_backtrack env s' info.is_evar concl - else true - in - let e' = match foundone with None -> e | Some e' -> merge_failures e e' in - if !typeclasses_debug then - msg_debug - ((if do_backtrack then str"Backtracking after " - else str "Not backtracking after ") - ++ Lazy.force pp); - if do_backtrack then aux (succ i) (Some e') tl - else fk e') - in - sk glsv fk') - | [] -> - if foundone == None && !typeclasses_debug then - msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ - Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ - spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); - match foundone with - | Some e -> fk e - | None -> fk NotApplicable - in aux 1 None poss } - -let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = - let rec aux s (acc : autogoal list list) fk = function - | (gl,info) :: gls -> - Control.check_for_interrupt (); - (match info.is_evar with - | Some ev when Evd.is_defined s ev -> aux s acc fk gls - | _ -> - second.skft - (fun {it=gls';sigma=s'} fk' -> - let fk'' = - if not info.unique && List.is_empty gls' && - not (needs_backtrack (Goal.V82.env s gl) s - info.is_evar (Goal.V82.concl s gl)) - then fk - else fk' - in - aux s' (gls'::acc) fk'' gls) - fk {it = (gl,info); sigma = s; }) - | [] -> Somek2 (List.rev acc, s, fk) - in fun {it = gls; sigma = s; } fk -> - let rec aux' = function - | Nonek2 e -> fk e - | Somek2 (res, s', fk') -> - let goals' = List.concat res in - sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e)) - in aux' (aux s [] (fun e -> Nonek2 e) gls) - -let then_tac (first : atac) (second : atac) : atac = - { skft = fun sk fk -> first.skft (then_list second sk) fk } - -let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = - t.skft (fun x _ -> Some x) (fun _ -> None) gl - -type run_list_res = auto_result optionk - -let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = - (then_list t (fun x fk -> Somek (x, fk))) - gl - (fun _ -> Nonek) - -let fail_tac reason : atac = - { skft = fun sk fk _ -> fk reason } - -let rec fix (t : 'a tac) : 'a tac = - then_tac t { skft = fun sk fk -> (fix t).skft sk fk } - -let rec fix_limit limit (t : 'a tac) : 'a tac = - if Int.equal limit 0 then fail_tac ReachedLimit - else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } - -let fix_iterative t = - let rec aux depth = - or_else_tac (fix_limit depth t) - (function - | NotApplicable as e -> fail_tac e - | ReachedLimit -> aux (succ depth)) - in aux 1 - -let fix_iterative_limit limit (t : 'a tac) : 'a tac = - let rec aux depth = - if Int.equal depth limit then fail_tac ReachedLimit - else or_tac (fix_limit depth t) { skft = fun sk fk -> (aux (succ depth)).skft sk fk } - in aux 1 - -let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g = - let hints = make_autogoal_hints only_classes ~st g in - (g.it, { hints = hints ; is_evar = ev; unique = unique; - only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); - auto_path = []; auto_cut = cut }) - - -let cut_of_hints h = - List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h - -let make_autogoals ?(only_classes=true) ?(unique=false) - ?(st=full_transparent_state) hints gs evm' = - let cut = cut_of_hints hints in - { it = List.map_i (fun i g -> - let (gl, auto) = make_autogoal ~only_classes ~unique - ~st cut (Some g) {it = g; sigma = evm'; } in - (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; } - -let get_result r = - match r with - | Nonek -> None - | Somek (gls, fk) -> Some (gls.sigma,fk) - -let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) p evm hints tac = - match evars_to_goals p evm with - | None -> None (* This happens only because there's no evar having p *) - | Some (goals, evm') -> - let goals = - if !typeclasses_dependency_order then - top_sort evm' goals - else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) - in - let res = run_list_tac tac p goals - (make_autogoals ~only_classes ~unique ~st hints goals evm') in - match get_result res with - | None -> raise Not_found - | Some (evm', fk) -> - Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) - -let eauto_tac hints = - then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) - -let eauto_tac ?limit hints = - if get_typeclasses_iterative_deepening () then - match limit with - | None -> fix_iterative (eauto_tac hints) - | Some limit -> fix_iterative_limit limit (eauto_tac hints) - else - match limit with - | None -> fix (eauto_tac hints) - | Some limit -> fix_limit limit (eauto_tac hints) - -let real_eauto ?limit unique st hints p evd = - let res = - run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints) - in - match res with - | None -> evd - | Some (evd', fk) -> - if unique then - (match get_result (fk NotApplicable) with - | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" - | None -> evd') - else evd' - -let resolve_all_evars_once debug limit unique p evd = - let db = searchtable_map typeclasses_db in - real_eauto ?limit unique (Hint_db.transparent_state db) [db] p evd - -let eauto ?(only_classes=true) ?st ?limit hints g = - let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in - match run_tac (eauto_tac ?limit hints) gl with - | None -> raise Not_found - | Some {it = goals; sigma = s; } -> - {it = List.map fst goals; sigma = s;} - -(** We compute dependencies via a union-find algorithm. - Beware of the imperative effects on the partition structure, - it should not be shared, but only used locally. *) - -module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) - -let deps_of_constraints cstrs evm p = - List.iter (fun (_, _, x, y) -> - let evx = Evarutil.undefined_evars_of_term evm x in - let evy = Evarutil.undefined_evars_of_term evm y in - Intpart.union_set (Evar.Set.union evx evy) p) - cstrs - -let evar_dependencies evm p = - Evd.fold_undefined - (fun ev evi _ -> - let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) - in Intpart.union_set evars p) - evm () - -let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = - let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in - let (gl,t,sigma) = - Goal.V82.mk_goal sigma nc gl Store.empty in - let gls = { it = gl ; sigma = sigma; } in - let hints = searchtable_map typeclasses_db in - let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in - let evd = sig_sig gls' in - let t' = let (ev, inst) = destEvar t in - mkEvar (ev, Array.of_list subst) - in - let term = Evarutil.nf_evar evd t' in - evd, term - -let _ = - Typeclasses.solve_instantiation_problem := - (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) - -(** [split_evars] returns groups of undefined evars according to dependencies *) - -let split_evars evm = - let p = Intpart.create () in - evar_dependencies evm p; - deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; - Intpart.partition p - -let is_inference_forced p evd ev = - try - let evi = Evd.find_undefined evd ev in - if Typeclasses.is_resolvable evi && snd (p ev evi) - then - let (loc, k) = evar_source ev evd in - match k with - | Evar_kinds.ImplicitArg (_, _, b) -> b - | Evar_kinds.QuestionMark _ -> false - | _ -> true - else true - with Not_found -> assert false - -let is_mandatory p comp evd = - Evar.Set.exists (is_inference_forced p evd) comp - -(** In case of unsatisfiable constraints, build a nice error message *) - -let error_unresolvable env comp evd = - let evd = Evarutil.nf_evar_map_undefined evd in - let is_part ev = match comp with - | None -> true - | Some s -> Evar.Set.mem ev s - in - let fold ev evi (found, accu) = - let ev_class = class_of_constr evi.evar_concl in - if not (Option.is_empty ev_class) && is_part ev then - (* focus on one instance if only one was searched for *) - if not found then (true, Some ev) - else (found, None) - else (found, accu) - in - let (_, ev) = Evd.fold_undefined fold evd (true, None) in - Pretype_errors.unsatisfiable_constraints - (Evarutil.nf_env_evar evd env) evd ev comp - -(** Check if an evar is concerned by the current resolution attempt, - (and in particular is in the current component), and also update - its evar_info. - Invariant : this should only be applied to undefined evars, - and return undefined evar_info *) - -let select_and_update_evars p oevd in_comp evd ev evi = - assert (evi.evar_body == Evar_empty); - try - let oevi = Evd.find_undefined oevd ev in - if Typeclasses.is_resolvable oevi then - Typeclasses.mark_unresolvable evi, - (in_comp ev && p evd ev evi) - else evi, false - with Not_found -> - Typeclasses.mark_unresolvable evi, p evd ev evi - -(** Do we still have unresolved evars that should be resolved ? *) - -let has_undefined p oevd evd = - let check ev evi = snd (p oevd ev evi) in - Evar.Map.exists check (Evd.undefined_map evd) - -(** Revert the resolvability status of evars after resolution, - potentially unprotecting some evars that were set unresolvable - just for this call to resolution. *) - -let revert_resolvability oevd evd = - let map ev evi = - try - if not (Typeclasses.is_resolvable evi) then - let evi' = Evd.find_undefined oevd ev in - if Typeclasses.is_resolvable evi' then - Typeclasses.mark_resolvable evi - else evi - else evi - with Not_found -> evi - in - Evd.raw_map_undefined map evd - -(** If [do_split] is [true], we try to separate the problem in - several components and then solve them separately *) - -exception Unresolved - -let resolve_all_evars debug m unique env p oevd do_split fail = - let split = if do_split then split_evars oevd else [Evar.Set.empty] in - let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true - in - let rec docomp evd = function - | [] -> revert_resolvability oevd evd - | comp :: comps -> - let p = select_and_update_evars p oevd (in_comp comp) in - try - let evd' = resolve_all_evars_once debug m unique p evd in - if has_undefined p oevd evd' then raise Unresolved; - docomp evd' comps - with Unresolved | Not_found -> - if fail && (not do_split || is_mandatory (p evd) comp evd) - then (* Unable to satisfy the constraints. *) - let comp = if do_split then Some comp else None in - error_unresolvable env comp evd - else (* Best effort: do nothing on this component *) - docomp evd comps - in docomp oevd split - -let initial_select_evars filter = - fun evd ev evi -> - filter ev (snd evi.Evd.evar_source) && - Typeclasses.is_class_evar evd evi - -let resolve_typeclass_evars debug m unique env evd filter split fail = - let evd = - try Evarconv.consider_remaining_unif_problems - ~ts:(Typeclasses.classes_transparent_state ()) env evd - with e when Errors.noncritical e -> evd - in - resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail - -let solve_inst debug depth env evd filter unique split fail = - resolve_typeclass_evars debug depth unique env evd filter split fail - -let _ = - Typeclasses.solve_instantiations_problem := - solve_inst false !typeclasses_depth - -let set_typeclasses_debug d = (:=) typeclasses_debug d; - Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth - -let get_typeclasses_debug () = !typeclasses_debug - -let set_typeclasses_depth d = (:=) typeclasses_depth d; - Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth - -let get_typeclasses_depth () = !typeclasses_depth - -open Goptions - -let set_typeclasses_debug = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "debug output for typeclasses proof search"; - optkey = ["Typeclasses";"Debug"]; - optread = get_typeclasses_debug; - optwrite = set_typeclasses_debug; } - -let set_typeclasses_depth = - declare_int_option - { optsync = true; - optdepr = false; - optname = "depth for typeclasses proof search"; - optkey = ["Typeclasses";"Depth"]; - optread = get_typeclasses_depth; - optwrite = set_typeclasses_depth; } - -let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = - try - let dbs = List.map_filter - (fun db -> try Some (searchtable_map db) - with e when Errors.noncritical e -> None) - dbs - in - let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in - eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl - with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl - -(** Take the head of the arity of a constr. - Used in the partial application tactic. *) - -let rec head_of_constr t = - let t = strip_outer_cast(collapse_appl t) in - match kind_of_term t with - | Prod (_,_,c2) -> head_of_constr c2 - | LetIn (_,_,_,c2) -> head_of_constr c2 - | App (f,args) -> head_of_constr f - | _ -> t - -let head_of_constr h c = - let c = head_of_constr c in - letin_tac None (Name h) c None Locusops.allHyps - -let not_evar c = match kind_of_term c with -| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") -| _ -> Proofview.tclUNIT () - -let is_ground c gl = - if Evarutil.is_ground_term (project gl) c then tclIDTAC gl - else tclFAIL 0 (str"Not ground") gl - -let autoapply c i gl = - let flags = auto_unif_flags Evar.Set.empty - (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in - let cty = pf_unsafe_type_of gl c in - let ce = mk_clenv_from gl (c,cty) in - let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),ce) } in - Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli deleted file mode 100644 index f1bcfa7dd4..0000000000 --- a/tactics/class_tactics.mli +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool - -val set_typeclasses_debug : bool -> unit -val get_typeclasses_debug : unit -> bool - -val set_typeclasses_depth : int option -> unit -val get_typeclasses_depth : unit -> int option - -val progress_evars : unit Proofview.tactic -> unit Proofview.tactic - -val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> - Hints.hint_db_name list -> tactic - -val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic - -val not_evar : constr -> unit Proofview.tactic - -val is_ground : constr -> tactic - -val autoapply : constr -> Hints.hint_db_name -> tactic diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 deleted file mode 100644 index 6c02a7202f..0000000000 --- a/tactics/coretactics.ml4 +++ /dev/null @@ -1,299 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ Tactics.intros_reflexivity ] -END - -TACTIC EXTEND assumption - [ "assumption" ] -> [ Tactics.assumption ] -END - -TACTIC EXTEND etransitivity - [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] -END - -TACTIC EXTEND cut - [ "cut" constr(c) ] -> [ Tactics.cut c ] -END - -TACTIC EXTEND exact_no_check - [ "exact_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.exact_no_check c) ] -END - -TACTIC EXTEND vm_cast_no_check - [ "vm_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ] -END - -TACTIC EXTEND native_cast_no_check - [ "native_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.native_cast_no_check c) ] -END - -TACTIC EXTEND casetype - [ "casetype" constr(c) ] -> [ Tactics.case_type c ] -END - -TACTIC EXTEND elimtype - [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] -END - -TACTIC EXTEND lapply - [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] -END - -TACTIC EXTEND transitivity - [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] -END - -(** Left *) - -TACTIC EXTEND left - [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] -END - -TACTIC EXTEND eleft - [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] -END - -TACTIC EXTEND left_with - [ "left" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) - ] -END - -TACTIC EXTEND eleft_with - [ "eleft" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) - ] -END - -(** Right *) - -TACTIC EXTEND right - [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] -END - -TACTIC EXTEND eright - [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] -END - -TACTIC EXTEND right_with - [ "right" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) - ] -END - -TACTIC EXTEND eright_with - [ "eright" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) - ] -END - -(** Constructor *) - -TACTIC EXTEND constructor - [ "constructor" ] -> [ Tactics.any_constructor false None ] -| [ "constructor" int_or_var(i) ] -> [ - Tactics.constructor_tac false None i NoBindings - ] -| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ - let tac bl = Tactics.constructor_tac false None i bl in - Tacticals.New.tclDELAYEDWITHHOLES false bl tac - ] -END - -TACTIC EXTEND econstructor - [ "econstructor" ] -> [ Tactics.any_constructor true None ] -| [ "econstructor" int_or_var(i) ] -> [ - Tactics.constructor_tac true None i NoBindings - ] -| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ - let tac bl = Tactics.constructor_tac true None i bl in - Tacticals.New.tclDELAYEDWITHHOLES true bl tac - ] -END - -(** Specialize *) - -TACTIC EXTEND specialize - [ "specialize" constr_with_bindings(c) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false c Tactics.specialize - ] -END - -TACTIC EXTEND symmetry - [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] -| [ "symmetry" clause_dft_concl(cl) ] -> [ Tactics.intros_symmetry cl ] -END - -(** Split *) - -let rec delayed_list = function -| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } -| x :: l -> - { Tacexpr.delayed = fun env sigma -> - let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in - let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in - Sigma (x :: l, sigma, p +> q) } - -TACTIC EXTEND split - [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] -END - -TACTIC EXTEND esplit - [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] -END - -TACTIC EXTEND split_with - [ "split" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) - ] -END - -TACTIC EXTEND esplit_with - [ "esplit" "with" bindings(bl) ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) - ] -END - -TACTIC EXTEND exists - [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] -| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) - ] -END - -TACTIC EXTEND eexists - [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] -| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ - Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) - ] -END - -(** Intro *) - -TACTIC EXTEND intros_until - [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] -END - -(** Move *) - -TACTIC EXTEND move - [ "move" hyp(id) "at" "top" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveFirst) ] -| [ "move" hyp(id) "at" "bottom" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveLast) ] -| [ "move" hyp(id) "after" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveAfter h)) ] -| [ "move" hyp(id) "before" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveBefore h)) ] -END - -(** Revert *) - -TACTIC EXTEND revert - [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] -END - -(** Simple induction / destruct *) - -TACTIC EXTEND simple_induction - [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ] -END - -TACTIC EXTEND simple_destruct - [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] -END - -(* Admit *) - -TACTIC EXTEND admit - [ "admit" ] -> [ Proofview.give_up ] -END - -(* Fix *) - -TACTIC EXTEND fix - [ "fix" natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix None n) ] -| [ "fix" ident(id) natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix (Some id) n) ] -END - -(* Cofix *) - -TACTIC EXTEND cofix - [ "cofix" ] -> [ Proofview.V82.tactic (Tactics.cofix None) ] -| [ "cofix" ident(id) ] -> [ Proofview.V82.tactic (Tactics.cofix (Some id)) ] -END - -(* Clear *) - -TACTIC EXTEND clear - [ "clear" hyp_list(ids) ] -> [ - if List.is_empty ids then Tactics.keep [] - else Proofview.V82.tactic (Tactics.clear ids) - ] -| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] -END - -(* Clearbody *) - -TACTIC EXTEND clearbody - [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] -END - -(* Generalize dependent *) - -TACTIC EXTEND generalize_dependent - [ "generalize" "dependent" constr(c) ] -> [ Proofview.V82.tactic (Tactics.generalize_dep c) ] -END - -(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) - -open Tacexpr - -let initial_atomic () = - let dloc = Loc.ghost in - let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in - let iter (s, t) = - let body = TacAtom (dloc, t) in - Tacenv.register_ltac false false (Id.of_string s) body - in - let () = List.iter iter - [ "red", TacReduce(Red false,nocl); - "hnf", TacReduce(Hnf,nocl); - "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); - "compute", TacReduce(Cbv Redops.all_flags,nocl); - "intro", TacIntroMove(None,MoveLast); - "intros", TacIntroPattern []; - ] - in - let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in - List.iter iter - [ "idtac",TacId []; - "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(dloc,TacFreshId []) - ] - -let () = Mltop.declare_cache_obj initial_atomic "coretactics" diff --git a/tactics/eauto.ml b/tactics/eauto.ml deleted file mode 100644 index 0449467598..0000000000 --- a/tactics/eauto.ml +++ /dev/null @@ -1,526 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let t1 = Tacmach.New.pf_unsafe_type_of gl c in - let t2 = Tacmach.New.pf_concl gl in - if occur_existential t1 || occur_existential t2 then - Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) - else exact_check c - end } - -let assumption id = e_give_exact (mkVar id) - -let e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) - end } - -let registered_e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) - (Tacmach.New.pf_ids_of_hyps gl)) - end } - -let eval_uconstrs ist cs = - let flags = { - Pretyping.use_typeclasses = false; - use_unif_heuristics = true; - use_hook = Some Pfedit.solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true - } in - List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs - -(************************************************************************) -(* PROLOG tactic *) -(************************************************************************) - -(*s Tactics handling a list of goals. *) - -(* first_goal : goal list sigma -> goal sigma *) - -let first_goal gls = - let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in - if List.is_empty gl then error "first_goal"; - { Evd.it = List.hd gl; Evd.sigma = sig_0; } - -(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) - -let apply_tac_list tac glls = - let (sigr,lg) = unpackage glls in - match lg with - | (g1::rest) -> - let gl = apply_sig_tac sigr tac g1 in - repackage sigr (gl@rest) - | _ -> error "apply_tac_list" - -let one_step l gl = - [Proofview.V82.of_tactic Tactics.intro] - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) - @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) - -let rec prolog l n gl = - if n <= 0 then error "prolog - failure"; - let prol = (prolog l (n-1)) in - (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl - -let out_term = function - | IsConstr (c, _) -> c - | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) - -let prolog_tac l n = - Proofview.V82.tactic begin fun gl -> - let map c = - let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in - let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in - out_term c - in - let l = List.map map l in - try (prolog l n gl) - with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" (str "Prolog failed.") - end - -open Auto -open Unification - -(***************************************************************************) -(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) -(***************************************************************************) - -let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) - -let unify_e_resolve poly flags (c,clenv) = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let clenv', c = connect_hint_clenv poly c clenv gl in - Proofview.V82.tactic - (fun gls -> - let clenv' = clenv_unique_resolver ~flags clenv' gls in - tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) - end } - -let hintmap_of hdc concl = - match hdc with - | None -> fun db -> Hint_db.map_none db - | Some hdc -> - if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) - else (fun db -> Hint_db.map_auto hdc concl db) - (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) - -let e_exact poly flags (c,clenv) = - let (c, _, _) = c in - let clenv', subst = - if poly then Clenv.refresh_undefined_univs clenv - else clenv, Univ.empty_level_subst - in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) - -let rec e_trivial_fail_db db_list local_db = - let next = Proofview.Goal.nf_enter { enter = begin fun gl -> - let d = Tacmach.New.pf_last_hyp gl in - let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in - e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) - end } in - Proofview.Goal.enter { enter = begin fun gl -> - let tacl = - registered_e_assumption :: - (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) - in - Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) - end } - -and e_my_find_search db_list local_db hdc concl = - let hint_of_db = hintmap_of hdc concl in - let hintl = - List.map_append (fun db -> - let flags = auto_flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, {pri = b; pat = p; code = t; poly = poly}) -> - let b = match Hints.repr_hint t with - | Unfold_nth _ -> 1 - | _ -> b - in - (b, - let tac = function - | Res_pf (term,cl) -> unify_resolve poly st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) - | Give_exact (c,cl) -> e_exact poly st (c,cl) - | Res_pf_THEN_trivial_fail (term,cl) -> - Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) - (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl - | Extern tacast -> conclPattern concl p tacast - in - let tac = run_hint t tac in - (tac, lazy (pr_hint t))) - in - List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in - try priority (e_my_find_search db_list local_db hd gl) - with Not_found -> [] - -let e_possible_resolve db_list local_db gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in - try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) - with Not_found -> [] - -let find_first_goal gls = - try first_goal gls with UserError _ -> assert false - -(*s The following module [SearchProblem] is used to instantiate the generic - exploration functor [Explore.Make]. *) - -type search_state = { - priority : int; - depth : int; (*r depth of search before failing *) - tacres : goal list sigma; - last_tactic : std_ppcmds Lazy.t; - dblist : hint_db list; - localdb : hint_db list; - prev : prev_search_state; - local_lemmas : Tacexpr.delayed_open_constr list; -} - -and prev_search_state = (* for info eauto *) - | Unknown - | Init - | State of search_state - -module SearchProblem = struct - - type state = search_state - - let success s = List.is_empty (sig_it s.tacres) - -(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) - - let filter_tactics glls l = -(* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) -(* let evars = Evarutil.nf_evars (Refiner.project glls) in *) -(* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) - let rec aux = function - | [] -> [] - | (tac, cost, pptac) :: tacl -> - try - let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in -(* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) -(* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) - (lgls, cost, pptac) :: aux tacl - with e when Errors.noncritical e -> - let e = Errors.push e in - Refiner.catch_failerror e; aux tacl - in aux l - - (* Ordering of states is lexicographic on depth (greatest first) then - number of remaining goals. *) - let compare s s' = - let d = s'.depth - s.depth in - let d' = Int.compare s.priority s'.priority in - let nbgoals s = List.length (sig_it s.tacres) in - if not (Int.equal d 0) then d - else if not (Int.equal d' 0) then d' - else Int.compare (nbgoals s) (nbgoals s') - - let branching s = - if Int.equal s.depth 0 then - [] - else - let ps = if s.prev == Unknown then Unknown else State s in - let lg = s.tacres in - let nbgl = List.length (sig_it lg) in - assert (nbgl > 0); - let g = find_first_goal lg in - let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in - let assumption_tacs = - let tacs = List.map map_assum (pf_ids_of_hyps g) in - let l = filter_tactics s.tacres tacs in - List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = List.tl s.localdb; - prev = ps; local_lemmas = s.local_lemmas}) l - in - let intro_tac = - let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in - List.map - (fun (lgls, cost, pp) -> - let g' = first_goal lgls in - let hintl = - make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in - let ldb = Hint_db.add_list (pf_env g') (project g') - hintl (List.hd s.localdb) in - { depth = s.depth; priority = cost; tacres = lgls; - last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb; prev = ps; - local_lemmas = s.local_lemmas}) - l - in - let rec_tacs = - let l = - filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) - in - List.map - (fun (lgls, cost, pp) -> - let nbgl' = List.length (sig_it lgls) in - if nbgl' < nbgl then - { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; - prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; - local_lemmas = s.local_lemmas } - else - let newlocal = - let hyps = pf_hyps g in - List.map (fun gl -> - let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in - let hyps' = pf_hyps gls in - if hyps' == hyps then List.hd s.localdb - else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) - (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) - in - { depth = pred s.depth; priority = cost; tacres = lgls; - dblist = s.dblist; last_tactic = pp; prev = ps; - localdb = newlocal @ List.tl s.localdb; - local_lemmas = s.local_lemmas }) - l - in - List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - - let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ - (Lazy.force s.last_tactic)) - -end - -module Search = Explore.Make(SearchProblem) - -(** Utilities for debug eauto / info eauto *) - -let global_debug_eauto = ref false -let global_info_eauto = ref false - -let _ = - Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; - Goptions.optname = "Debug Eauto"; - Goptions.optkey = ["Debug";"Eauto"]; - Goptions.optread = (fun () -> !global_debug_eauto); - Goptions.optwrite = (:=) global_debug_eauto } - -let _ = - Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; - Goptions.optname = "Info Eauto"; - Goptions.optkey = ["Info";"Eauto"]; - Goptions.optread = (fun () -> !global_info_eauto); - Goptions.optwrite = (:=) global_info_eauto } - -let mk_eauto_dbg d = - if d == Debug || !global_debug_eauto then Debug - else if d == Info || !global_info_eauto then Info - else Off - -let pr_info_nop = function - | Info -> msg_debug (str "idtac.") - | _ -> () - -let pr_dbg_header = function - | Off -> () - | Debug -> msg_debug (str "(* debug eauto : *)") - | Info -> msg_debug (str "(* info eauto : *)") - -let pr_info dbg s = - if dbg != Info then () - else - let rec loop s = - match s.prev with - | Unknown | Init -> s.depth - | State sp -> - let mindepth = loop sp in - let indent = String.make (mindepth - sp.depth) ' ' in - msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); - mindepth - in - ignore (loop s) - -(** Eauto main code *) - -let make_initial_state dbg n gl dblist localdb lems = - { depth = n; - priority = 0; - tacres = tclIDTAC gl; - last_tactic = lazy (mt()); - dblist = dblist; - localdb = [localdb]; - prev = if dbg == Info then Init else Unknown; - local_lemmas = lems; - } - -let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in - let d = mk_eauto_dbg debug in - let tac = match in_depth,d with - | (true,Debug) -> Search.debug_depth_first - | (true,_) -> Search.depth_first - | (false,Debug) -> Search.debug_breadth_first - | (false,_) -> Search.breadth_first - in - try - pr_dbg_header d; - let s = tac (make_initial_state d p gl db_list local_db lems) in - pr_info d s; - s.tacres - with Not_found -> - pr_info_nop d; - error "eauto: search failed" - -(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) -(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) - -let eauto_with_bases ?(debug=Off) np lems db_list = - tclTRY (e_search_auto debug np lems db_list) - -let eauto ?(debug=Off) np lems dbnames = - let db_list = make_db_list dbnames in - tclTRY (e_search_auto debug np lems db_list) - -let full_eauto ?(debug=Off) n lems gl = - let dbnames = current_db_names () in - let dbnames = String.Set.remove "v62" dbnames in - let db_list = List.map searchtable_map (String.Set.elements dbnames) in - tclTRY (e_search_auto debug n lems db_list) gl - -let gen_eauto ?(debug=Off) np lems = function - | None -> Proofview.V82.tactic (full_eauto ~debug np lems) - | Some l -> Proofview.V82.tactic (eauto ~debug np lems l) - -let make_depth = function - | None -> !default_search_depth - | Some d -> d - -let make_dimension n = function - | None -> (true,make_depth n) - | Some d -> (false,d) - -let cons a l = a :: l - -let autounfolds db occs cls gl = - let unfolds = List.concat (List.map (fun dbname -> - let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - let hyps = pf_ids_of_hyps gl in - let ids = Idset.filter (fun id -> List.mem id hyps) ids in - Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in Proofview.V82.of_tactic (unfold_option unfolds cls) gl - -let autounfold db cls = - Proofview.V82.tactic begin fun gl -> - let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in - let tac = autounfolds db in - tclMAP (function - | OnHyp (id,occs,where) -> tac occs (Some (id,where)) - | OnConcl occs -> tac occs None) - cls gl - end - -let autounfold_tac db cls = - Proofview.tclUNIT () >>= fun () -> - let dbs = match db with - | None -> String.Set.elements (current_db_names ()) - | Some [] -> ["core"] - | Some l -> l - in - autounfold dbs cls - -let unfold_head env (ids, csts) c = - let rec aux c = - match kind_of_term c with - | Var id when Id.Set.mem id ids -> - (match Environ.named_body id env with - | Some b -> true, b - | None -> false, c) - | Const (cst,u as c) when Cset.mem cst csts -> - true, Environ.constant_value_in env c - | App (f, args) -> - (match aux f with - | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) - | false, _ -> - let done_, args' = - Array.fold_left_i (fun i (done_, acc) arg -> - if done_ then done_, arg :: acc - else match aux arg with - | true, arg' -> true, arg' :: acc - | false, arg' -> false, arg :: acc) - (false, []) args - in - if done_ then true, mkApp (f, Array.of_list (List.rev args')) - else false, c) - | _ -> - let done_ = ref false in - let c' = map_constr (fun c -> - if !done_ then c else - let x, c' = aux c in - done_ := x; c') c - in !done_, c' - in aux c - -let autounfold_one db cl = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let st = - List.fold_left (fun (i,c) dbname -> - let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db - in - let did, c' = unfold_head env st - (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) - in - if did then - match cl with - | Some hyp -> change_in_hyp None (make_change_arg c') hyp - | None -> convert_concl_no_check c' DEFAULTcast - else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") - end } diff --git a/tactics/eauto.mli b/tactics/eauto.mli deleted file mode 100644 index 8812093d5f..0000000000 --- a/tactics/eauto.mli +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> unit Proofview.tactic - -val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic - -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> - hint_db_name list option -> unit Proofview.tactic - -val eauto_with_bases : - ?debug:Tacexpr.debug -> - bool * int -> - Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic - -val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic -val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic -val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic - -val make_dimension : int option -> int option -> bool * int diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml deleted file mode 100644 index 7d0df2f522..0000000000 --- a/tactics/eqdecide.ml +++ /dev/null @@ -1,225 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (clear [destVar c]))) - -let choose_eq eqonleft = - if eqonleft then - left_with_bindings false Misctypes.NoBindings - else - right_with_bindings false Misctypes.NoBindings -let choose_noteq eqonleft = - if eqonleft then - right_with_bindings false Misctypes.NoBindings - else - left_with_bindings false Misctypes.NoBindings - -let mkBranches c1 c2 = - tclTHENLIST - [Proofview.V82.tactic (generalize [c2]); - Simple.elim c1; - intros; - onLastHyp Simple.case; - clear_last; - intros] - -let solveNoteqBranch side = - tclTHEN (choose_noteq side) - (tclTHEN introf - (onLastHypId (fun id -> Extratactics.discrHyp id))) - -(* Constructs the type {c1=c2}+{~c1=c2} *) - -let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) - -let mkDecideEqGoal eqonleft op rectype c1 c2 = - let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in - let disequality = mkApp(build_coq_not (), [|equality|]) in - if eqonleft then mkApp(op, [|equality; disequality |]) - else mkApp(op, [|disequality; equality |]) - - -(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) - -let idx = Id.of_string "x" -let idy = Id.of_string "y" - -let mkGenDecideEqGoal rectype g = - let hypnames = pf_ids_of_hyps g in - let xname = next_ident_away idx hypnames - and yname = next_ident_away idy hypnames in - (mkNamedProd xname rectype - (mkNamedProd yname rectype - (mkDecideEqGoal true (build_coq_sumbool ()) - rectype (mkVar xname) (mkVar yname)))) - -let rec rewrite_and_clear hyps = match hyps with -| [] -> Proofview.tclUNIT () -| id :: hyps -> - tclTHENLIST [ - Equality.rewriteLR (mkVar id); - clear [id]; - rewrite_and_clear hyps; - ] - -let eqCase tac = - tclTHEN intro (onLastHypId tac) - -let diseqCase hyps eqonleft = - let diseq = Id.of_string "diseq" in - let absurd = Id.of_string "absurd" in - (tclTHEN (intro_using diseq) - (tclTHEN (choose_noteq eqonleft) - (tclTHEN (rewrite_and_clear (List.rev hyps)) - (tclTHEN (red_in_concl) - (tclTHEN (intro_using absurd) - (tclTHEN (Simple.apply (mkVar diseq)) - (tclTHEN (Extratactics.injHyp absurd) - (full_trivial [])))))))) - -open Proofview.Notations - -(* spiwack: a small wrapper around [Hipattern]. *) - -let match_eqdec c = - try Proofview.tclUNIT (match_eqdec c) - with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure - -(* /spiwack *) - -let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with -| [], [] -> - tclTHENLIST [ - choose_eq eqonleft; - rewrite_and_clear (List.rev hyps); - intros_reflexivity; - ] -| a1 :: largs, a2 :: rargs -> - Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl a1 in - let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in - let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in - let subtacs = - if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] - else [diseqCase hyps eqonleft;eqCase tac;default_auto] in - (tclTHENS (elim_type decide) subtacs) - end } -| _ -> invalid_arg "List.fold_right2" - -let solveEqBranch rectype = - Proofview.tclORELSE - begin - Proofview.Goal.enter { enter = begin fun gl -> - let concl = pf_nf_concl gl in - match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) -> - let (mib,mip) = Global.lookup_inductive rectype in - let nparams = mib.mind_nparams in - let getargs l = List.skipn nparams (snd (decompose_app l)) in - let rargs = getargs rhs - and largs = getargs lhs in - solveArg [] eqonleft op largs rargs - end } - end - begin function (e, info) -> match e with - | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") - | e -> Proofview.tclZERO ~info e - end - -(* The tactic Decide Equality *) - -let hd_app c = match kind_of_term c with - | App (h,_) -> h - | _ -> c - -let decideGralEquality = - Proofview.tclORELSE - begin - Proofview.Goal.enter { enter = begin fun gl -> - let concl = pf_nf_concl gl in - match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> - let headtyp = hd_app (pf_compute gl typ) in - begin match kind_of_term headtyp with - | Ind (mi,_) -> Proofview.tclUNIT mi - | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") - end >>= fun rectype -> - (tclTHEN - (mkBranches c1 c2) - (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) - end } - end - begin function (e, info) -> match e with - | PatternMatchingFailure -> - Tacticals.New.tclZEROMSG (Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.") - | e -> Proofview.tclZERO ~info e - end - -let decideEqualityGoal = tclTHEN intros decideGralEquality - -let decideEquality rectype = - Proofview.Goal.enter { enter = begin fun gl -> - let decide = mkGenDecideEqGoal rectype gl in - (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) - end } - - -(* The tactic Compare *) - -let compare c1 c2 = - Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl c1 in - let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in - (tclTHENS (cut decide) - [(tclTHEN intro - (tclTHEN (onLastHyp simplest_case) clear_last)); - decideEquality rectype]) - end } diff --git a/tactics/eqdecide.mli b/tactics/eqdecide.mli deleted file mode 100644 index cb48a5bcc8..0000000000 --- a/tactics/eqdecide.mli +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Constr.t -> unit Proofview.tactic diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml deleted file mode 100644 index 2e0996bf5a..0000000000 --- a/tactics/evar_tactics.ml +++ /dev/null @@ -1,91 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let sigma = gl.sigma in - let evl = - match ido with - ConclLocation () -> evar_list (pf_concl gl) - | HypLocation (id,hloc) -> - let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in - match hloc with - InHyp -> - (match decl with - | LocalAssum (_,typ) -> evar_list typ - | _ -> error - "Please be more specific: in type or value?") - | InHypTypeOnly -> - evar_list (get_type decl) - | InHypValueOnly -> - (match decl with - | LocalDef (_,body,_) -> evar_list body - | _ -> error "Not a defined hypothesis.") in - if List.length evl < n then - error "Not enough uninstantiated existential variables."; - if n <= 0 then error "Incorrect existential variable index."; - let evk,_ = List.nth evl (n-1) in - instantiate_evar evk c sigma gl - end - -let instantiate_tac_by_name id c = - Proofview.V82.tactic begin fun gl -> - let sigma = gl.sigma in - let evk = - try Evd.evar_key id sigma - with Not_found -> error "Unknown existential variable." in - instantiate_evar evk c sigma gl - end - -let let_evar name typ = - let src = (Loc.ghost,Evar_kinds.GoalEvar) in - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - let sigma = ref sigma in - let _ = Typing.e_sort_of env sigma typ in - let sigma = Sigma.Unsafe.of_evar_map !sigma in - let id = match name with - | Names.Anonymous -> - let id = Namegen.id_of_name_using_hdchar env typ name in - Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) - | Names.Name id -> id - in - let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in - let tac = - (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) - in - Sigma (tac, sigma, p) - end } diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli deleted file mode 100644 index e67540c055..0000000000 --- a/tactics/evar_tactics.mli +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Tacinterp.interp_sign * Glob_term.glob_constr -> - (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic - -val instantiate_tac_by_name : Id.t -> - Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic - -val let_evar : Name.t -> Term.types -> unit Proofview.tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 deleted file mode 100644 index d33ec91f9d..0000000000 --- a/tactics/extraargs.ml4 +++ /dev/null @@ -1,345 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* " - -let pr_orient _prc _prlc _prt = function - | true -> Pp.mt () - | false -> Pp.str " <-" - -ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient -| [ "->" ] -> [ true ] -| [ "<-" ] -> [ false ] -| [ ] -> [ true ] -END - -let pr_int _ _ _ i = Pp.int i - -let _natural = Pcoq.Prim.natural - -ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int -| [ _natural(i) ] -> [ i ] -END - -let pr_orient = pr_orient () () () - - -let pr_int_list = Pp.pr_sequence Pp.int -let pr_int_list_full _prc _prlc _prt l = pr_int_list l - -let pr_occurrences _prc _prlc _prt l = - match l with - | ArgArg x -> pr_int_list x - | ArgVar (loc, id) -> Nameops.pr_id id - -let occurrences_of = function - | [] -> NoOccurrences - | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) - | nl -> - if List.exists (fun n -> n < 0) nl then - Errors.error "Illegal negative occurrence number."; - OnlyOccurrences nl - -let coerce_to_int v = match Value.to_int v with - | None -> raise (CannotCoerceTo "an integer") - | Some n -> n - -let int_list_of_VList v = match Value.to_list v with -| Some l -> List.map (fun n -> coerce_to_int n) l -| _ -> raise (CannotCoerceTo "an integer") - -let interp_occs ist gl l = - match l with - | ArgArg x -> x - | ArgVar (_,id as locid) -> - (try int_list_of_VList (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) -let interp_occs ist gl l = - Tacmach.project gl , interp_occs ist gl l - -let glob_occs ist l = l - -let subst_occs evm l = l - -ARGUMENT EXTEND occurrences - PRINTED BY pr_int_list_full - - INTERPRETED BY interp_occs - GLOBALIZED BY glob_occs - SUBSTITUTED BY subst_occs - - RAW_TYPED AS occurrences_or_var - RAW_PRINTED BY pr_occurrences - - GLOB_TYPED AS occurrences_or_var - GLOB_PRINTED BY pr_occurrences - -| [ ne_integer_list(l) ] -> [ ArgArg l ] -| [ var(id) ] -> [ ArgVar id ] -END - -let pr_occurrences = pr_occurrences () () () - -let pr_gen prc _prlc _prtac c = prc c - -let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob - -let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) - -let glob_glob = Tacintern.intern_constr - -let pr_lconstr _ prc _ c = prc c - -let subst_glob = Tacsubst.subst_glob_constr_and_expr - -ARGUMENT EXTEND glob - PRINTED BY pr_globc - - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob - - RAW_TYPED AS constr_expr - RAW_PRINTED BY pr_gen - - GLOB_TYPED AS glob_constr_and_expr - GLOB_PRINTED BY pr_gen - [ constr(c) ] -> [ c ] -END - -let l_constr = Pcoq.Constr.lconstr - -ARGUMENT EXTEND lconstr - TYPED AS constr - PRINTED BY pr_lconstr - [ l_constr(c) ] -> [ c ] -END - -ARGUMENT EXTEND lglob - PRINTED BY pr_globc - - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob - - RAW_TYPED AS constr_expr - RAW_PRINTED BY pr_gen - - GLOB_TYPED AS glob_constr_and_expr - GLOB_PRINTED BY pr_gen - [ lconstr(c) ] -> [ c ] -END - -type 'id gen_place= ('id * hyp_location_flag,unit) location - -type loc_place = Id.t Loc.located gen_place -type place = Id.t gen_place - -let pr_gen_place pr_id = function - ConclLocation () -> Pp.mt () - | HypLocation (id,InHyp) -> str "in " ++ pr_id id - | HypLocation (id,InHypTypeOnly) -> - str "in (Type of " ++ pr_id id ++ str ")" - | HypLocation (id,InHypValueOnly) -> - str "in (Value of " ++ pr_id id ++ str ")" - -let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) -let pr_place _ _ _ = pr_gen_place Nameops.pr_id -let pr_hloc = pr_loc_place () () () - -let intern_place ist = function - ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) - -let interp_place ist env sigma = function - ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) - -let interp_place ist gl p = - Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p - -let subst_place subst pl = pl - -ARGUMENT EXTEND hloc - PRINTED BY pr_place - INTERPRETED BY interp_place - GLOBALIZED BY intern_place - SUBSTITUTED BY subst_place - RAW_TYPED AS loc_place - RAW_PRINTED BY pr_loc_place - GLOB_TYPED AS loc_place - GLOB_PRINTED BY pr_loc_place - [ ] -> - [ ConclLocation () ] - | [ "in" "|-" "*" ] -> - [ ConclLocation () ] -| [ "in" ident(id) ] -> - [ HypLocation ((Loc.ghost,id),InHyp) ] -| [ "in" "(" "Type" "of" ident(id) ")" ] -> - [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] -| [ "in" "(" "Value" "of" ident(id) ")" ] -> - [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] - - END - - - - - - - -(* Julien: Mise en commun des differentes version de replace with in by *) - -let pr_by_arg_tac _prc _prlc prtac opt_c = - match opt_c with - | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) - -ARGUMENT EXTEND by_arg_tac - TYPED AS tactic_opt - PRINTED BY pr_by_arg_tac -| [ "by" tactic3(c) ] -> [ Some c ] -| [ ] -> [ None ] -END - -let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c - -(* spiwack: the print functions are incomplete, but I don't know what they are - used for *) -let pr_r_nat_field natf = - str "nat " ++ - match natf with - | Retroknowledge.NatType -> str "type" - | Retroknowledge.NatPlus -> str "plus" - | Retroknowledge.NatTimes -> str "times" - -let pr_r_n_field nf = - str "binary N " ++ - match nf with - | Retroknowledge.NPositive -> str "positive" - | Retroknowledge.NType -> str "type" - | Retroknowledge.NTwice -> str "twice" - | Retroknowledge.NTwicePlusOne -> str "twice plus one" - | Retroknowledge.NPhi -> str "phi" - | Retroknowledge.NPhiInv -> str "phi inv" - | Retroknowledge.NPlus -> str "plus" - | Retroknowledge.NTimes -> str "times" - -let pr_r_int31_field i31f = - str "int31 " ++ - match i31f with - | Retroknowledge.Int31Bits -> str "bits" - | Retroknowledge.Int31Type -> str "type" - | Retroknowledge.Int31Twice -> str "twice" - | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" - | Retroknowledge.Int31Phi -> str "phi" - | Retroknowledge.Int31PhiInv -> str "phi inv" - | Retroknowledge.Int31Plus -> str "plus" - | Retroknowledge.Int31Times -> str "times" - | _ -> assert false - -let pr_retroknowledge_field f = - match f with - (* | Retroknowledge.KEq -> str "equality" - | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf - | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) - | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ - str "in " ++ str group - -VERNAC ARGUMENT EXTEND retroknowledge_nat -PRINTED BY pr_r_nat_field -| [ "nat" "type" ] -> [ Retroknowledge.NatType ] -| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] -| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] -END - - -VERNAC ARGUMENT EXTEND retroknowledge_binary_n -PRINTED BY pr_r_n_field -| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] -| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] -| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] -| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] -| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] -| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] -| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] -| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] -END - -VERNAC ARGUMENT EXTEND retroknowledge_int31 -PRINTED BY pr_r_int31_field -| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] -| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] -| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] -| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] -| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] -| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] -| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] -| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] -| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] -| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] -| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] -| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] -| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] -| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] -| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] -| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] -| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] -| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] -| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] -| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] -| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] -| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] -| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] -| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] -END - -VERNAC ARGUMENT EXTEND retroknowledge_field -PRINTED BY pr_retroknowledge_field -(*| [ "equality" ] -> [ Retroknowledge.KEq ] -| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] -| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) -| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] -END diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli deleted file mode 100644 index 14aa69875f..0000000000 --- a/tactics/extraargs.mli +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pp.std_ppcmds - -val occurrences : (int list or_var) Pcoq.Gram.entry -val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type -val pr_occurrences : int list or_var -> Pp.std_ppcmds -val occurrences_of : int list -> Locus.occurrences - -val wit_natural : int Genarg.uniform_genarg_type - -val wit_glob : - (constr_expr, - Tacexpr.glob_constr_and_expr, - Tacinterp.interp_sign * glob_constr) Genarg.genarg_type - -val wit_lglob : - (constr_expr, - Tacexpr.glob_constr_and_expr, - Tacinterp.interp_sign * glob_constr) Genarg.genarg_type - -val wit_lconstr : - (constr_expr, - Tacexpr.glob_constr_and_expr, - Constr.t) Genarg.genarg_type - -val glob : constr_expr Pcoq.Gram.entry -val lglob : constr_expr Pcoq.Gram.entry - -type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location - -type loc_place = Id.t Loc.located gen_place -type place = Id.t gen_place - -val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type -val hloc : loc_place Pcoq.Gram.entry -val pr_hloc : loc_place -> Pp.std_ppcmds - -val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry -val wit_by_arg_tac : - (raw_tactic_expr option, - glob_tactic_expr option, - Genarg.Val.t option) Genarg.genarg_type - -val pr_by_arg_tac : - (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> - raw_tactic_expr option -> Pp.std_ppcmds - -(** Spiwack: Primitive for retroknowledge registration *) - -val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry -val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 deleted file mode 100644 index 23aa8dcb47..0000000000 --- a/tactics/extratactics.ml4 +++ /dev/null @@ -1,1048 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) - -let replace_term ist dir_opt c cl = - with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) - -let clause = Pcoq.Tactic.clause_dft_concl - -TACTIC EXTEND replace - ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] -END - -TACTIC EXTEND replace_term_left - [ "replace" "->" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some true) c cl ] -END - -TACTIC EXTEND replace_term_right - [ "replace" "<-" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some false) c cl ] -END - -TACTIC EXTEND replace_term - [ "replace" uconstr(c) clause(cl) ] - -> [ replace_term ist None c cl ] -END - -let induction_arg_of_quantified_hyp = function - | AnonHyp n -> None,ElimOnAnonHyp n - | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) - -(* Versions *_main must come first!! so that "1" is interpreted as a - ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a - ElimOnIdent and not as "constr" *) - -let elimOnConstrWithHoles tac with_evars c = - Tacticals.New.tclDELAYEDWITHHOLES with_evars c - (fun c -> tac with_evars (Some (None,ElimOnConstr c))) - -TACTIC EXTEND simplify_eq_main -| [ "simplify_eq" constr_with_bindings(c) ] -> - [ elimOnConstrWithHoles dEq false c ] -END -TACTIC EXTEND simplify_eq - [ "simplify_eq" ] -> [ dEq false None ] -| [ "simplify_eq" quantified_hypothesis(h) ] -> - [ dEq false (Some (induction_arg_of_quantified_hyp h)) ] -END -TACTIC EXTEND esimplify_eq_main -| [ "esimplify_eq" constr_with_bindings(c) ] -> - [ elimOnConstrWithHoles dEq true c ] -END -TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq true None ] -| [ "esimplify_eq" quantified_hypothesis(h) ] -> - [ dEq true (Some (induction_arg_of_quantified_hyp h)) ] -END - -let discr_main c = elimOnConstrWithHoles discr_tac false c - -TACTIC EXTEND discriminate_main -| [ "discriminate" constr_with_bindings(c) ] -> - [ discr_main c ] -END -TACTIC EXTEND discriminate -| [ "discriminate" ] -> [ discr_tac false None ] -| [ "discriminate" quantified_hypothesis(h) ] -> - [ discr_tac false (Some (induction_arg_of_quantified_hyp h)) ] -END -TACTIC EXTEND ediscriminate_main -| [ "ediscriminate" constr_with_bindings(c) ] -> - [ elimOnConstrWithHoles discr_tac true c ] -END -TACTIC EXTEND ediscriminate -| [ "ediscriminate" ] -> [ discr_tac true None ] -| [ "ediscriminate" quantified_hypothesis(h) ] -> - [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ] -END - -open Proofview.Notations -let discrHyp id = - Proofview.tclEVARMAP >>= fun sigma -> - discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } - -let injection_main c = - elimOnConstrWithHoles (injClause None) false c - -TACTIC EXTEND injection_main -| [ "injection" constr_with_bindings(c) ] -> - [ injection_main c ] -END -TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None false None ] -| [ "injection" quantified_hypothesis(h) ] -> - [ injClause None false (Some (induction_arg_of_quantified_hyp h)) ] -END -TACTIC EXTEND einjection_main -| [ "einjection" constr_with_bindings(c) ] -> - [ elimOnConstrWithHoles (injClause None) true c ] -END -TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None true None ] -| [ "einjection" quantified_hypothesis(h) ] -> [ injClause None true (Some (induction_arg_of_quantified_hyp h)) ] -END -TACTIC EXTEND injection_as_main -| [ "injection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> - [ elimOnConstrWithHoles (injClause (Some ipat)) false c ] -END -TACTIC EXTEND injection_as -| [ "injection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) false None ] -| [ "injection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> - [ injClause (Some ipat) false (Some (induction_arg_of_quantified_hyp h)) ] -END -TACTIC EXTEND einjection_as_main -| [ "einjection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> - [ elimOnConstrWithHoles (injClause (Some ipat)) true c ] -END -TACTIC EXTEND einjection_as -| [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause (Some ipat) true None ] -| [ "einjection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> - [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ] -END - -let injHyp id = - Proofview.tclEVARMAP >>= fun sigma -> - injection_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } - -TACTIC EXTEND dependent_rewrite -| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] -| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] - -> [ rewriteInHyp b c id ] -END - -(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to - "replace u with t" or "enough (t=u) as <-" and - "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) - -TACTIC EXTEND cut_rewrite -| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] -| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] - -> [ cutRewriteInHyp b eqn id ] -END - -(**********************************************************************) -(* Decompose *) - -TACTIC EXTEND decompose_sum -| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] -END - -TACTIC EXTEND decompose_record -| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] -END - -(**********************************************************************) -(* Contradiction *) - -open Contradiction - -TACTIC EXTEND absurd - [ "absurd" constr(c) ] -> [ absurd c ] -END - -let onSomeWithHoles tac = function - | None -> tac None - | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) - -TACTIC EXTEND contradiction - [ "contradiction" constr_with_bindings_opt(c) ] -> - [ onSomeWithHoles contradiction c ] -END - -(**********************************************************************) -(* AutoRewrite *) - -open Autorewrite - -let pr_orient _prc _prlc _prt = function - | true -> Pp.mt () - | false -> Pp.str " <-" - -let pr_orient_string _prc _prlc _prt (orient, s) = - pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s - -ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string -| [ orient(r) preident(i) ] -> [ r, i ] -END - -TACTIC EXTEND autorewrite -| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite l ( cl) ] -| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ - auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl - ] -END - -TACTIC EXTEND autorewrite_star -| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite ~conds:AllMatches l cl ] -| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] -END - -(**********************************************************************) -(* Rewrite star *) - -let rewrite_star ist clause orient occs c (tac : Val.t option) = - let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in - with_delayed_uconstr ist c - (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) - -TACTIC EXTEND rewrite_star -| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist None o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> - [ rewrite_star ist None o Locus.AllOccurrences c tac ] - END - -(**********************************************************************) -(* Hint Rewrite *) - -let add_rewrite_hint bases ort t lcsr = - let env = Global.env() in - let sigma = Evd.from_env env in - let poly = Flags.use_polymorphic_flag () in - let f ce = - let c, ctx = Constrintern.interp_constr env sigma ce in - let ctx = - let ctx = UState.context_set ctx in - if poly then ctx - else (Global.push_context_set false ctx; Univ.ContextSet.empty) - in - Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in - let eqs = List.map f lcsr in - let add_hints base = add_rew_rules base eqs in - List.iter add_hints bases - -let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater - -VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint - [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - [ add_rewrite_hint bl o None l ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) - ":" preident_list(bl) ] -> - [ add_rewrite_hint bl o (Some t) l ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - [ add_rewrite_hint ["core"] o None l ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - [ add_rewrite_hint ["core"] o (Some t) l ] -END - -(**********************************************************************) -(* Hint Resolve *) - -open Term -open Vars -open Coqlib - -let project_hint pri l2r r = - let gr = Smartlocate.global_with_alias r in - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, c = Evd.fresh_global env sigma gr in - let t = Retyping.get_type_of env sigma c in - let t = - Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in - let sign,ccl = decompose_prod_assum t in - let (a,b) = match snd (decompose_app ccl) with - | [a;b] -> (a,b) - | _ -> assert false in - let p = - if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_vect 0 sign)) in - let c = it_mkLambda_or_LetIn - (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in - let id = - Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) - in - let ctx = Evd.universe_context_set sigma in - let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in - (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) - -let add_hints_iff l2r lc n bl = - Hints.add_hints true bl - (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) - -VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ add_hints_iff true lc n bl ] -| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> - [ add_hints_iff true lc n ["core"] ] -END -VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ add_hints_iff false lc n bl ] -| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> - [ add_hints_iff false lc n ["core"] ] -END - -(**********************************************************************) -(* Refine *) - -let refine_tac ist simple c = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let flags = Pretyping.all_no_fail_flags in - let expected_type = Pretyping.OfType concl in - let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in - let update = { run = fun sigma -> c.delayed env sigma } in - let refine = Refine.refine ~unsafe:false update in - if simple then refine - else refine <*> - Tactics.New.reduce_after_refine <*> - Proofview.shelve_unifiable - end } - -TACTIC EXTEND refine -| [ "refine" uconstr(c) ] -> [ refine_tac ist false c ] -END - -TACTIC EXTEND simple_refine -| [ "simple" "refine" uconstr(c) ] -> [ refine_tac ist true c ] -END - -(**********************************************************************) -(* Inversion lemmas (Leminv) *) - -open Inv -open Leminv - -let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater - -VERNAC COMMAND EXTEND DeriveInversionClear -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] - -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] -END - -open Term - -VERNAC COMMAND EXTEND DeriveInversion -| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s false inv_tac ] - -| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_tac ] -END - -VERNAC COMMAND EXTEND DeriveDependentInversion -| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s true dinv_tac ] -END - -VERNAC COMMAND EXTEND DeriveDependentInversionClear -| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] - => [ seff na ] - -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] -END - -(**********************************************************************) -(* Subst *) - -TACTIC EXTEND subst -| [ "subst" ne_var_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ subst_all () ] -END - -let simple_subst_tactic_flags = - { only_leibniz = true; rewrite_dependent_proof = false } - -TACTIC EXTEND simple_subst -| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] -END - -open Evar_tactics - -(**********************************************************************) -(* Evar creation *) - -(* TODO: add support for some test similar to g_constr.name_colon so that - expressions like "evar (list A)" do not raise a syntax error *) -TACTIC EXTEND evar - [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] -| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] -END - -open Tacticals - -TACTIC EXTEND instantiate - [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> - [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] -| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> - [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] -| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] -END - -(**********************************************************************) -(** Nijmegen "step" tactic for setoid rewriting *) - -open Tactics -open Glob_term -open Libobject -open Lib - -(* Registered lemmas are expected to be of the form - x R y -> y == z -> x R z (in the right table) - x R y -> x == z -> z R y (in the left table) -*) - -let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r" -let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" - -(* [step] tries to apply a rewriting lemma; then apply [tac] intended to - complete to proof of the last hypothesis (assumed to state an equality) *) - -let step left x tac = - let l = - List.map (fun lem -> - Tacticals.New.tclTHENLAST - (apply_with_bindings (lem, ImplicitBindings [x])) - tac) - !(if left then transitivity_left_table else transitivity_right_table) - in - Tacticals.New.tclFIRST l - -(* Main function to push lemmas in persistent environment *) - -let cache_transitivity_lemma (_,(left,lem)) = - if left then - transitivity_left_table := lem :: !transitivity_left_table - else - transitivity_right_table := lem :: !transitivity_right_table - -let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) - -let inTransitivity : bool * constr -> obj = - declare_object {(default_object "TRANSITIVITY-STEPS") with - cache_function = cache_transitivity_lemma; - open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); - subst_function = subst_transitivity_lemma; - classify_function = (fun o -> Substitute o) } - -(* Main entry points *) - -let add_transitivity_lemma left lem = - let env = Global.env () in - let sigma = Evd.from_env env in - let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in - add_anonymous_leaf (inTransitivity (left,lem')) - -(* Vernacular syntax *) - -TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] -| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] -END - -TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] -| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] -END - -VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF -| [ "Declare" "Left" "Step" constr(t) ] -> - [ add_transitivity_lemma true t ] -END - -VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF -| [ "Declare" "Right" "Step" constr(t) ] -> - [ add_transitivity_lemma false t ] -END - -VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> - [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ] -| [ "Clear" "Implicit" "Tactic" ] -> - [ Pfedit.clear_implicit_tactic () ] -END - - - - -(**********************************************************************) -(*spiwack : Vernac commands for retroknowledge *) - -VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF - | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in - let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in - Global.register f tc tb ] -END - - - -(**********************************************************************) -(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as - defined by Conor McBride *) -TACTIC EXTEND generalize_eqs -| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] -END -TACTIC EXTEND dep_generalize_eqs -| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] -END -TACTIC EXTEND generalize_eqs_vars -| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] -END -TACTIC EXTEND dep_generalize_eqs_vars -| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] -END - -(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] - where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated - during dependent induction. For internal use. *) - -TACTIC EXTEND specialize_eqs -[ "specialize_eqs" hyp(id) ] -> [ Proofview.V82.tactic (specialize_eqs id) ] -END - -(**********************************************************************) -(* A tactic that considers a given occurrence of [c] in [t] and *) -(* abstract the minimal set of all the occurrences of [c] so that the *) -(* abstraction [fun x -> t[x/c]] is well-typed *) -(* *) -(* Contributed by Chung-Kil Hur (Winter 2009) *) -(**********************************************************************) - -let subst_var_with_hole occ tid t = - let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in - let locref = ref 0 in - let rec substrec = function - | GVar (_,id) as x -> - if Id.equal id tid - then - (decr occref; - if Int.equal !occref 0 then x - else - (incr locref; - GHole (Loc.make_loc (!locref,0), - Evar_kinds.QuestionMark(Evar_kinds.Define true), - Misctypes.IntroAnonymous, None))) - else x - | c -> map_glob_constr_left_to_right substrec c in - let t' = substrec t - in - if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' - -let subst_hole_with_term occ tc t = - let locref = ref 0 in - let occref = ref occ in - let rec substrec = function - | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> - decr occref; - if Int.equal !occref 0 then tc - else - (incr locref; - GHole (Loc.make_loc (!locref,0), - Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) - | c -> map_glob_constr_left_to_right substrec c - in - substrec t - -open Tacmach - -let hResolve id c occ t = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in - let env = Termops.clear_named_body id (Proofview.Goal.env gl) in - let concl = Proofview.Goal.concl gl in - let env_ids = Termops.ids_of_context env in - let c_raw = Detyping.detype true env_ids env sigma c in - let t_raw = Detyping.detype true env_ids env sigma t in - let rec resolve_hole t_hole = - try - Pretyping.understand env sigma t_hole - with - | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> - let (e, info) = Errors.push e in - let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in - resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) - in - let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in - let sigma = Evd.merge_universe_context sigma ctx in - let t_constr_type = Retyping.get_type_of env sigma t_constr in - let tac = - (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } - -let hResolve_auto id c t = - let rec resolve_auto n = - try - hResolve id c n t - with - | UserError _ as e -> raise e - | e when Errors.noncritical e -> resolve_auto (n+1) - in - resolve_auto 1 - -TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] -END - -(** - hget_evar -*) - -let hget_evar n = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl gl in - let evl = evar_list concl in - if List.length evl < n then - error "Not enough uninstantiated existential variables."; - if n <= 0 then error "Incorrect existential variable index."; - let ev = List.nth evl (n-1) in - let ev_type = existential_type sigma ev in - change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) - end } - -TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] -END - -(**********************************************************************) - -(**********************************************************************) -(* A tactic that reduces one match t with ... by doing destruct t. *) -(* if t is not a variable, the tactic does *) -(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) -(* preserved). *) -(* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) -(**********************************************************************) - -exception Found of unit Proofview.tactic - -let rewrite_except h = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let hyps = Tacmach.New.pf_ids_of_hyps gl in - Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else - Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) - hyps - end } - - -let refl_equal = - let coq_base_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in - function () -> (coq_base_constant "eq_refl") - - -(* This is simply an implementation of the case_eq tactic. this code - should be replaced by a call to the tactic but I don't know how to - call it before it is defined. *) -let mkCaseEq a : unit Proofview.tactic = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in - Tacticals.New.tclTHENLIST - [Proofview.V82.tactic (Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - (** FIXME: this looks really wrong. Does anybody really use this tactic? *) - let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in - change_concl c - end }; - simplest_case a] - end } - - -let case_eq_intros_rewrite x = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let n = nb_prod (Proofview.Goal.concl gl) in - (* Pp.msgnl (Printer.pr_lconstr x); *) - Tacticals.New.tclTHENLIST [ - mkCaseEq x; - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let hyps = Tacmach.New.pf_ids_of_hyps gl in - let n' = nb_prod concl in - let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in - Tacticals.New.tclTHENLIST [ - Tacticals.New.tclDO (n'-n-1) intro; - introduction h; - rewrite_except h] - end } - ] - end } - -let rec find_a_destructable_match t = - let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in - let cl = [cl, (None, None), None], None in - let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in - match kind_of_term t with - | Case (_,_,x,_) when closed0 x -> - if isVar x then - (* TODO check there is no rel n. *) - raise (Found (Tacinterp.eval_tactic dest)) - else - (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) - raise (Found (case_eq_intros_rewrite x)) - | _ -> iter_constr find_a_destructable_match t - - -let destauto t = - try find_a_destructable_match t; - Tacticals.New.tclZEROMSG (str "No destructable match found") - with Found tac -> tac - -let destauto_in id = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in -(* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) -(* Pp.msgnl (Printer.pr_lconstr (ctype)); *) - destauto ctype - end } - -TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.nf_enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] -| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] -END - - -(* ********************************************************************* *) - -let eq_constr x y = - Proofview.Goal.enter { enter = begin fun gl -> - let evd = Tacmach.New.project gl in - if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () - else Tacticals.New.tclFAIL 0 (str "Not equal") - end } - -TACTIC EXTEND constr_eq -| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] -END - -TACTIC EXTEND constr_eq_nounivs -| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ - if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] -END - -TACTIC EXTEND is_evar -| [ "is_evar" constr(x) ] -> - [ match kind_of_term x with - | Evar _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") - ] -END - -let rec has_evar x = - match kind_of_term x with - | Evar _ -> true - | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> - false - | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> - has_evar t1 || has_evar t2 - | LetIn (_, t1, t2, t3) -> - has_evar t1 || has_evar t2 || has_evar t3 - | App (t1, ts) -> - has_evar t1 || has_evar_array ts - | Case (_, t1, t2, ts) -> - has_evar t1 || has_evar t2 || has_evar_array ts - | Fix ((_, tr)) | CoFix ((_, tr)) -> - has_evar_prec tr - | Proj (p, c) -> has_evar c -and has_evar_array x = - Array.exists has_evar x -and has_evar_prec (_, ts1, ts2) = - Array.exists has_evar ts1 || Array.exists has_evar ts2 - -TACTIC EXTEND has_evar -| [ "has_evar" constr(x) ] -> - [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ] -END - -TACTIC EXTEND is_hyp -| [ "is_var" constr(x) ] -> - [ match kind_of_term x with - | Var _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] -END - -TACTIC EXTEND is_fix -| [ "is_fix" constr(x) ] -> - [ match kind_of_term x with - | Fix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] -END;; - -TACTIC EXTEND is_cofix -| [ "is_cofix" constr(x) ] -> - [ match kind_of_term x with - | CoFix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] -END;; - -(* Command to grab the evars left unresolved at the end of a proof. *) -(* spiwack: I put it in extratactics because it is somewhat tied with - the semantics of the LCF-style tactics, hence with the classic tactic - mode. *) -VERNAC COMMAND EXTEND GrabEvars -[ "Grab" "Existential" "Variables" ] - => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] -END - -(* Shelves all the goals under focus. *) -TACTIC EXTEND shelve -| [ "shelve" ] -> - [ Proofview.shelve ] -END - -(* Shelves the unifiable goals under focus, i.e. the goals which - appear in other goals under focus (the unfocused goals are not - considered). *) -TACTIC EXTEND shelve_unifiable -| [ "shelve_unifiable" ] -> - [ Proofview.shelve_unifiable ] -END - -(* Unshelves the goal shelved by the tactic. *) -TACTIC EXTEND unshelve -| [ "unshelve" tactic1(t) ] -> - [ - Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> - Proofview.Unsafe.tclGETGOALS >>= fun ogls -> - Proofview.Unsafe.tclSETGOALS (gls @ ogls) - ] -END - -(* Command to add every unshelved variables to the focus *) -VERNAC COMMAND EXTEND Unshelve -[ "Unshelve" ] - => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] -END - -(* Gives up on the goals under focus: the goals are considered solved, - but the proof cannot be closed until the user goes back and solve - these goals. *) -TACTIC EXTEND give_up -| [ "give_up" ] -> - [ Proofview.give_up ] -END - -(* cycles [n] goals *) -TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] -END - -(* swaps goals number [i] and [j] *) -TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] -END - -(* reverses the list of focused goals *) -TACTIC EXTEND revgoals -| [ "revgoals" ] -> [ Proofview.revgoals ] -END - - -type cmp = - | Eq - | Lt | Le - | Gt | Ge - -type 'i test = - | Test of cmp * 'i * 'i - -let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 "cmp" -let wit_test : (int or_var test,int or_var test,int test) Genarg.genarg_type = - Genarg.make0 "tactest" - -let pr_cmp = function - | Eq -> Pp.str"=" - | Lt -> Pp.str"<" - | Le -> Pp.str"<=" - | Gt -> Pp.str">" - | Ge -> Pp.str">=" - -let pr_cmp' _prc _prlc _prt = pr_cmp - -let pr_test_gen f (Test(c,x,y)) = - Pp.(f x ++ pr_cmp c ++ f y) - -let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int) - -let pr_test' _prc _prlc _prt = pr_test - -let pr_itest = pr_test_gen Pp.int - -let pr_itest' _prc _prlc _prt = pr_itest - - - -ARGUMENT EXTEND comparison TYPED AS cmp PRINTED BY pr_cmp' -| [ "=" ] -> [ Eq ] -| [ "<" ] -> [ Lt ] -| [ "<=" ] -> [ Le ] -| [ ">" ] -> [ Gt ] -| [ ">=" ] -> [ Ge ] - END - -let interp_test ist gls = function - | Test (c,x,y) -> - project gls , - Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) - -ARGUMENT EXTEND test - PRINTED BY pr_itest' - INTERPRETED BY interp_test - RAW_TYPED AS test - RAW_PRINTED BY pr_test' - GLOB_TYPED AS test - GLOB_PRINTED BY pr_test' -| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] -END - -let interp_cmp = function - | Eq -> Int.equal - | Lt -> ((<):int->int->bool) - | Le -> ((<=):int->int->bool) - | Gt -> ((>):int->int->bool) - | Ge -> ((>=):int->int->bool) - -let run_test = function - | Test(c,x,y) -> interp_cmp c x y - -let guard tst = - if run_test tst then - Proofview.tclUNIT () - else - let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in - Tacticals.New.tclZEROMSG msg - - -TACTIC EXTEND guard -| [ "guard" test(tst) ] -> [ guard tst ] -END - -let decompose l c = - Proofview.Goal.enter { enter = begin fun gl -> - let to_ind c = - if isInd c then Univ.out_punivs (destInd c) - else error "not an inductive type" - in - let l = List.map to_ind l in - Elim.h_decompose l c - end } - -TACTIC EXTEND decompose -| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] -END - -(** library/keys *) - -VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF -| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ - let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in - let k1 = Keys.constr_key (it c) in - let k2 = Keys.constr_key (it c') in - match k1, k2 with - | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 - | _ -> () ] -END - -VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> [ msg_info (Keys.pr_keys Printer.pr_global) ] -END - - -VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Proof_global.compact_the_proof () ] -| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Gc.compact () ] -END diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli deleted file mode 100644 index 18334dafe7..0000000000 --- a/tactics/extratactics.mli +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit Proofview.tactic -val injHyp : Names.Id.t -> unit Proofview.tactic - -(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) - -val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/tactics/g_auto.ml4 b/tactics/g_auto.ml4 deleted file mode 100644 index 788443944f..0000000000 --- a/tactics/g_auto.ml4 +++ /dev/null @@ -1,211 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ Eauto.e_assumption ] -END - -TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] -END - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] -END - -let eval_uconstrs ist cs = - let flags = { - Pretyping.use_typeclasses = false; - use_unif_heuristics = true; - use_hook = Some Pfedit.solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true - } in - List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs - -let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) - -ARGUMENT EXTEND auto_using - TYPED AS uconstr_list - PRINTED BY pr_auto_using -| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] -| [ ] -> [ [] ] -END - -(** Auto *) - -TACTIC EXTEND trivial -| [ "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND info_trivial -| [ "info_trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND debug_trivial -| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND auto -| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto n (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND info_auto -| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND debug_auto -| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] -END - -(** Eauto *) - -TACTIC EXTEND prolog -| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> - [ Eauto.prolog_tac (eval_uconstrs ist l) n ] -END - -let make_depth n = snd (Eauto.make_dimension n None) - -TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) - hintbases(db) ] -> - [ match db with - | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) - | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] -END - -TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND info_eauto -| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] -END - -TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] -END - -TACTIC EXTEND autounfold_one -| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] -| [ "autounfold_one" hintbases(db) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] - END - -TACTIC EXTEND autounfoldify -| [ "autounfoldify" constr(x) ] -> [ - let db = match Term.kind_of_term x with - | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) - | _ -> assert false - in Eauto.autounfold ["core";db] Locusops.onConcl - ] -END - -TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ - let table = try Some (Hints.searchtable_map base) with Not_found -> None in - match table with - | None -> - let msg = str "Hint table " ++ str base ++ str " not found" in - Tacticals.New.tclZEROMSG msg - | Some t -> - let state = Hints.Hint_db.transparent_state t in - Tactics.unify ~state x y - ] -END - - -TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] -END - -let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom - -ARGUMENT EXTEND hints_path_atom - TYPED AS hints_path_atom - PRINTED BY pr_hints_path_atom -| [ global_list(g) ] -> [ Hints.PathHints (List.map Nametab.global g) ] -| [ "*" ] -> [ Hints.PathAny ] -END - -let pr_hints_path prc prx pry c = Hints.pp_hints_path c - -ARGUMENT EXTEND hints_path - TYPED AS hints_path - PRINTED BY pr_hints_path -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ "!" hints_path(p) ] -> [ Hints.PathStar p ] -| [ "emp" ] -> [ Hints.PathEmpty ] -| [ "eps" ] -> [ Hints.PathEpsilon ] -| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] -| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] -| [ hints_path(p) ";" hints_path(q) ] -> [ Hints.PathSeq (p, q) ] -END - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND opthints - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ ":" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ None ] -END - -VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - let entry = Hints.HintsCutEntry p in - Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (match dbnames with None -> ["core"] | Some l -> l) entry ] -END diff --git a/tactics/g_class.ml4 b/tactics/g_class.ml4 deleted file mode 100644 index 9ef1545416..0000000000 --- a/tactics/g_class.ml4 +++ /dev/null @@ -1,89 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ progress_evars (Tacinterp.tactic_of_value ist t) ] -END - -(** Options: depth, debug and transparency settings. *) - -let set_transparency cl b = - List.iter (fun r -> - let gr = Smartlocate.global_with_alias r in - let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in - Classes.set_typeclass_transparency ev false b) cl - -VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ - set_transparency cl true ] -END - -VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ - set_transparency cl false ] -END - -open Genarg - -let pr_debug _prc _prlc _prt b = - if b then Pp.str "debug" else Pp.mt() - -ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug -| [ "debug" ] -> [ true ] -| [ ] -> [ false ] -END - -let pr_depth _prc _prlc _prt = function - Some i -> Pp.int i - | None -> Pp.mt() - -ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth -| [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ] -END - -(* true = All transparent, false = Opaque if possible *) - -VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [ - set_typeclasses_debug d; - set_typeclasses_depth depth - ] -END - -TACTIC EXTEND typeclasses_eauto -| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ Proofview.V82.tactic (typeclasses_eauto l) ] -| [ "typeclasses" "eauto" ] -> [ Proofview.V82.tactic (typeclasses_eauto ~only_classes:true [Hints.typeclasses_db]) ] -END - -TACTIC EXTEND head_of_constr - [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] -END - -TACTIC EXTEND not_evar - [ "not_evar" constr(ty) ] -> [ not_evar ty ] -END - -TACTIC EXTEND is_ground - [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ] -END - -TACTIC EXTEND autoapply - [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ] -END diff --git a/tactics/g_eqdecide.ml4 b/tactics/g_eqdecide.ml4 deleted file mode 100644 index 905653281c..0000000000 --- a/tactics/g_eqdecide.ml4 +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ decideEqualityGoal ] -END - -TACTIC EXTEND compare -| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] -END diff --git a/tactics/g_ltac.ml4 b/tactics/g_ltac.ml4 deleted file mode 100644 index b55ac9ad06..0000000000 --- a/tactics/g_ltac.ml4 +++ /dev/null @@ -1,430 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a - | e -> Tacexp (e:raw_tactic_expr) - -let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () -let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c - -let reference_to_id = function - | Libnames.Ident (loc, id) -> (loc, id) - | Libnames.Qualid (loc,_) -> - Errors.user_err_loc (loc, "", - str "This expression should be a simple identifier.") - -let tactic_mode = Gram.entry_create "vernac:tactic_command" - -let new_entry name = - let e = Gram.entry_create name in - let entry = Entry.create name in - let () = Pcoq.set_grammar entry e in - e - -let selector = new_entry "vernac:selector" -let tacdef_body = new_entry "tactic:tacdef_body" - -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> set_command_entry tactic_mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); - } in - Proof_global.register_proof_mode mode - -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match get_tok (stream_nth 0 strm) with - | KEYWORD "[" -> - (match get_tok (stream_nth 1 strm) with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* Tactics grammar rules *) - -GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - tactic_mode constr_may_eval constr_eval selector; - - tactic_then_last: - [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> - Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] - ] ] - ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) - | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) - | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) - | ta = tactic_expr -> ([ta], None) - | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) - | -> ([TacId []], None) - ] ] - ; - tactic_then_locality: (* [true] for the local variant [TacThens] and [false] - for [TacExtend] *) - [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] - ; - tactic_expr: - [ "5" RIGHTA - [ te = binder_tactic -> te ] - | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) - | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> - match l , tail with - | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) - | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) - | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) ] - | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) - | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "once"; ta = tactic_expr -> TacOnce ta - | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta - | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta -(*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = ident -> - TacAbstract (tc,Some s) ] -(*End of To do*) - | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] - | "1" RIGHTA - [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,false,mrl) - | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; - mrl = match_context_list; "end" -> - TacMatchGoal (b,true,mrl) - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (b,c,mrl) - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; l = LIST0 message_token -> TacId l - | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (g,n,l) - | st = simple_tactic -> st - | a = tactic_arg -> TacArg(!@loc,a) - | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(!@loc,TacCall (!@loc,r,la)) ] - | "0" - [ "("; a = tactic_expr; ")" -> a - | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> - begin match tail with - | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) - | None -> TacDispatch tf - end - | a = tactic_atom -> TacArg (!@loc,a) ] ] - ; - failkw: - [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] - ; - (* binder_tactic: level 5 of tactic_expr *) - binder_tactic: - [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> - TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; - llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) - | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] - ; - (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> a - | r = reference -> Reference r - | c = Constr.constr -> ConstrMayEval (ConstrTerm c) - (* Unambigous entries: tolerated w/o "ltac:" modifier *) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l - | IDENT "type_term"; c=uconstr -> TacPretype c - | IDENT "numgoals" -> TacNumgoals ] ] - ; - (* If a qualid is given, use its short name. TODO: have the shortest - non ambiguous name where dots are replaced by "_"? Probably too - verbose most of the time. *) - fresh_id: - [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) - | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] - ; - constr_eval: - [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) - | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) - | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] - ; - constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] - ; - tactic_atom: - [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (!@loc,r,[]) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - match_key: - [ [ "match" -> Once - | "lazymatch" -> Select - | "multimatch" -> General ] ] - ; - input_fun: - [ [ "_" -> None - | l = ident -> Some l ] ] - ; - let_clause: - [ [ id = identref; ":="; te = tactic_expr -> - (id, arg_of_expr te) - | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - (id, arg_of_expr (TacFun(args,te))) ] ] - ; - match_pattern: - [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - let mode = not (!Flags.tactic_context_compat) in - Subterm (mode, oid, pc) - | IDENT "appcontext"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - msg_warning (strbrk "appcontext is deprecated"); - Subterm (true,oid, pc) - | pc = Constr.lconstr_pattern -> Term pc ] ] - ; - match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) - | na = name; ":="; mpv = match_pattern -> - let t, ty = - match mpv with - | Term t -> (match t with - | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) - | _ -> mpv, None) - | _ -> mpv, None - in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) - ] ] - ; - match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_context_list: - [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] - ; - message_token: - [ [ id = identref -> MsgIdent id - | s = STRING -> MsgString s - | n = integer -> MsgInt n ] ] - ; - - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) - else - let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Vernacexpr.TacticRedefinition (name, body) - else - let id = reference_to_id name in - Vernacexpr.TacticDefinition (id, body) - ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - selector: - [ [ n=natural; ":" -> Vernacexpr.SelectNth n - | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id - | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] - ; - tactic_mode: - [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] - ; - END - -open Stdarg -open Constrarg -open Vernacexpr -open Vernac_classifier -open Goptions -open Libnames - -let print_info_trace = ref None - -let _ = declare_int_option { - optsync = true; - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Pp.feedback Feedback.AddedAxiom - -let pr_ltac_selector = function -| SelectNth i -> int i ++ str ":" -| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" -| SelectAll -> str "all" ++ str ":" - -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ selector(s) ] -> [ s ] -END - -let pr_ltac_info n = str "Info" ++ spc () ++ int n - -VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info -| [ "Info" natural(n) ] -> [ n ] -END - -let pr_ltac_use_default b = if b then str ".." else mt () - -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] -END - -VERNAC tactic_mode EXTEND VernacSolve -| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ classify_as_proofstep ] -> [ - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - vernac_solve g n t def - ] -| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ VtProofStep true, VtLater ] -> [ - vernac_solve SelectAll n t def - ] -END - -let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level -| [ "(" "at" "level" natural(n) ")" ] -> [ n ] -END - -VERNAC ARGUMENT EXTEND ltac_production_sep -| [ "," string(sep) ] -> [ sep ] -END - -let pr_ltac_production_item = function -| TacTerm s -> quote (str s) -| TacNonTerm (_, arg, (id, sep)) -> - let sep = match sep with - | "" -> mt () - | sep -> str "," ++ spc () ++ quote (str sep) - in - str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item -| [ string(s) ] -> [ TacTerm s ] -| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ TacNonTerm (loc, Names.Id.to_string nt, (p, Option.default "" sep)) ] -END - -VERNAC COMMAND EXTEND VernacTacticNotation -| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - [ VtUnknown, VtNow ] -> - [ - let l = Locality.LocalityFixme.consume () in - let n = Option.default 0 n in - Tacentries.add_tactic_notation (Locality.make_module_locality l, n, r, e) - ] -END - -VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY -| [ "Print" "Ltac" reference(r) ] -> - [ msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] -END - -VERNAC ARGUMENT EXTEND ltac_tacdef_body -| [ tacdef_body(t) ] -> [ t ] -END - -VERNAC COMMAND EXTEND VernacDeclareTacticDefinition -| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ - VtSideff (List.map (function - | TacticDefinition ((_,r),_) -> r - | TacticRedefinition (Ident (_,r),_) -> r - | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater - ] -> [ - let lc = Locality.LocalityFixme.consume () in - Tacentries.register_ltac (Locality.make_module_locality lc) l - ] -END diff --git a/tactics/g_obligations.ml4 b/tactics/g_obligations.ml4 deleted file mode 100644 index 4cd8bf1feb..0000000000 --- a/tactics/g_obligations.ml4 +++ /dev/null @@ -1,147 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - snd (get_default_tactic ()) - end in - Obligations.default_tactic := tac - -(* We define new entries for programs, with the use of this module - * Subtac. These entries are named Subtac. - *) - -module Gram = Pcoq.Gram -module Tactic = Pcoq.Tactic - -open Pcoq - -let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) - -type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type - -let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = - Genarg.create_arg "withtac" - -let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) - -GEXTEND Gram - GLOBAL: withtac; - - withtac: - [ [ "with"; t = Tactic.tactic -> Some t - | -> None ] ] - ; - - Constr.closed_binder: - [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in - [LocalRawAssum ([id], default_binder_kind, typ)] - ] ]; - - END - -open Obligations - -let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) - -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl -| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, Some name, Some t) tac ] -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> - [ obligation (num, Some name, None) tac ] -| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, None, Some t) tac ] -| [ "Obligation" integer(num) withtac(tac) ] -> - [ obligation (num, None, None) tac ] -| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> - [ next_obligation (Some name) tac ] -| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] -END - -VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF -| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> - [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] -END - -VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF -| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" "with" tactic(t) ] -> - [ try_solve_obligations None (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" ] -> - [ try_solve_obligations None None ] -END - -VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF -| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> - [ solve_all_obligations (Some (Tacinterp.interp t)) ] -| [ "Solve" "All" "Obligations" ] -> - [ solve_all_obligations None ] -END - -VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] -END - -VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - set_default_tactic - (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (Tacintern.glob_tactic t) ] -END - -open Pp - -VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY -| [ "Show" "Obligation" "Tactic" ] -> [ - msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] -END - -VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY -| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] -| [ "Obligations" ] -> [ show_obligations None ] -END - -VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ msg_info (show_term None) ] -END - -open Pp - -(* Declare a printer for the content of Program tactics *) -let () = - let printer _ _ _ = function - | None -> mt () - | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac - in - (* should not happen *) - let dummy _ _ _ expr = assert false in - Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4 deleted file mode 100644 index c4ef1f297e..0000000000 --- a/tactics/g_rewrite.ml4 +++ /dev/null @@ -1,272 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ bl ] -END - -type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast -type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast - -let interp_strategy ist gl s = - let sigma = project gl in - sigma, strategy_of_ast s -let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s -let subst_strategy s str = str - -let pr_strategy _ _ _ (s : strategy) = Pp.str "" -let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "" -let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "" - -ARGUMENT EXTEND rewstrategy - PRINTED BY pr_strategy - - INTERPRETED BY interp_strategy - GLOBALIZED BY glob_strategy - SUBSTITUTED BY subst_strategy - - RAW_TYPED AS raw_strategy - RAW_PRINTED BY pr_raw_strategy - - GLOB_TYPED AS glob_strategy - GLOB_PRINTED BY pr_glob_strategy - - [ glob(c) ] -> [ StratConstr (c, true) ] - | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] - | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] - | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] - | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] - | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] - | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] - | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] - | [ "id" ] -> [ StratId ] - | [ "fail" ] -> [ StratFail ] - | [ "refl" ] -> [ StratRefl ] - | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] - | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] - | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] - | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] - | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] - | [ "(" rewstrategy(h) ")" ] -> [ h ] - | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] - | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] - | [ "hints" preident(h) ] -> [ StratHints (false, h) ] - | [ "terms" constr_list(h) ] -> [ StratTerms h ] - | [ "eval" red_expr(r) ] -> [ StratEval r ] - | [ "fold" constr(c) ] -> [ StratFold c ] -END - -(* By default the strategy for "rewrite_db" is top-down *) - -let db_strat db = StratUnary (Topdown, StratHints (false, db)) -let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) - -let cl_rewrite_clause_db = - if Flags.profile then - let key = Profile.declare_profile "cl_rewrite_clause_db" in - Profile.profile3 key cl_rewrite_clause_db - else cl_rewrite_clause_db - -TACTIC EXTEND rewrite_strat -| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ] -| [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ] -| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db (Some id)) ] -| [ "rewrite_db" preident(db) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db None) ] -END - -let clsubstitute o c = - let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in - Tacticals.onAllHypsAndConcl - (fun cl -> - match cl with - | Some id when is_tac id -> tclIDTAC - | _ -> cl_rewrite_clause c o AllOccurrences cl) - -TACTIC EXTEND substitute -| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ] -END - - -(* Compatibility with old Setoids *) - -TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] - -> [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences None) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences (Some id))] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) None)] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> - [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> - [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))] -END - -VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] - - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None None ] - | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) None ] - | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n None None (Some lemma3) ] -END - -type binders_argtype = local_binder list - -let wit_binders = - (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) - -let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) - -open Pcoq - -GEXTEND Gram - GLOBAL: binders; - binders: - [ [ b = Pcoq.Constr.binders -> b ] ]; -END - -VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] - | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] - | [ "Add" "Morphism" constr(m) ":" ident(n) ] - (* This command may or may not open a goal *) - => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] - -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] - | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] - | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) - "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] -END - -TACTIC EXTEND setoid_symmetry - [ "setoid_symmetry" ] -> [ setoid_symmetry ] - | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] -END - -TACTIC EXTEND setoid_reflexivity -[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] -END - -TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] -| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] -END - -VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY - [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Pp.msg_notice (Autorewrite.print_rewrite_hintdb s) ] -END diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib deleted file mode 100644 index 7987d774d1..0000000000 --- a/tactics/hightactics.mllib +++ /dev/null @@ -1,23 +0,0 @@ -Tacsubst -Tacenv -Tactic_debug -Tacintern -Tacentries -Tacinterp -Evar_tactics -Tactic_option -Extraargs -G_obligations -Coretactics -Autorewrite -Extratactics -Eauto -G_auto -Class_tactics -G_class -Rewrite -G_rewrite -Tauto -Eqdecide -G_eqdecide -G_ltac diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml deleted file mode 100644 index fb04bee070..0000000000 --- a/tactics/rewrite.ml +++ /dev/null @@ -1,2184 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") - -let find_reference dir s = - let gr = lazy (try_find_global_reference dir s) in - fun () -> Lazy.force gr - -type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) - -let find_global dir s = - let gr = lazy (try_find_global_reference dir s) in - fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in - let evd = Sigma.to_evar_map sigma in - (evd, cstrs), c - -(** Utility for dealing with polymorphic applications *) - -(** Global constants. *) - -let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" -let coq_eq = find_global ["Init"; "Logic"] "eq" -let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" -let coq_all = find_global ["Init"; "Logic"] "all" -let impl = find_global ["Program"; "Basics"] "impl" - -(** Bookkeeping which evars are constraints so that we can - remove them at the end of the tactic. *) - -let goalevars evars = fst evars -let cstrevars evars = snd evars - -let new_cstr_evar (evd,cstrs) env t = - let s = Typeclasses.set_resolvable Evd.Store.empty false in - let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in - let evd' = Sigma.to_evar_map evd' in - let ev, _ = destEvar t in - (evd', Evar.Set.add ev cstrs), t - -(** Building or looking up instances. *) -let e_new_cstr_evar env evars t = - let evd', t = new_cstr_evar !evars env t in evars := evd'; t - -(** Building or looking up instances. *) - -let extends_undefined evars evars' = - let f ev evi found = found || not (Evd.mem evars ev) - in fold_undefined f evars' false - -let app_poly_check env evars f args = - let (evars, cstrs), fc = f evars in - let evdref = ref evars in - let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in - (!evdref, cstrs), t - -let app_poly_nocheck env evars f args = - let evars, fc = f evars in - evars, mkApp (fc, args) - -let app_poly_sort b = - if b then app_poly_nocheck - else app_poly_check - -let find_class_proof proof_type proof_method env evars carrier relation = - try - let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in - let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in - if extends_undefined (goalevars evars) evars' then raise Not_found - else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |] - with e when Logic.catchable_exception e -> raise Not_found - -(** Utility functions *) - -module GlobalBindings (M : sig - val relation_classes : string list - val morphisms : string list - val relation : string list * string - val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr - val arrow : evars -> evars * constr -end) = struct - open M - open Context.Rel.Declaration - let relation : evars -> evars * constr = find_global (fst relation) (snd relation) - - let reflexive_type = find_global relation_classes "Reflexive" - let reflexive_proof = find_global relation_classes "reflexivity" - - let symmetric_type = find_global relation_classes "Symmetric" - let symmetric_proof = find_global relation_classes "symmetry" - - let transitive_type = find_global relation_classes "Transitive" - let transitive_proof = find_global relation_classes "transitivity" - - let forall_relation = find_global morphisms "forall_relation" - let pointwise_relation = find_global morphisms "pointwise_relation" - - let forall_relation_ref = find_reference morphisms "forall_relation" - let pointwise_relation_ref = find_reference morphisms "pointwise_relation" - - let respectful = find_global morphisms "respectful" - let respectful_ref = find_reference morphisms "respectful" - - let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" - - let coq_forall = find_global morphisms "forall_def" - - let subrelation = find_global relation_classes "subrelation" - let do_subrelation = find_global morphisms "do_subrelation" - let apply_subrelation = find_global morphisms "apply_subrelation" - - let rewrite_relation_class = find_global relation_classes "RewriteRelation" - - let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) - let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) - - let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) - - let proper_type = - let l = lazy (Lazy.force proper_class).cl_impl in - fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in - (evd, cstrs), c - - let proper_proxy_type = - let l = lazy (Lazy.force proper_proxy_class).cl_impl in - fun (evd,cstrs) -> - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in - let evd = Sigma.to_evar_map sigma in - (evd, cstrs), c - - let proper_proof env evars carrier relation x = - let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in - new_cstr_evar evars env goal - - let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env - let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env - let get_transitive_proof env = find_class_proof transitive_type transitive_proof env - - let mk_relation env evd a = - app_poly env evd relation [| a |] - - (** Build an infered signature from constraints on the arguments and expected output - relation *) - - let build_signature evars env m (cstrs : (types * types option) option list) - (finalcstr : (types * types option) option) = - let mk_relty evars newenv ty obj = - match obj with - | None | Some (_, None) -> - let evars, relty = mk_relation env evars ty in - if closed0 ty then - let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in - new_cstr_evar evars env' relty - else new_cstr_evar evars newenv relty - | Some (x, Some rel) -> evars, rel - in - let rec aux env evars ty l = - let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in - match kind_of_term t, l with - | Prod (na, ty, b), obj :: cstrs -> - let b = Reductionops.nf_betaiota (goalevars evars) b in - if noccurn 1 b (* non-dependent product *) then - let ty = Reductionops.nf_betaiota (goalevars evars) ty in - let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in - let evars, relty = mk_relty evars env ty obj in - let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in - evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs - else - let (evars, b, arg, cstrs) = - aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs - in - let ty = Reductionops.nf_betaiota (goalevars evars) ty in - let pred = mkLambda (na, ty, b) in - let liftarg = mkLambda (na, ty, arg) in - let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in - if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs - else error "build_signature: no constraint can apply on a dependent argument" - | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") - | _, [] -> - (match finalcstr with - | None | Some (_, None) -> - let t = Reductionops.nf_betaiota (fst evars) ty in - let evars, rel = mk_relty evars env t None in - evars, t, rel, [t, Some rel] - | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) - in aux env evars m cstrs - - (** Folding/unfolding of the tactic constants. *) - - let unfold_impl t = - match kind_of_term t with - | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) - | _ -> assert false - - let unfold_all t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - - let unfold_forall t = - match kind_of_term t with - | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> - (match kind_of_term b with - | Lambda (n, ty, b) -> mkProd (n, ty, b) - | _ -> assert false) - | _ -> assert false - - let arrow_morphism env evd ta tb a b = - let ap = is_Prop ta and bp = is_Prop tb in - if ap && bp then app_poly env evd impl [| a; b |], unfold_impl - else if ap then (* Domain in Prop, CoDomain in Type *) - (app_poly env evd arrow [| a; b |]), unfold_impl - (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) - else if bp then (* Dummy forall *) - (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall - else (* None in Prop, use arrow *) - (app_poly env evd arrow [| a; b |]), unfold_impl - - let rec decomp_pointwise n c = - if Int.equal n 0 then c - else - match kind_of_term c with - | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> - decomp_pointwise (pred n) relb - | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> - decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1])) - | _ -> invalid_arg "decomp_pointwise" - - let rec apply_pointwise rel = function - | arg :: args -> - (match kind_of_term rel with - | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f -> - apply_pointwise relb args - | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f -> - apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args - | _ -> invalid_arg "apply_pointwise") - | [] -> rel - - let pointwise_or_dep_relation env evd n t car rel = - if noccurn 1 car && noccurn 1 rel then - app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] - else - app_poly env evd forall_relation - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] - - let lift_cstr env evars (args : constr list) c ty cstr = - let start evars env car = - match cstr with - | None | Some (_, None) -> - let evars, rel = mk_relation env evars car in - new_cstr_evar evars env rel - | Some (ty, Some rel) -> evars, rel - in - let rec aux evars env prod n = - if Int.equal n 0 then start evars env prod - else - match kind_of_term (Reduction.whd_betadeltaiota env prod) with - | Prod (na, ty, b) -> - if noccurn 1 b then - let b' = lift (-1) b in - let evars, rb = aux evars env b' (pred n) in - app_poly env evars pointwise_relation [| ty; b'; rb |] - else - let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in - app_poly env evars forall_relation - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] - | _ -> raise Not_found - in - let rec find env c ty = function - | [] -> None - | arg :: args -> - try let evars, found = aux evars env ty (succ (List.length args)) in - Some (evars, found, c, ty, arg :: args) - with Not_found -> - let ty = whd_betadeltaiota env ty in - find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args - in find env c ty args - - let unlift_cstr env sigma = function - | None -> None - | Some codom -> Some (decomp_pointwise 1 codom) - - (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) - let is_applied_rewrite_relation env sigma rels t = - match kind_of_term t with - | App (c, args) when Array.length args >= 2 -> - let head = if isApp c then fst (destApp c) else c in - if Globnames.is_global (coq_eq_ref ()) head then None - else - (try - let params, args = Array.chop (Array.length args - 2) args in - let env' = Environ.push_rel_context rels env in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in - let evars = Sigma.to_evar_map sigma in - let evars, inst = - app_poly env (evars,Evar.Set.empty) - rewrite_relation_class [| evar; mkApp (c, params) |] in - let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in - Some (it_mkProd_or_LetIn t rels) - with e when Errors.noncritical e -> None) - | _ -> None - - -end - -(* let my_type_of env evars c = Typing.e_type_of env evars c *) -(* let mytypeofkey = Profile.declare_profile "my_type_of";; *) -(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) - - -let type_app_poly env env evd f args = - let evars, c = app_poly_nocheck env evd f args in - let evd', t = Typing.type_of env (goalevars evars) c in - (evd', cstrevars evars), c - -module PropGlobal = struct - module Consts = - struct - let relation_classes = ["Classes"; "RelationClasses"] - let morphisms = ["Classes"; "Morphisms"] - let relation = ["Relations";"Relation_Definitions"], "relation" - let app_poly = app_poly_nocheck - let arrow = find_global ["Program"; "Basics"] "arrow" - let coq_inverse = find_global ["Program"; "Basics"] "flip" - end - - module G = GlobalBindings(Consts) - - include G - include Consts - let inverse env evd car rel = - type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |] - (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *) - -end - -module TypeGlobal = struct - module Consts = - struct - let relation_classes = ["Classes"; "CRelationClasses"] - let morphisms = ["Classes"; "CMorphisms"] - let relation = relation_classes, "crelation" - let app_poly = app_poly_check - let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" - let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" - end - - module G = GlobalBindings(Consts) - include G - include Consts - - - let inverse env (evd,cstrs) car rel = - let sigma = Sigma.Unsafe.of_evar_map evd in - let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in - let evd = Sigma.to_evar_map sigma in - app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] - -end - -let sort_of_rel env evm rel = - Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) - -let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation - -(* let _ = *) -(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) - -let split_head = function - hd :: tl -> hd, tl - | [] -> assert(false) - -let evd_convertible env evd x y = - try - let evd = Evarconv.the_conv_x env x y evd in - (* Unfortunately, the_conv_x might say they are unifiable even if some - unsolvable constraints remain, so we check them here *) - let evd = Evarconv.consider_remaining_unif_problems env evd in - let () = Evarconv.check_problems_are_solved env evd in - Some evd - with e when Errors.noncritical e -> None - -let convertible env evd x y = - Reductionops.is_conv_leq env evd x y - -type hypinfo = { - prf : constr; - car : constr; - rel : constr; - sort : bool; (* true = Prop; false = Type *) - c1 : constr; - c2 : constr; - holes : Clenv.hole list; -} - -let get_symmetric_proof b = - if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof - -let error_no_relation () = error "Cannot find a relation to rewrite." - -let rec decompose_app_rel env evd t = - (** Head normalize for compatibility with the old meta mechanism *) - let t = Reductionops.whd_betaiota evd t in - match kind_of_term t with - | App (f, [||]) -> assert false - | App (f, [|arg|]) -> - let (f', argl, argr) = decompose_app_rel env evd arg in - let ty = Typing.unsafe_type_of env evd argl in - let f'' = mkLambda (Name default_dependent_ident, ty, - mkLambda (Name (Id.of_string "y"), lift 1 ty, - mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) - in (f'', argl, argr) - | App (f, args) -> - let len = Array.length args in - let fargs = Array.sub args 0 (Array.length args - 2) in - let rel = mkApp (f, fargs) in - rel, args.(len - 2), args.(len - 1) - | _ -> error_no_relation () - -let decompose_app_rel env evd t = - let (rel, t1, t2) = decompose_app_rel env evd t in - let ty = Retyping.get_type_of env evd rel in - let () = if not (Reduction.is_arity env ty) then error_no_relation () in - (rel, t1, t2) - -let decompose_applied_relation env sigma (c,l) = - let open Context.Rel.Declaration in - let ctype = Retyping.get_type_of env sigma c in - let find_rel ty = - let sigma, cl = Clenv.make_evar_clause env sigma ty in - let sigma = Clenv.solve_evar_clause env sigma true cl l in - let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in - let (equiv, c1, c2) = decompose_app_rel env sigma t in - let ty1 = Retyping.get_type_of env sigma c1 in - let ty2 = Retyping.get_type_of env sigma c2 in - match evd_convertible env sigma ty1 ty2 with - | None -> None - | Some sigma -> - let sort = sort_of_rel env sigma equiv in - let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in - let value = mkApp (c, args) in - Some (sigma, { prf=value; - car=ty1; rel = equiv; sort = Sorts.is_prop sort; - c1=c1; c2=c2; holes }) - in - match find_rel ctype with - | Some c -> c - | None -> - let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with - | Some c -> c - | None -> error "Cannot find an homogeneous relation to rewrite." - -let rewrite_db = "rewrite" - -let conv_transparent_state = (Id.Pred.empty, Cpred.full) - -let _ = - Hints.add_hints_init - (fun () -> - Hints.create_hint_db false rewrite_db conv_transparent_state true) - -let rewrite_transparent_state () = - Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) - -let rewrite_core_unif_flags = { - Unification.modulo_conv_on_closed_terms = None; - Unification.use_metas_eagerly_in_conv_on_closed_terms = true; - Unification.use_evars_eagerly_in_conv_on_closed_terms = true; - Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = full_transparent_state; - Unification.check_applied_meta_types = true; - Unification.use_pattern_unification = true; - Unification.use_meta_bound_pattern_unification = true; - Unification.frozen_evars = Evar.Set.empty; - Unification.restrict_conv_on_strict_subterms = false; - Unification.modulo_betaiota = false; - Unification.modulo_eta = true; -} - -(* Flags used for the setoid variant of "rewrite" and for the strategies - "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing - evars in "rewrite" (see unify_abs) *) -let rewrite_unif_flags = - let flags = rewrite_core_unif_flags in { - Unification.core_unify_flags = flags; - Unification.merge_unify_flags = flags; - Unification.subterm_unify_flags = flags; - Unification.allow_K_in_toplevel_higher_order_unification = true; - Unification.resolve_evars = true - } - -let rewrite_core_conv_unif_flags = { - rewrite_core_unif_flags with - Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; - Unification.modulo_delta_types = conv_transparent_state; - Unification.modulo_betaiota = true -} - -(* Fallback flags for the setoid variant of "rewrite" *) -let rewrite_conv_unif_flags = - let flags = rewrite_core_conv_unif_flags in { - Unification.core_unify_flags = flags; - Unification.merge_unify_flags = flags; - Unification.subterm_unify_flags = flags; - Unification.allow_K_in_toplevel_higher_order_unification = true; - Unification.resolve_evars = true - } - -(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *) -let general_rewrite_unif_flags () = - let ts = rewrite_transparent_state () in - let core_flags = - { rewrite_core_unif_flags with - Unification.modulo_conv_on_closed_terms = Some ts; - Unification.use_evars_eagerly_in_conv_on_closed_terms = false; - Unification.modulo_delta = ts; - Unification.modulo_delta_types = ts; - Unification.modulo_betaiota = true } - in { - Unification.core_unify_flags = core_flags; - Unification.merge_unify_flags = core_flags; - Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; - Unification.allow_K_in_toplevel_higher_order_unification = true; - Unification.resolve_evars = true - } - -let refresh_hypinfo env sigma (is, cb) = - let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in - let sigma, hypinfo = decompose_applied_relation env sigma cbl in - let { c1; c2; car; rel; prf; sort; holes } = hypinfo in - sigma, (car, rel, prf, c1, c2, holes, sort) - -(** FIXME: write this in the new monad interface *) -let solve_remaining_by env sigma holes by = - match by with - | None -> sigma - | Some tac -> - let map h = - if h.Clenv.hole_deps then None - else - let (evk, _) = destEvar (h.Clenv.hole_evar) in - Some evk - in - (** Only solve independent holes *) - let indep = List.map_filter map holes in - let solve_tac = Tacticals.New.tclCOMPLETE (Tacinterp.eval_tactic tac) in - let solve sigma evk = - let evi = - try Some (Evd.find_undefined sigma evk) - with Not_found -> None - in - match evi with - | None -> sigma - (** Evar should not be defined, but just in case *) - | Some evi -> - let env = Environ.reset_with_named_context evi.evar_hyps env in - let ty = evi.evar_concl in - let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in - Evd.define evk c sigma - in - List.fold_left solve sigma indep - -let no_constraints cstrs = - fun ev _ -> not (Evar.Set.mem ev cstrs) - -let all_constraints cstrs = - fun ev _ -> Evar.Set.mem ev cstrs - -let poly_inverse sort = - if sort then PropGlobal.inverse else TypeGlobal.inverse - -type rewrite_proof = - | RewPrf of constr * constr - (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) - | RewCast of cast_kind - (** A proof of convertibility (with casts) *) - -type rewrite_result_info = { - rew_car : constr ; - (** A type *) - rew_from : constr ; - (** A term of type rew_car *) - rew_to : constr ; - (** A term of type rew_car *) - rew_prf : rewrite_proof ; - (** A proof of rew_from == rew_to *) - rew_evars : evars; -} - -type rewrite_result = -| Fail -| Identity -| Success of rewrite_result_info - -type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) - env : Environ.env ; - unfresh : Id.t list ; (* Unfresh names *) - term1 : constr ; - ty1 : types ; (* first term and its type (convertible to rew_from) *) - cstr : (bool (* prop *) * constr option) ; - evars : evars } - -type 'a pure_strategy = { strategy : - 'a strategy_input -> - 'a * rewrite_result (* the updated state and the "result" *) } - -type strategy = unit pure_strategy - -let symmetry env sort rew = - let { rew_evars = evars; rew_car = car; } = rew in - let (rew_evars, rew_prf) = match rew.rew_prf with - | RewCast _ -> (rew.rew_evars, rew.rew_prf) - | RewPrf (rel, prf) -> - try - let evars, symprf = get_symmetric_proof sort env evars car rel in - let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in - (evars, RewPrf (rel, prf)) - with Not_found -> - let evars, rel = poly_inverse sort env evars car rel in - (evars, RewPrf (rel, prf)) - in - { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; } - -(* Matching/unifying the rewriting rule against [t] *) -let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t = - try - let left = if l2r then c1 else c2 in - let sigma = Unification.w_unify ~flags env sigma CONV left t in - let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) - ~fail:true env sigma in - let evd = solve_remaining_by env sigma holes by in - let nf c = Evarutil.nf_evar evd (Reductionops.nf_meta evd c) in - let c1 = nf c1 and c2 = nf c2 - and rew_car = nf car and rel = nf rel - and prf = nf prf in - let ty1 = Retyping.get_type_of env evd c1 in - let ty2 = Retyping.get_type_of env evd c2 in - let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in - let rew_evars = evd, cstrs in - let rew_prf = RewPrf (rel, prf) in - let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in - let rew = if l2r then rew else symmetry env sort rew in - Some rew - with - | e when Class_tactics.catchable e -> None - | Reduction.NotConvertible -> None - -let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = - try - let left = if l2r then c1 else c2 in - (* The pattern is already instantiated, so the next w_unify is - basically an eq_constr, except when preexisting evars occur in - either the lemma or the goal, in which case the eq_constr also - solved this evars *) - let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in - let rew_evars = sigma, cstrs in - let rew_prf = RewPrf (rel, prf) in - let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in - let rew = if l2r then rew else symmetry env sort rew in - Some rew - with - | e when Class_tactics.catchable e -> None - | Reduction.NotConvertible -> None - -type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } - -let default_flags = { under_lambdas = true; on_morphisms = true; } - -let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None - -let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) -let make_eq_refl () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) - -let get_rew_prf r = match r.rew_prf with - | RewPrf (rel, prf) -> rel, prf - | RewCast c -> - let rel = mkApp (make_eq (), [| r.rew_car |]) in - rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), - c, mkApp (rel, [| r.rew_from; r.rew_to |])) - -let poly_subrelation sort = - if sort then PropGlobal.subrelation else TypeGlobal.subrelation - -let resolve_subrelation env avoid car rel sort prf rel' res = - if eq_constr rel rel' then res - else - let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in - let evars, subrel = new_cstr_evar evars env app in - let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in - { res with - rew_prf = RewPrf (rel', appsub); - rew_evars = evars } - -let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = - let evars, morph_instance, proj, sigargs, m', args, args' = - let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with - | Some i -> i - | None -> invalid_arg "resolve_morphism" in - let morphargs, morphobjs = Array.chop first args in - let morphargs', morphobjs' = Array.chop first args' in - let appm = mkApp(m, morphargs) in - let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in - let cstrs = List.map - (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) - (Array.to_list morphobjs') - in - (* Desired signature *) - let evars, appmtype', signature, sigargs = - if b then PropGlobal.build_signature evars env appmtype cstrs cstr - else TypeGlobal.build_signature evars env appmtype cstrs cstr - in - (* Actual signature found *) - let cl_args = [| appmtype' ; signature ; appm |] in - let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) - cl_args in - let env' = - let dosub, appsub = - if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation - else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation - in - Environ.push_named - (LocalDef (Id.of_string "do_subrelation", - snd (app_poly_sort b env evars dosub [||]), - snd (app_poly_nocheck env evars appsub [||]))) - env - in - let evars, morph = new_cstr_evar evars env' app in - evars, morph, morph, sigargs, appm, morphobjs, morphobjs' - in - let projargs, subst, evars, respars, typeargs = - Array.fold_left2 - (fun (acc, subst, evars, sigargs, typeargs') x y -> - let (carrier, relation), sigargs = split_head sigargs in - match relation with - | Some relation -> - let carrier = substl subst carrier - and relation = substl subst relation in - (match y with - | None -> - let evars, proof = - (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) - env evars carrier relation x in - [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' - | Some r -> - [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, - sigargs, r.rew_to :: typeargs') - | None -> - if not (Option.is_empty y) then - error "Cannot rewrite inside dependent arguments of a function"; - x :: acc, x :: subst, evars, sigargs, x :: typeargs') - ([], [], evars, sigargs, []) args args' - in - let proof = applistc proj (List.rev projargs) in - let newt = applistc m' (List.rev typeargs) in - match respars with - [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt - | _ -> assert(false) - -let apply_constraint env avoid car rel prf cstr res = - match snd cstr with - | None -> res - | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res - -let coerce env avoid cstr res = - let rel, prf = get_rew_prf res in - apply_constraint env avoid res.rew_car rel prf cstr res - -let apply_rule unify loccs : int pure_strategy = - let (nowhere_except_in,occs) = convert_occs loccs in - let is_occ occ = - if nowhere_except_in - then List.mem occ occs - else not (List.mem occ occs) - in - { strategy = fun { state = occ ; env ; unfresh ; - term1 = t ; ty1 = ty ; cstr ; evars } -> - let unif = if isEvar t then None else unify env evars t in - match unif with - | None -> (occ, Fail) - | Some rew -> - let occ = succ occ in - if not (is_occ occ) then (occ, Fail) - else if eq_constr t rew.rew_to then (occ, Identity) - else - let res = { rew with rew_car = ty } in - let rel, prf = get_rew_prf res in - let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in - (occ, res) - } - -let apply_lemma l2r flags oc by loccs : strategy = { strategy = - fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) -> - let sigma, c = oc sigma in - let sigma, hypinfo = decompose_applied_relation env sigma c in - let { c1; c2; car; rel; prf; sort; holes } = hypinfo in - let rew = (car, rel, prf, c1, c2, holes, sort) in - let evars = (sigma, cstrs) in - let unify env evars t = - let rew = unify_eqn rew l2r flags env evars by t in - match rew with - | None -> None - | Some rew -> Some rew - in - let _, res = (apply_rule unify loccs).strategy { input with - state = 0 ; - evars } in - (), res - } - -let e_app_poly env evars f args = - let evars', c = app_poly_nocheck env !evars f args in - evars := evars'; - c - -let make_leibniz_proof env c ty r = - let evars = ref r.rew_evars in - let prf = - match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = e_app_poly env evars coq_eq [| ty |] in - let prf = - e_app_poly env evars coq_f_equal - [| r.rew_car; ty; - mkLambda (Anonymous, r.rew_car, c); - r.rew_from; r.rew_to; prf |] - in RewPrf (rel, prf) - | RewCast k -> r.rew_prf - in - { rew_car = ty; rew_evars = !evars; - rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } - -let reset_env env = - let env' = Global.env_of_context (Environ.named_context_val env) in - Environ.push_rel_context (Environ.rel_context env) env' - -let fold_match ?(force=false) env sigma c = - let (ci, p, c, brs) = destCase c in - let cty = Retyping.get_type_of env sigma c in - let dep, pred, exists, (sk,eff) = - let env', ctx, body = - let ctx, pred = decompose_lam_assum p in - let env' = Environ.push_rel_context ctx env in - env', ctx, pred - in - let sortp = Retyping.get_sort_family_of env' sigma body in - let sortc = Retyping.get_sort_family_of env sigma cty in - let dep = not (noccurn 1 body) in - let pred = if dep then p else - it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) - in - let sk = - if sortp == InProp then - if sortc == InProp then - if dep then case_dep_scheme_kind_from_prop - else case_scheme_kind_from_prop - else ( - if dep - then case_dep_scheme_kind_from_type_in_prop - else case_scheme_kind_from_type) - else ((* sortc <> InProp by typing *) - if dep - then case_dep_scheme_kind_from_type - else case_scheme_kind_from_type) - in - let exists = Ind_tables.check_scheme sk ci.ci_ind in - if exists || force then - dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind - else raise Not_found - in - let app = - let ind, args = Inductive.find_rectype env cty in - let pars, args = List.chop ci.ci_npar args in - let meths = List.map (fun br -> br) (Array.to_list brs) in - applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) - in - sk, (if exists then env else reset_env env), app, eff - -let unfold_match env sigma sk app = - match kind_of_term app with - | App (f', args) when eq_constant (fst (destConst f')) sk -> - let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in - Reductionops.whd_beta sigma (mkApp (v, args)) - | _ -> app - -let is_rew_cast = function RewCast _ -> true | _ -> false - -let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = - let rec aux { state ; env ; unfresh ; - term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = - let cstr' = Option.map (fun c -> (ty, Some c)) cstr in - match kind_of_term t with - | App (m, args) -> - let rewrite_args state success = - let state, (args', evars', progress) = - Array.fold_left - (fun (state, (acc, evars, progress)) arg -> - if not (Option.is_empty progress) && not all then - state, (None :: acc, evars, progress) - else - let argty = Retyping.get_type_of env (goalevars evars) arg in - let state, res = s.strategy { state ; env ; - unfresh ; - term1 = arg ; ty1 = argty ; - cstr = (prop,None) ; - evars } in - let res' = - match res with - | Identity -> - let progress = if Option.is_empty progress then Some false else progress in - (None :: acc, evars, progress) - | Success r -> - (Some r :: acc, r.rew_evars, Some true) - | Fail -> (None :: acc, evars, progress) - in state, res') - (state, ([], evars, success)) args - in - let res = - match progress with - | None -> Fail - | Some false -> Identity - | Some true -> - let args' = Array.of_list (List.rev args') in - if Array.exists - (function - | None -> false - | Some r -> not (is_rew_cast r.rew_prf)) args' - then - let evars', prf, car, rel, c1, c2 = - resolve_morphism env unfresh t m args args' (prop, cstr') evars' - in - let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evars' } - in Success res - else - let args' = Array.map2 - (fun aorig anew -> - match anew with None -> aorig - | Some r -> r.rew_to) args args' - in - let res = { rew_car = ty; rew_from = t; - rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; - rew_evars = evars' } - in Success res - in state, res - in - if flags.on_morphisms then - let mty = Retyping.get_type_of env (goalevars evars) m in - let evars, cstr', m, mty, argsl, args = - let argsl = Array.to_list args in - let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in - match lift env evars argsl m mty None with - | Some (evars, cstr', m, mty, args) -> - evars, Some cstr', m, mty, args, Array.of_list args - | None -> evars, None, m, mty, argsl, args - in - let state, m' = s.strategy { state ; env ; unfresh ; - term1 = m ; ty1 = mty ; - cstr = (prop, cstr') ; evars } in - match m' with - | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) - | Identity -> rewrite_args state (Some false) - | Success r -> - (* We rewrote the function and get a proof of pointwise rel for the arguments. - We just apply it. *) - let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let app = if prop then PropGlobal.apply_pointwise - else TypeGlobal.apply_pointwise - in - RewPrf (app rel argsl, mkApp (prf, args)) - | x -> x - in - let res = - { rew_car = prod_appvect r.rew_car args; - rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); - rew_prf = prf; rew_evars = r.rew_evars } - in - let res = - match prf with - | RewPrf (rel, prf) -> - Success (apply_constraint env unfresh res.rew_car - rel prf (prop,cstr) res) - | _ -> Success res - in state, res - else rewrite_args state None - - | Prod (n, x, b) when noccurn 1 b -> - let b = subst1 mkProp b in - let tx = Retyping.get_type_of env (goalevars evars) x - and tb = Retyping.get_type_of env (goalevars evars) b in - let arr = if prop then PropGlobal.arrow_morphism - else TypeGlobal.arrow_morphism - in - let (evars', mor), unfold = arr env evars tx tb x b in - let state, res = aux { state ; env ; unfresh ; - term1 = mor ; ty1 = ty ; - cstr = (prop,cstr) ; evars = evars' } in - let res = - match res with - | Success r -> Success { r with rew_to = unfold r.rew_to } - | Fail | Identity -> res - in state, res - - (* if x' = None && flags.under_lambdas then *) - (* let lam = mkLambda (n, x, b) in *) - (* let lam', occ = aux env lam occ None in *) - (* let res = *) - (* match lam' with *) - (* | None -> None *) - (* | Some (prf, (car, rel, c1, c2)) -> *) - (* Some (resolve_morphism env sigma t *) - (* ~fnewt:unfold_all *) - (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) - (* cstr evars) *) - (* in res, occ *) - (* else *) - - | Prod (n, dom, codom) -> - let lam = mkLambda (n, dom, codom) in - let (evars', app), unfold = - if eq_constr ty mkProp then - (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all - else - let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in - (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall - in - let state, res = aux { state ; env ; unfresh ; - term1 = app ; ty1 = ty ; - cstr = (prop,cstr) ; evars = evars' } in - let res = - match res with - | Success r -> Success { r with rew_to = unfold r.rew_to } - | Fail | Identity -> res - in state, res - -(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with - H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. - B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing - dependent relations and using projections to get them out. - *) - (* | Lambda (n, t, b) when flags.under_lambdas -> *) - (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) - (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) - (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) - (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) - (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) - (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) - (* (match b' with *) - (* | Some (Some r) -> *) - (* let prf = match r.rew_prf with *) - (* | RewPrf (rel, prf) -> *) - (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) - (* let prf = mkLambda (n', t, prf) in *) - (* RewPrf (rel, prf) *) - (* | x -> x *) - (* in *) - (* Some (Some { r with *) - (* rew_prf = prf; *) - (* rew_car = mkProd (n, t, r.rew_car); *) - (* rew_from = mkLambda(n, t, r.rew_from); *) - (* rew_to = mkLambda (n, t, r.rew_to) }) *) - (* | _ -> b') *) - - | Lambda (n, t, b) when flags.under_lambdas -> - let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in - let open Context.Rel.Declaration in - let env' = Environ.push_rel (LocalAssum (n', t)) env in - let bty = Retyping.get_type_of env' (goalevars evars) b in - let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in - let state, b' = s.strategy { state ; env = env' ; unfresh ; - term1 = b ; ty1 = bty ; - cstr = (prop, unlift env evars cstr) ; - evars } in - let res = - match b' with - | Success r -> - let r = match r.rew_prf with - | RewPrf (rel, prf) -> - let point = if prop then PropGlobal.pointwise_or_dep_relation else - TypeGlobal.pointwise_or_dep_relation - in - let evars, rel = point env r.rew_evars n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in - { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } - | x -> r - in - Success { r with - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } - | Fail | Identity -> b' - in state, res - - | Case (ci, p, c, brs) -> - let cty = Retyping.get_type_of env (goalevars evars) c in - let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in - let cstr' = Some eqty in - let state, c' = s.strategy { state ; env ; unfresh ; - term1 = c ; ty1 = cty ; - cstr = (prop, cstr') ; evars = evars' } in - let state, res = - match c' with - | Success r -> - let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in - let res = make_leibniz_proof env case ty r in - state, Success (coerce env unfresh (prop,cstr) res) - | Fail | Identity -> - if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then - let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in - let cstr = Some eqty in - let state, found, brs' = Array.fold_left - (fun (state, found, acc) br -> - if not (Option.is_empty found) then - (state, found, fun x -> lift 1 br :: acc x) - else - let state, res = s.strategy { state ; env ; unfresh ; - term1 = br ; ty1 = ty ; - cstr = (prop,cstr) ; evars } in - match res with - | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) - | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) - (state, None, fun x -> []) brs - in - match found with - | Some r -> - let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in - state, Success (make_leibniz_proof env ctxc ty r) - | None -> state, c' - else - match try Some (fold_match env (goalevars evars) t) with Not_found -> None with - | None -> state, c' - | Some (cst, _, t', eff (*FIXME*)) -> - let state, res = aux { state ; env ; unfresh ; - term1 = t' ; ty1 = ty ; - cstr = (prop,cstr) ; evars } in - let res = - match res with - | Success prf -> - Success { prf with - rew_from = t; - rew_to = unfold_match env (goalevars evars) cst prf.rew_to } - | x' -> c' - in state, res - in - let res = - match res with - | Success r -> - let rel, prf = get_rew_prf r in - Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) - | Fail | Identity -> res - in state, res - | _ -> state, Fail - in { strategy = aux } - -let all_subterms = subterm true default_flags -let one_subterm = subterm false default_flags - -(** Requires transitivity of the rewrite step, if not a reduction. - Not tail-recursive. *) - -let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : - 'a * rewrite_result = - let state, nextres = - next.strategy { state ; env ; unfresh ; - term1 = res.rew_to ; ty1 = res.rew_car ; - cstr = (prop, get_opt_rew_rel res.rew_prf) ; - evars = res.rew_evars } - in - let res = - match nextres with - | Fail -> Fail - | Identity -> Success res - | Success res' -> - match res.rew_prf with - | RewCast c -> Success { res' with rew_from = res.rew_from } - | RewPrf (rew_rel, rew_prf) -> - match res'.rew_prf with - | RewCast _ -> Success { res with rew_to = res'.rew_to } - | RewPrf (res'_rel, res'_prf) -> - let trans = - if prop then PropGlobal.transitive_type - else TypeGlobal.transitive_type - in - let evars, prfty = - app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] - in - let evars, prf = new_cstr_evar evars env prfty in - let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; - rew_prf; res'_prf |]) - in Success { res' with rew_from = res.rew_from; - rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } - in state, res - -(** Rewriting strategies. - - Inspired by ELAN's rewriting strategies: - http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 -*) - -module Strategies = - struct - - let fail : 'a pure_strategy = - { strategy = fun { state } -> state, Fail } - - let id : 'a pure_strategy = - { strategy = fun { state } -> state, Identity } - - let refl : 'a pure_strategy = - { strategy = - fun { state ; env ; - term1 = t ; ty1 = ty ; - cstr = (prop,cstr) ; evars } -> - let evars, rel = match cstr with - | None -> - let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in - let evars, rty = mkr env evars ty in - new_cstr_evar evars env rty - | Some r -> evars, r - in - let evars, proof = - let proxy = - if prop then PropGlobal.proper_proxy_type - else TypeGlobal.proper_proxy_type - in - let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in - new_cstr_evar evars env mty - in - let res = Success { rew_car = ty; rew_from = t; rew_to = t; - rew_prf = RewPrf (rel, proof); rew_evars = evars } - in state, res - } - - let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = - fun input -> - let state, res = s.strategy input in - match res with - | Fail -> state, Fail - | Identity -> state, Fail - | Success r -> state, Success r - } - - let seq first snd : 'a pure_strategy = { strategy = - fun ({ env ; unfresh ; cstr } as input) -> - let state, res = first.strategy input in - match res with - | Fail -> state, Fail - | Identity -> snd.strategy { input with state } - | Success res -> transitivity state env unfresh (fst cstr) res snd - } - - let choice fst snd : 'a pure_strategy = { strategy = - fun input -> - let state, res = fst.strategy input in - match res with - | Fail -> snd.strategy { input with state } - | Identity | Success _ -> state, res - } - - let try_ str : 'a pure_strategy = choice str id - - let check_interrupt str input = - Control.check_for_interrupt (); - str input - - let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = - let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in - { strategy = aux } - - let any (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun any -> try_ (seq s any)) - - let repeat (s : 'a pure_strategy) : 'a pure_strategy = - seq s (any s) - - let bu (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) - - let td (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) - - let innermost (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun ins -> choice (one_subterm ins) s) - - let outermost (s : 'a pure_strategy) : 'a pure_strategy = - fix (fun out -> choice s (one_subterm out)) - - let lemmas cs : 'a pure_strategy = - List.fold_left (fun tac (l,l2r,by) -> - choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) - fail cs - - let inj_open hint = (); fun sigma -> - let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in - let sigma = Evd.merge_universe_context sigma ctx in - (sigma, (hint.Autorewrite.rew_lemma, NoBindings)) - - let old_hints (db : string) : 'a pure_strategy = - let rules = Autorewrite.find_rewrites db in - lemmas - (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, - hint.Autorewrite.rew_tac)) rules) - - let hints (db : string) : 'a pure_strategy = { strategy = - fun ({ term1 = t } as input) -> - let rules = Autorewrite.find_matches db t in - let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, - hint.Autorewrite.rew_tac) in - let lems = List.map lemma rules in - (lemmas lems).strategy input - } - - let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = - fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> - let rfn, ckind = Redexpr.reduction_of_red_expr env r in - let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in - let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in - let evars' = Sigma.to_evar_map sigma in - if eq_constr t' t then - state, Identity - else - state, Success { rew_car = ty; rew_from = t; rew_to = t'; - rew_prf = RewCast ckind; - rew_evars = evars', cstrevars evars } - } - - let fold_glob c : 'a pure_strategy = { strategy = - fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> -(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) - let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in - let unfolded = - try Tacred.try_red_product env sigma c - with e when Errors.noncritical e -> - error "fold: the term is not unfoldable !" - in - try - let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in - let c' = Evarutil.nf_evar sigma c in - state, Success { rew_car = ty; rew_from = t; rew_to = c'; - rew_prf = RewCast DEFAULTcast; - rew_evars = (sigma, snd evars) } - with e when Errors.noncritical e -> state, Fail - } - - -end - -(** The strategy for a single rewrite, dealing with occurrences. *) - -(** A dummy initial clauseenv to avoid generating initial evars before - even finding a first application of the rewriting lemma, in setoid_rewrite - mode *) - -let rewrite_with l2r flags c occs : strategy = { strategy = - fun ({ state = () } as input) -> - let unify env evars t = - let (sigma, cstrs) = evars in - let ans = - try Some (refresh_hypinfo env sigma c) - with e when Class_tactics.catchable e -> None - in - match ans with - | None -> None - | Some (sigma, rew) -> - let rew = unify_eqn rew l2r flags env (sigma, cstrs) None t in - match rew with - | None -> None - | Some rew -> Some rew - in - let app = apply_rule unify occs in - let strat = - Strategies.fix (fun aux -> - Strategies.choice app (subterm true default_flags aux)) - in - let _, res = strat.strategy { input with state = 0 } in - ((), res) - } - -let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = - let ty = Retyping.get_type_of env (goalevars evars) concl in - let _, res = s.strategy { state = () ; env ; unfresh ; - term1 = concl ; ty1 = ty ; - cstr = (prop, Some cstr) ; evars } in - res - -let solve_constraints env (evars,cstrs) = - let filter = all_constraints cstrs in - Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true - (Typeclasses.mark_resolvables ~filter evars) - -let nf_zeta = - Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - -exception RewriteFailure of Pp.std_ppcmds - -type result = (evar_map * constr option * types) option option - -let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = - let evdref = ref sigma in - let sort = Typing.e_sort_of env evdref concl in - let evars = (!evdref, Evar.Set.empty) in - let evars, cstr = - let prop, (evars, arrow) = - if is_prop_sort sort then true, app_poly_sort true env evars impl [||] - else false, app_poly_sort false env evars TypeGlobal.arrow [||] - in - match is_hyp with - | None -> - let evars, t = poly_inverse prop env evars (mkSort sort) arrow in - evars, (prop, t) - | Some _ -> evars, (prop, arrow) - in - let eq = apply_strategy strat env avoid concl cstr evars in - match eq with - | Fail -> None - | Identity -> Some None - | Success res -> - let (_, cstrs) = res.rew_evars in - let evars' = solve_constraints env res.rew_evars in - let newt = Evarutil.nf_evar evars' res.rew_to in - let evars = (* Keep only original evars (potentially instantiated) and goal evars, - the rest has been defined and substituted already. *) - Evar.Set.fold - (fun ev acc -> - if not (Evd.is_defined acc ev) then - errorlabstrm "rewrite" - (str "Unsolved constraint remaining: " ++ spc () ++ - Evd.pr_evar_info (Evd.find acc ev)) - else Evd.remove acc ev) - cstrs evars' - in - let res = match res.rew_prf with - | RewCast c -> None - | RewPrf (rel, p) -> - let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in - let term = - match abs with - | None -> p - | Some (t, ty) -> - let t = Evarutil.nf_evar evars' t in - let ty = Evarutil.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) - in - let proof = match is_hyp with - | None -> term - | Some id -> mkApp (term, [| mkVar id |]) - in Some proof - in Some (Some (evars, res, newt)) - -(** Insert a declaration after the last declaration it depends on *) -let rec insert_dependent env decl accu hyps = match hyps with -| [] -> List.rev_append accu [decl] -| ndecl :: rem -> - if occur_var_in_decl env (get_id ndecl) decl then - List.rev_append accu (decl :: hyps) - else - insert_dependent env decl (ndecl :: accu) rem - -let assert_replacing id newt tac = - let prf = Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let ctx = Environ.named_context env in - let after, before = List.split_when (Id.equal id % get_id) ctx in - let nc = match before with - | [] -> assert false - | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem - in - let env' = Environ.reset_with_named_context (val_of_named_context nc) env in - Refine.refine ~unsafe:false { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in - let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in - let map d = - let n = get_id d in - if Id.equal n id then ev' else mkVar n - in - let (e, _) = destEvar ev in - Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) - end } - end } in - Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) - -let newfail n s = - Proofview.tclZERO (Refiner.FailError (n, lazy s)) - -let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = - let open Proofview.Notations in - let treat sigma res = - match res with - | None -> newfail 0 (str "Nothing to rewrite") - | Some None -> if progress then newfail 0 (str"Failed to progress") - else Proofview.tclUNIT () - | Some (Some res) -> - let (undef, prf, newt) = res in - let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in - let gls = List.rev (Evd.fold_undefined fold undef []) in - match clause, prf with - | Some id, Some p -> - let tac = Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in - Proofview.Unsafe.tclEVARS undef <*> - assert_replacing id newt tac - | Some id, None -> - Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (id, newt)) - | None, Some p -> - Proofview.Unsafe.tclEVARS undef <*> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let make = { run = begin fun sigma -> - let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in - Sigma (mkApp (p, [| ev |]), sigma, q) - end } in - Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls - end } - | None, None -> - Proofview.Unsafe.tclEVARS undef <*> - convert_concl_no_check newt DEFAULTcast - in - let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in - let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in - let opt_beta = match clause with - | None -> Proofview.tclUNIT () - | Some id -> Tactics.reduct_in_hyp beta_red (id, InHyp) - in - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let ty = match clause with - | None -> concl - | Some id -> Environ.named_type id env - in - let env = match clause with - | None -> env - | Some id -> - (** Only consider variables not depending on [id] *) - let ctx = Environ.named_context env in - let filter decl = not (occur_var_in_decl env id decl) in - let nctx = List.filter filter ctx in - Environ.reset_with_named_context (Environ.val_of_named_context nctx) env - in - try - let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty clause - in - let sigma = match origsigma with None -> sigma | Some sigma -> sigma in - treat sigma res <*> - (** For compatibility *) - beta <*> opt_beta <*> Proofview.shelve_unifiable - with - | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> - raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) - end } - -let tactic_init_setoid () = - try init_setoid (); tclIDTAC - with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded") - -let cl_rewrite_clause_strat progress strat clause = - tclTHEN (tactic_init_setoid ()) - ((if progress then tclWEAK_PROGRESS else fun x -> x) - (fun gl -> - try Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~progress strat clause) gl - with RewriteFailure e -> - errorlabstrm "" (str"setoid rewrite failed: " ++ e) - | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)) - -(** Setoid rewriting when called with "setoid_rewrite" *) -let cl_rewrite_clause l left2right occs clause gl = - let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in - cl_rewrite_clause_strat true strat clause gl - -(** Setoid rewriting when called with "rewrite_strat" *) -let cl_rewrite_clause_strat strat clause = - cl_rewrite_clause_strat false strat clause - -let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> - let c sigma = - let (sigma, c) = Pretyping.understand_tcc env sigma c in - (sigma, (c, NoBindings)) - in - let flags = general_rewrite_unif_flags () in - (apply_lemma l2r flags c None occs).strategy input - -let interp_glob_constr_list env = - let make c = (); fun sigma -> - let sigma, c = Pretyping.understand_tcc env sigma c in - (sigma, (c, NoBindings)) - in - List.map (fun c -> make c, true, None) - -(* Syntax for rewriting with strategies *) - -type unary_strategy = - Subterms | Subterm | Innermost | Outermost - | Bottomup | Topdown | Progress | Try | Any | Repeat - -type binary_strategy = - | Compose | Choice - -type ('constr,'redexpr) strategy_ast = - | StratId | StratFail | StratRefl - | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast - | StratBinary of binary_strategy - * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast - | StratConstr of 'constr * bool - | StratTerms of 'constr list - | StratHints of bool * string - | StratEval of 'redexpr - | StratFold of 'constr - -let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function - | StratId | StratFail | StratRefl as s -> s - | StratUnary (s, str) -> StratUnary (s, map_strategy f g str) - | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str') - | StratConstr (c, b) -> StratConstr (f c, b) - | StratTerms l -> StratTerms (List.map f l) - | StratHints (b, id) -> StratHints (b, id) - | StratEval r -> StratEval (g r) - | StratFold c -> StratFold (f c) - -let rec strategy_of_ast = function - | StratId -> Strategies.id - | StratFail -> Strategies.fail - | StratRefl -> Strategies.refl - | StratUnary (f, s) -> - let s' = strategy_of_ast s in - let f' = match f with - | Subterms -> all_subterms - | Subterm -> one_subterm - | Innermost -> Strategies.innermost - | Outermost -> Strategies.outermost - | Bottomup -> Strategies.bu - | Topdown -> Strategies.td - | Progress -> Strategies.progress - | Try -> Strategies.try_ - | Any -> Strategies.any - | Repeat -> Strategies.repeat - in f' s' - | StratBinary (f, s, t) -> - let s' = strategy_of_ast s in - let t' = strategy_of_ast t in - let f' = match f with - | Compose -> Strategies.seq - | Choice -> Strategies.choice - in f' s' t' - | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } - | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id - | StratTerms l -> { strategy = - (fun ({ state = () ; env } as input) -> - let l' = interp_glob_constr_list env (List.map fst l) in - (Strategies.lemmas l').strategy input) - } - | StratEval r -> { strategy = - (fun ({ state = () ; env ; evars } as input) -> - let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in - (Strategies.reduce r_interp).strategy { input with - evars = (sigma,cstrevars evars) }) } - | StratFold c -> Strategies.fold_glob (fst c) - - -(* By default the strategy for "rewrite_db" is top-down *) - -let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) - -let declare_an_instance n s args = - (((Loc.ghost,Name n),None), Explicit, - CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), - args)) - -let declare_instance a aeq n s = declare_an_instance n s [a;aeq] - -let anew_instance global binders instance fields = - new_instance (Flags.is_universe_polymorphism ()) - binders instance (Some (true, CRecord (Loc.ghost,fields))) - ~global ~generalize:false None - -let declare_instance_refl global binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] - -let declare_instance_sym global binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] - -let declare_instance_trans global binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] - -let declare_relation ?(binders=[]) a aeq n refl symm trans = - init_setoid (); - let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in - let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance global binders instance []); - match (refl,symm,trans) with - (None, None, None) -> () - | (Some lemma1, None, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1) - | (None, Some lemma2, None) -> - ignore (declare_instance_sym global binders a aeq n lemma2) - | (None, None, Some lemma3) -> - ignore (declare_instance_trans global binders a aeq n lemma3) - | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1); - ignore (declare_instance_sym global binders a aeq n lemma2) - | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); - (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) - | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); - (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) - | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); - (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); - (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) - -let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) - -let proper_projection r ty = - let ctx, inst = decompose_prod_assum ty in - let mor, args = destApp inst in - let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force PropGlobal.proper_proj, - Array.append args [| instarg |]) in - it_mkLambda_or_LetIn app ctx - -let declare_projection n instance_id r = - let poly = Global.is_polymorphic r in - let env = Global.env () in - let sigma = Evd.from_env env in - let evd,c = Evd.fresh_global env sigma r in - let ty = Retyping.get_type_of env sigma c in - let term = proper_projection c ty in - let typ = Typing.unsafe_type_of env sigma term in - let ctx, typ = decompose_prod_assum typ in - let typ = - let n = - let rec aux t = - match kind_of_term t with - | App (f, [| a ; a' ; rel; rel' |]) - when Globnames.is_global (PropGlobal.respectful_ref ()) f -> - succ (aux rel') - | _ -> 0 - in - let init = - match kind_of_term typ with - App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f -> - mkApp (f, fst (Array.chop (Array.length args - 2) args)) - | _ -> typ - in aux init - in - let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ - in it_mkProd_or_LetIn ccl ctx - in - let typ = it_mkProd_or_LetIn typ ctx in - let pl, ctx = Evd.universe_context sigma in - let cst = - Declare.definition_entry ~types:typ ~poly ~univs:ctx term - in - ignore(Declare.declare_constant n - (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) - -let build_morphism_signature m = - let env = Global.env () in - let sigma = Evd.from_env env in - let m,ctx = Constrintern.interp_constr env sigma m in - let sigma = Evd.from_ctx ctx in - let t = Typing.unsafe_type_of env sigma m in - let cstrs = - let rec aux t = - match kind_of_term t with - | Prod (na, a, b) -> - None :: aux b - | _ -> [] - in aux t - in - let evars, t', sig_, cstrs = - PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in - let evd = ref evars in - let _ = List.iter - (fun (ty, rel) -> - Option.iter (fun rel -> - let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in - ignore(e_new_cstr_evar env evd default)) - rel) - cstrs - in - let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in - let evd = solve_constraints env !evd in - let m = Evarutil.nf_evar evd morph in - Pretyping.check_evars env Evd.empty evd m; m - -let default_morphism sign m = - let env = Global.env () in - let sigma = Evd.from_env env in - let t = Typing.unsafe_type_of env sigma m in - let evars, _, sign, cstrs = - PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) - in - let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in - let evars, mor = resolve_one_typeclass env (goalevars evars) morph in - mor, proper_projection mor morph - -let add_setoid global binders a aeq t n = - init_setoid (); - let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" - in ignore( - anew_instance global binders instance - [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) - - -let make_tactic name = - let open Tacexpr in - let loc = Loc.ghost in - let tacpath = Libnames.qualid_of_string name in - let tacname = Qualid (loc, tacpath) in - TacArg (loc, TacCall (loc, tacname, [])) - -let add_morphism_infer glob m n = - init_setoid (); - let poly = Flags.is_universe_polymorphism () in - let instance_id = add_suffix n "_Proper" in - let instance = build_morphism_signature m in - let evd = Evd.from_env (Global.env ()) in - if Lib.is_modtype () then - let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id - (Entries.ParameterEntry - (None,poly,(instance,Univ.UContext.empty),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) - in - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) None glob - poly (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - else - let kind = Decl_kinds.Global, poly, - Decl_kinds.DefinitionBody Decl_kinds.Instance - in - let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in - let hook _ = function - | Globnames.ConstRef cst -> - add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) None - glob poly (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) - | _ -> assert false - in - let hook = Lemmas.mk_hook hook in - Flags.silently - (fun () -> - Lemmas.start_proof instance_id kind evd instance hook; - ignore (Pfedit.by (Tacinterp.interp tac))) () - -let add_morphism glob binders m s n = - init_setoid (); - let poly = Flags.is_universe_polymorphism () in - let instance_id = add_suffix n "_Proper" in - let instance = - (((Loc.ghost,Name instance_id),None), Explicit, - CAppExpl (Loc.ghost, - (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), - [cHole; s; m])) - in - let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~global:glob poly binders instance - (Some (true, CRecord (Loc.ghost,[]))) - ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) - -(** Bind to "rewrite" too *) - -(** Taken from original setoid_replace, to emulate the old rewrite semantics where - lemmas are first instantiated and then rewrite proceeds. *) - -let check_evar_map_of_evars_defs evd = - let metas = Evd.meta_list evd in - let check_freemetas_is_empty rebus = - Evd.Metaset.iter - (fun m -> - if Evd.meta_defined evd m then () else - raise - (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) - in - List.iter - (fun (_,binding) -> - match binding with - Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> - check_freemetas_is_empty rebus freemetas - | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), - {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> - check_freemetas_is_empty rebus1 freemetas1 ; - check_freemetas_is_empty rebus2 freemetas2 - ) metas - -(* Find a subterm which matches the pattern to rewrite for "rewrite" *) -let unification_rewrite l2r c1 c2 sigma prf car rel but env = - let (sigma,c') = - try - (* ~flags:(false,true) to allow to mark occurrences that must not be - rewritten simply by replacing them with let-defined definitions - in the context *) - Unification.w_unify_to_subterm - ~flags:rewrite_unif_flags - env sigma ((if l2r then c1 else c2),but) - with - | ex when Pretype_errors.precatchable_exception ex -> - (* ~flags:(true,true) to make Ring work (since it really - exploits conversion) *) - Unification.w_unify_to_subterm - ~flags:rewrite_conv_unif_flags - env sigma ((if l2r then c1 else c2),but) - in - let nf c = Evarutil.nf_evar sigma c in - let c1 = if l2r then nf c' else nf c1 - and c2 = if l2r then nf c2 else nf c' - and car = nf car and rel = nf rel in - check_evar_map_of_evars_defs sigma; - let prf = nf prf in - let prfty = nf (Retyping.get_type_of env sigma prf) in - let sort = sort_of_rel env sigma but in - let abs = prf, prfty in - let prf = mkRel 1 in - let res = (car, rel, prf, c1, c2) in - abs, sigma, res, Sorts.is_prop sort - -let get_hyp gl (c,l) clause l2r = - let evars = project gl in - let env = pf_env gl in - let sigma, hi = decompose_applied_relation env evars (c,l) in - let but = match clause with - | Some id -> pf_get_hyp_typ gl id - | None -> Evarutil.nf_evar evars (pf_concl gl) - in - unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env - -let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } - -(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) -(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) - -(** Setoid rewriting when called with "rewrite" *) -let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = - let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in - let unify env evars t = unify_abs res l2r sort env evars t in - let app = apply_rule unify occs in - let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in - let substrat = Strategies.fix recstrat in - let strat = { strategy = fun ({ state = () } as input) -> - let _, res = substrat.strategy { input with state = 0 } in - (), res - } - in - let origsigma = project gl in - init_setoid (); - try - tclWEAK_PROGRESS - (tclTHEN - (Refiner.tclEVARS evd) - (Proofview.V82.of_tactic - (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) gl - with RewriteFailure e -> - tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl - -let general_s_rewrite_clause x = - match x with - | None -> general_s_rewrite None - | Some id -> general_s_rewrite (Some id) - -let general_s_rewrite_clause x y z w ~new_goals = - Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals) - -let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite_clause - -(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) - -let not_declared env ty rel = - Tacticals.New.tclFAIL 0 - (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ - str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") - -let setoid_proof ty fn fallback = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl gl in - Proofview.tclORELSE - begin - try - let rel, _, _ = decompose_app_rel env sigma concl in - let open Context.Rel.Declaration in - let (sigma, t) = Typing.type_of env sigma rel in - let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in - (try init_relation_classes () with _ -> raise Not_found); - fn env sigma car rel - with e -> Proofview.tclZERO e - end - begin function - | e -> - Proofview.tclORELSE - fallback - begin function (e', info) -> match e' with - | Hipattern.NoEquationFound -> - begin match e with - | (Not_found, _) -> - let rel, _, _ = decompose_app_rel env sigma concl in - not_declared env ty rel - | (e, info) -> Proofview.tclZERO ~info e - end - | e' -> Proofview.tclZERO ~info e' - end - end - end } - -let tac_open ((evm,_), c) tac = - Proofview.V82.tactic - (tclTHEN (Refiner.tclEVARS evm) (tac c)) - -let poly_proof getp gett env evm car rel = - if Sorts.is_prop (sort_of_rel env evm rel) then - getp env (evm,Evar.Set.empty) car rel - else gett env (evm,Evar.Set.empty) car rel - -let setoid_reflexivity = - setoid_proof "reflexive" - (fun env evm car rel -> - tac_open (poly_proof PropGlobal.get_reflexive_proof - TypeGlobal.get_reflexive_proof - env evm car rel) - (fun c -> tclCOMPLETE (Proofview.V82.of_tactic (apply c)))) - (reflexivity_red true) - -let setoid_symmetry = - setoid_proof "symmetric" - (fun env evm car rel -> - tac_open - (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof - env evm car rel) - (fun c -> Proofview.V82.of_tactic (apply c))) - (symmetry_red true) - -let setoid_transitivity c = - setoid_proof "transitive" - (fun env evm car rel -> - tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof - env evm car rel) - (fun proof -> match c with - | None -> Proofview.V82.of_tactic (eapply proof) - | Some c -> Proofview.V82.of_tactic (apply_with_bindings (proof,ImplicitBindings [ c ])))) - (transitivity_red true c) - -let setoid_symmetry_in id = - Proofview.V82.tactic (fun gl -> - let ctype = pf_unsafe_type_of gl (mkVar id) in - let binders,concl = decompose_prod_assum ctype in - let (equiv, args) = decompose_app concl in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> let l,res = split_last_two (y::z) in x::l, res - | _ -> error "Cannot find an equivalence relation to rewrite." - in - let others,(c1,c2) = split_last_two args in - let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in - let new_hyp' = mkApp (he, [| c2 ; c1 |]) in - let new_hyp = it_mkProd_or_LetIn new_hyp' binders in - Proofview.V82.of_tactic - (Tacticals.New.tclTHENLAST - (Tactics.assert_after_replacing id new_hyp) - (Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) - gl) - -let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity -let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry -let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in -let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity - -let get_lemma_proof f env evm x y = - let (evm, _), c = f env (evm,Evar.Set.empty) x y in - evm, c - -let get_reflexive_proof = - get_lemma_proof PropGlobal.get_reflexive_proof - -let get_symmetric_proof = - get_lemma_proof PropGlobal.get_symmetric_proof - -let get_transitive_proof = - get_lemma_proof PropGlobal.get_transitive_proof - diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli deleted file mode 100644 index 01709f29fb..0000000000 --- a/tactics/rewrite.mli +++ /dev/null @@ -1,114 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* strategy - -val map_strategy : ('a -> 'b) -> ('c -> 'd) -> - ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast - -(** Entry point for user-level "rewrite_strat" *) -val cl_rewrite_clause_strat : strategy -> Id.t option -> tactic - -(** Entry point for user-level "setoid_rewrite" *) -val cl_rewrite_clause : - interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> - bool -> Locus.occurrences -> Id.t option -> tactic - -val is_applied_rewrite_relation : - env -> evar_map -> Context.Rel.t -> constr -> types option - -val declare_relation : - ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t -> - constr_expr option -> constr_expr option -> constr_expr option -> unit - -val add_setoid : - bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr -> - Id.t -> unit - -val add_morphism_infer : bool -> constr_expr -> Id.t -> unit - -val add_morphism : - bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit - -val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr - -val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr - -val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr - -val default_morphism : - (types * constr option) option list * (types * types option) option -> - constr -> constr * constr - -val setoid_symmetry : unit Proofview.tactic - -val setoid_symmetry_in : Id.t -> unit Proofview.tactic - -val setoid_reflexivity : unit Proofview.tactic - -val setoid_transitivity : constr option -> unit Proofview.tactic - - -val apply_strategy : - strategy -> - Environ.env -> - Names.Id.t list -> - Term.constr -> - bool * Term.constr -> - evars -> rewrite_result diff --git a/tactics/tacentries.ml b/tactics/tacentries.ml deleted file mode 100644 index 711cd8d9d0..0000000000 --- a/tactics/tacentries.ml +++ /dev/null @@ -1,263 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* GramTerminal s - | TacNonTerm (loc, nt, (_, sep)) -> - let EntryName (etyp, e) = interp_entry_name lev nt sep in - GramNonTerminal (loc, etyp, e) - -let make_terminal_status = function - | GramTerminal s -> Some s - | GramNonTerminal _ -> None - -let make_fresh_key = - let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in - fun () -> - let cur = incr id; !id in - let lbl = Id.of_string ("_" ^ string_of_int cur) in - let kn = Lib.make_kn lbl in - let (mp, dir, _) = KerName.repr kn in - (** We embed the full path of the kernel name in the label so that the - identifier should be unique. This ensures that including two modules - together won't confuse the corresponding labels. *) - let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" - (ModPath.to_string mp) (DirPath.to_string dir) cur) - in - KerName.make mp dir (Label.of_id lbl) - -type tactic_grammar_obj = { - tacobj_key : KerName.t; - tacobj_local : locality_flag; - tacobj_tacgram : tactic_grammar; - tacobj_tacpp : Pptactic.pp_tactic; - tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; -} - -let check_key key = - if Tacenv.check_alias key then - error "Conflicting tactic notations keys. This can happen when including \ - twice the same module." - -let cache_tactic_notation (_, tobj) = - let key = tobj.tacobj_key in - let () = check_key key in - Tacenv.register_alias key tobj.tacobj_body; - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram; - Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp - -let open_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram - -let load_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - let () = check_key key in - (** Only add the printing and interpretation rules. *) - Tacenv.register_alias key tobj.tacobj_body; - Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp; - if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram - -let subst_tactic_notation (subst, tobj) = - let (ids, body) = tobj.tacobj_body in - { tobj with - tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = (ids, Tacsubst.subst_tactic subst body); - } - -let classify_tactic_notation tacobj = Substitute tacobj - -let inTacticGrammar : tactic_grammar_obj -> obj = - declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; - load_function = load_tactic_notation; - cache_function = cache_tactic_notation; - subst_function = subst_tactic_notation; - classify_function = classify_tactic_notation} - -let cons_production_parameter = function -| TacTerm _ -> None -| TacNonTerm (_, _, (id, _)) -> Some id - -let add_tactic_notation (local,n,prods,e) = - let ids = List.map_filter cons_production_parameter prods in - let prods = List.map (interp_prod_item n) prods in - let pprule = { - Pptactic.pptac_level = n; - pptac_prods = prods; - } in - let tac = Tacintern.glob_tactic_env ids (Global.env()) e in - let parule = { - tacgram_level = n; - tacgram_prods = prods; - } in - let tacobj = { - tacobj_key = make_fresh_key (); - tacobj_local = local; - tacobj_tacgram = parule; - tacobj_tacpp = pprule; - tacobj_body = (ids, tac); - } in - Lib.add_anonymous_leaf (inTacticGrammar tacobj) - -(**********************************************************************) -(* ML Tactic entries *) - -type ml_tactic_grammar_obj = { - mltacobj_name : Tacexpr.ml_tactic_name; - (** ML-side unique name *) - mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list; - (** Grammar rules generating the ML tactic. *) -} - -exception NonEmptyArgument - -(** ML tactic notations whose use can be restricted to an identifier are added - as true Ltac entries. *) -let extend_atomic_tactic name entries = - let open Tacexpr in - let map_prod prods = - let (hd, rem) = match prods with - | GramTerminal s :: rem -> (s, rem) - | _ -> assert false (** Not handled by the ML extension syntax *) - in - let empty_value = function - | GramTerminal s -> raise NonEmptyArgument - | GramNonTerminal (_, typ, e) -> - let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in - let default = epsilon_value inj e in - match default with - | None -> raise NonEmptyArgument - | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def - in - try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None - in - let entries = List.map map_prod entries in - let add_atomic i args = match args with - | None -> () - | Some (id, args) -> - let args = List.map (fun a -> Tacexp a) args in - let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.ghost, entry, args) in - Tacenv.register_ltac false false (Names.Id.of_string id) body - in - List.iteri add_atomic entries - -let cache_ml_tactic_notation (_, obj) = - extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod - -let open_ml_tactic_notation i obj = - if Int.equal i 1 then cache_ml_tactic_notation obj - -let inMLTacticGrammar : ml_tactic_grammar_obj -> obj = - declare_object { (default_object "MLTacticGrammar") with - open_function = open_ml_tactic_notation; - cache_function = cache_ml_tactic_notation; - classify_function = (fun o -> Substitute o); - subst_function = (fun (_, o) -> o); - } - -let add_ml_tactic_notation name prods = - let obj = { - mltacobj_name = name; - mltacobj_prod = prods; - } in - Lib.add_anonymous_leaf (inMLTacticGrammar obj); - extend_atomic_tactic name prods - -(** Command *) - - -type tacdef_kind = - | NewTac of Id.t - | UpdateTac of Nametab.ltac_constant - -let is_defined_tac kn = - try ignore (Tacenv.interp_ltac kn); true with Not_found -> false - -let register_ltac local tacl = - let map tactic_body = - match tactic_body with - | TacticDefinition ((loc,id), body) -> - let kn = Lib.make_kn id in - let id_pp = pr_id id in - let () = if is_defined_tac kn then - Errors.user_err_loc (loc, "", - str "There is already an Ltac named " ++ id_pp ++ str".") - in - let is_primitive = - try - match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with - | Tacexpr.TacArg _ -> false - | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) - with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) - in - let () = if is_primitive then - msg_warning (str "The Ltac name " ++ id_pp ++ - str " may be unusable because of a conflict with a notation.") - in - NewTac id, body - | TacticRedefinition (ident, body) -> - let loc = loc_of_reference ident in - let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) - with Not_found -> - Errors.user_err_loc (loc, "", - str "There is no Ltac named " ++ pr_reference ident ++ str ".") - in - UpdateTac kn, body - in - let rfun = List.map map tacl in - let recvars = - let fold accu (op, _) = match op with - | UpdateTac _ -> accu - | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu - in - List.fold_left fold [] rfun - in - let ist = Tacintern.make_empty_glob_sign () in - let map (name, body) = - let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in - (name, body) - in - let defs () = - (** Register locally the tactic to handle recursivity. This function affects - the whole environment, so that we transactify it afterwards. *) - let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in - let () = List.iter iter_rec recvars in - List.map map rfun - in - let defs = Future.transactify defs () in - let iter (def, tac) = match def with - | NewTac id -> - Tacenv.register_ltac false local id tac; - Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined") - | UpdateTac kn -> - Tacenv.redefine_ltac local kn tac; - let name = Nametab.shortest_qualid_of_tactic kn in - Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined") - in - List.iter iter defs diff --git a/tactics/tacentries.mli b/tactics/tacentries.mli deleted file mode 100644 index 3cf0bc5cc9..0000000000 --- a/tactics/tacentries.mli +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - unit - -val add_ml_tactic_notation : ml_tactic_name -> - Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit - -val register_ltac : bool -> Vernacexpr.tacdef_body list -> unit diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml deleted file mode 100644 index d2d3f3117f..0000000000 --- a/tactics/tacenv.ml +++ /dev/null @@ -1,145 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Errors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) - -let check_alias key = KNmap.mem key !alias_map - -(** ML tactic extensions (TacML) *) - -type ml_tactic = - Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic - -module MLName = -struct - type t = ml_tactic_name - let compare tac1 tac2 = - let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in - if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin - else c -end - -module MLTacMap = Map.Make(MLName) - -let pr_tacname t = - str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic - -let tac_tab = ref MLTacMap.empty - -let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) = - let () = - if MLTacMap.mem s !tac_tab then - if overwrite then - let () = tac_tab := MLTacMap.remove s !tac_tab in - msg_warning (str "Overwriting definition of tactic " ++ pr_tacname s) - else - Errors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") - in - tac_tab := MLTacMap.add s t !tac_tab - -let interp_ml_tactic { mltac_name = s; mltac_index = i } = - try - let tacs = MLTacMap.find s !tac_tab in - let () = if Array.length tacs <= i then raise Not_found in - tacs.(i) - with Not_found -> - Errors.errorlabstrm "" - (str "The tactic " ++ pr_tacname s ++ str " is not installed.") - -(***************************************************************************) -(* Tactic registration *) - -(* Summary and Object declaration *) - -open Nametab -open Libobject - -type ltac_entry = { - tac_for_ml : bool; - tac_body : glob_tactic_expr; - tac_redef : ModPath.t list; -} - -let mactab = - Summary.ref (KNmap.empty : ltac_entry KNmap.t) - ~name:"tactic-definition" - -let ltac_entries () = !mactab - -let interp_ltac r = (KNmap.find r !mactab).tac_body - -let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml - -let add kn b t = - let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in - mactab := KNmap.add kn entry !mactab - -let replace kn path t = - let (path, _, _) = KerName.repr path in - let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in - mactab := KNmap.modify kn entry !mactab - -let load_md i ((sp, kn), (local, id, b, t)) = match id with -| None -> - let () = if not local then Nametab.push_tactic (Until i) sp kn in - add kn b t -| Some kn0 -> replace kn0 kn t - -let open_md i ((sp, kn), (local, id, b, t)) = match id with -| None -> - let () = if not local then Nametab.push_tactic (Exactly i) sp kn in - add kn b t -| Some kn0 -> replace kn0 kn t - -let cache_md ((sp, kn), (local, id ,b, t)) = match id with -| None -> - let () = Nametab.push_tactic (Until 1) sp kn in - add kn b t -| Some kn0 -> replace kn0 kn t - -let subst_kind subst id = match id with -| None -> None -| Some kn -> Some (Mod_subst.subst_kn subst kn) - -let subst_md (subst, (local, id, b, t)) = - (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t) - -let classify_md (local, _, _, _ as o) = Substitute o - -let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = - declare_object {(default_object "TAC-DEFINITION") with - cache_function = cache_md; - load_function = load_md; - open_function = open_md; - subst_function = subst_md; - classify_function = classify_md} - -let register_ltac for_ml local id tac = - ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac))) - -let redefine_ltac local kn tac = - Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli deleted file mode 100644 index 88b54993b1..0000000000 --- a/tactics/tacenv.mli +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* alias_tactic -> unit -(** Register a tactic alias. *) - -val interp_alias : alias -> alias_tactic -(** Recover the the body of an alias. Raises an anomaly if it does not exist. *) - -val check_alias : alias -> bool -(** Returns [true] if an alias is defined, false otherwise. *) - -(** {5 Coq tactic definitions} *) - -val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit -(** Register a new Ltac with the given name and body. - - The first boolean indicates whether this is done from ML side, rather than - Coq side. If the second boolean flag is set to true, then this is a local - definition. It also puts the Ltac name in the nametab, so that it can be - used unqualified. *) - -val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit -(** Replace a Ltac with the given name and body. If the boolean flag is set - to true, then this is a local redefinition. *) - -val interp_ltac : KerName.t -> glob_tactic_expr -(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *) - -val is_ltac_for_ml_tactic : KerName.t -> bool -(** Whether the tactic is defined from ML-side *) - -type ltac_entry = { - tac_for_ml : bool; - (** Whether the tactic is defined from ML-side *) - tac_body : glob_tactic_expr; - (** The current body of the tactic *) - tac_redef : ModPath.t list; - (** List of modules redefining the tactic in reverse chronological order *) -} - -val ltac_entries : unit -> ltac_entry KNmap.t -(** Low-level access to all Ltac entries currently defined. *) - -(** {5 ML tactic extensions} *) - -type ml_tactic = - Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic -(** Type of external tactics, used by [TacML]. *) - -val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit -(** Register an external tactic. *) - -val interp_ml_tactic : ml_tactic_entry -> ml_tactic -(** Get the named tactic. Raises a user error if it does not exist. *) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml deleted file mode 100644 index a75805b4f8..0000000000 --- a/tactics/tacintern.ml +++ /dev/null @@ -1,821 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Anonymous - | Name id -> Name (intern_ident l ist id) - -let strict_check = ref false - -let adjust_loc loc = if !strict_check then dloc else loc - -(* Globalize a name which must be bound -- actually just check it is bound *) -let intern_hyp ist (loc,id as locid) = - if not !strict_check then - locid - else if find_ident id ist then - (dloc,id) - else - Pretype_errors.error_var_not_found_loc loc id - -let intern_or_var f ist = function - | ArgVar locid -> ArgVar (intern_hyp ist locid) - | ArgArg x -> ArgArg (f x) - -let intern_int_or_var = intern_or_var (fun (n : int) -> n) -let intern_string_or_var = intern_or_var (fun (s : string) -> s) - -let intern_global_reference ist = function - | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) - | r -> - let loc,_ as lqid = qualid_of_reference r in - try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found_loc lqid - -let intern_ltac_variable ist = function - | Ident (loc,id) -> - if find_var id ist then - (* A local variable of any type *) - ArgVar (loc,id) - else raise Not_found - | _ -> - raise Not_found - -let intern_constr_reference strict ist = function - | Ident (_,id) as r when not strict && find_hyp id ist -> - GVar (dloc,id), Some (CRef (r,None)) - | Ident (_,id) as r when find_var id ist -> - GVar (dloc,id), if strict then None else Some (CRef (r,None)) - | r -> - let loc,_ as lqid = qualid_of_reference r in - GRef (loc,locate_global_with_alias lqid,None), - if strict then None else Some (CRef (r,None)) - -let intern_move_location ist = function - | MoveAfter id -> MoveAfter (intern_hyp ist id) - | MoveBefore id -> MoveBefore (intern_hyp ist id) - | MoveFirst -> MoveFirst - | MoveLast -> MoveLast - -(* Internalize an isolated reference in position of tactic *) - -let intern_isolated_global_tactic_reference r = - let (loc,qid) = qualid_of_reference r in - TacCall (loc,ArgArg (loc,locate_tactic qid),[]) - -let intern_isolated_tactic_reference strict ist r = - (* An ltac reference *) - try Reference (intern_ltac_variable ist r) - with Not_found -> - (* A global tactic *) - try intern_isolated_global_tactic_reference r - with Not_found -> - (* Tolerance for compatibility, allow not to use "constr:" *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) - with Not_found -> - (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) - -(* Internalize an applied tactic reference *) - -let intern_applied_global_tactic_reference r = - let (loc,qid) = qualid_of_reference r in - ArgArg (loc,locate_tactic qid) - -let intern_applied_tactic_reference ist r = - (* An ltac reference *) - try intern_ltac_variable ist r - with Not_found -> - (* A global tactic *) - try intern_applied_global_tactic_reference r - with Not_found -> - (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) - -(* Intern a reference parsed in a non-tactic entry *) - -let intern_non_tactic_reference strict ist r = - (* An ltac reference *) - try Reference (intern_ltac_variable ist r) - with Not_found -> - (* A constr reference *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) - with Not_found -> - (* Tolerance for compatibility, allow not to use "ltac:" *) - try intern_isolated_global_tactic_reference r - with Not_found -> - (* By convention, use IntroIdentifier for unbound ident, when not in a def *) - match r with - | Ident (loc,id) when not strict -> - let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in - TacGeneric ipat - | _ -> - (* Reference not found *) - error_global_not_found_loc (qualid_of_reference r) - -let intern_message_token ist = function - | (MsgString _ | MsgInt _ as x) -> x - | MsgIdent id -> MsgIdent (intern_hyp ist id) - -let intern_message ist = List.map (intern_message_token ist) - -let intern_quantified_hypothesis ist = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - (* Uncomment to disallow "intros until n" in ltac when n is not bound *) - NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) - -let intern_binding_name ist x = - (* We use identifier both for variables and binding names *) - (* Todo: consider the body of the lemma to which the binding refer - and if a term w/o ltac vars, check the name is indeed quantified *) - x - -let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c = - let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in - let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in - let ltacvars = { - Constrintern.ltac_vars = lfun; - ltac_bound = Id.Set.empty; - } in - let c' = - warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c - in - (c',if !strict_check then None else Some c) - -let intern_constr = intern_constr_gen false false -let intern_type = intern_constr_gen false true - -(* Globalize bindings *) -let intern_binding ist (loc,b,c) = - (loc,intern_binding_name ist b,intern_constr ist c) - -let intern_bindings ist = function - | NoBindings -> NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l) - | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l) - -let intern_constr_with_bindings ist (c,bl) = - (intern_constr ist c, intern_bindings ist bl) - -let intern_constr_with_bindings_arg ist (clear,c) = - (clear,intern_constr_with_bindings ist c) - -let rec intern_intro_pattern lf ist = function - | loc, IntroNaming pat -> - loc, IntroNaming (intern_intro_pattern_naming lf ist pat) - | loc, IntroAction pat -> - loc, IntroAction (intern_intro_pattern_action lf ist pat) - | loc, IntroForthcoming _ as x -> x - -and intern_intro_pattern_naming lf ist = function - | IntroIdentifier id -> - IntroIdentifier (intern_ident lf ist id) - | IntroFresh id -> - IntroFresh (intern_ident lf ist id) - | IntroAnonymous as x -> x - -and intern_intro_pattern_action lf ist = function - | IntroOrAndPattern l -> - IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) - | IntroInjection l -> - IntroInjection (List.map (intern_intro_pattern lf ist) l) - | IntroWildcard | IntroRewrite _ as x -> x - | IntroApplyOn (c,pat) -> - IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) - -and intern_or_and_intro_pattern lf ist = function - | IntroAndPattern l -> - IntroAndPattern (List.map (intern_intro_pattern lf ist) l) - | IntroOrPattern ll -> - IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) - -let intern_or_and_intro_pattern_loc lf ist = function - | ArgVar (_,id) as x -> - if find_var id ist then x - else error "Disjunctive/conjunctive introduction pattern expected." - | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) - -let intern_intro_pattern_naming_loc lf ist (loc,pat) = - (loc,intern_intro_pattern_naming lf ist pat) - - (* TODO: catch ltac vars *) -let intern_induction_arg ist = function - | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c) - | clear,ElimOnAnonHyp n as x -> x - | clear,ElimOnIdent (loc,id) -> - if !strict_check then - (* If in a defined tactic, no intros-until *) - match intern_constr ist (CRef (Ident (dloc,id), None)) with - | GVar (loc,id),_ -> clear,ElimOnIdent (loc,id) - | c -> clear,ElimOnConstr (c,NoBindings) - else - clear,ElimOnIdent (loc,id) - -let short_name = function - | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id) - | _ -> None - -let intern_evaluable_global_reference ist r = - let lqid = qualid_of_reference r in - try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) - with Not_found -> - match r with - | Ident (loc,id) when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found_loc lqid - -let intern_evaluable_reference_or_by_notation ist = function - | AN r -> intern_evaluable_global_reference ist r - | ByNotation (loc,ntn,sc) -> - evaluable_of_global_reference ist.genv - (Notation.interp_notation_as_global_reference loc - (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) - -(* Globalize a reduction expression *) -let intern_evaluable ist = function - | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) - | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist -> - ArgArg (EvalVarRef id, Some (loc,id)) - | r -> - let e = intern_evaluable_reference_or_by_notation ist r in - let na = short_name r in - ArgArg (e,na) - -let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) - -let intern_flag ist red = - { red with rConst = List.map (intern_evaluable ist) red.rConst } - -let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c) - -let intern_constr_pattern ist ~as_type ~ltacvars pc = - let ltacvars = { - Constrintern.ltac_vars = ltacvars; - ltac_bound = Id.Set.empty; - } in - let metas,pat = Constrintern.intern_constr_pattern - ist.genv ~as_type ~ltacvars pc - in - let c = intern_constr_gen true false ist pc in - metas,(c,pat) - -let dummy_pat = PRel 0 - -let intern_typed_pattern ist p = - (* we cannot ensure in non strict mode that the pattern is closed *) - (* keeping a constr_expr copy is too complicated and we want anyway to *) - (* type it, so we remember the pattern as a glob_constr only *) - (intern_constr_gen true false ist p,dummy_pat) - -let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = - let interp_ref r = - try Inl (intern_evaluable ist r) - with e when Logic.catchable_exception e -> - (* Compatibility. In practice, this means that the code above - is useless. Still the idea of having either an evaluable - ref or a pattern seems interesting, with "head" reduction - in case of an evaluable ref, and "strong" reduction in the - subterm matched when a pattern *) - let loc = loc_of_smart_reference r in - let r = match r with - | AN r -> r - | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in - let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in - let c = Constrintern.interp_reference sign r in - match c with - | GRef (_,r,None) -> - Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) - | GVar (_,id) -> - let r = evaluable_of_global_reference ist.genv (VarRef id) in - Inl (ArgArg (r,None)) - | _ -> - Inr ((c,None),dummy_pat) in - (l, match p with - | Inl r -> interp_ref r - | Inr (CAppExpl(_,(None,r,None),[])) -> - (* We interpret similarly @ref and ref *) - interp_ref (AN r) - | Inr c -> - Inr (intern_typed_pattern ist c)) - -(* This seems fairly hacky, but it's the first way I've found to get proper - globalization of [unfold]. --adamc *) -let dump_glob_red_expr = function - | Unfold occs -> List.iter (fun (_, r) -> - try - Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) - (Smartlocate.smart_global r) - with e when Errors.noncritical e -> ()) occs - | Cbv grf | Lazy grf -> - List.iter (fun r -> - try - Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) - (Smartlocate.smart_global r) - with e when Errors.noncritical e -> ()) grf.rConst - | _ -> () - -let intern_red_expr ist = function - | Unfold l -> Unfold (List.map (intern_unfold ist) l) - | Fold l -> Fold (List.map (intern_constr ist) l) - | Cbv f -> Cbv (intern_flag ist f) - | Cbn f -> Cbn (intern_flag ist f) - | Lazy f -> Lazy (intern_flag ist f) - | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) - | Simpl (f,o) -> - Simpl (intern_flag ist f, - Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) - | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) - | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) - | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r - -let intern_in_hyp_as ist lf (id,ipat) = - (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) - -let intern_hyp_list ist = List.map (intern_hyp ist) - -let intern_inversion_strength lf ist = function - | NonDepInversion (k,idl,ids) -> - NonDepInversion (k,intern_hyp_list ist idl, - Option.map (intern_or_and_intro_pattern_loc lf ist) ids) - | DepInversion (k,copt,ids) -> - DepInversion (k, Option.map (intern_constr ist) copt, - Option.map (intern_or_and_intro_pattern_loc lf ist) ids) - | InversionUsing (c,idl) -> - InversionUsing (intern_constr ist c, intern_hyp_list ist idl) - -(* Interprets an hypothesis name *) -let intern_hyp_location ist ((occs,id),hl) = - ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs, - intern_hyp ist id), hl) - -(* Reads a pattern *) -let intern_pattern ist ?(as_type=false) ltacvars = function - | Subterm (b,ido,pc) -> - let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in - ido, metas, Subterm (b,ido,pc) - | Term pc -> - let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in - None, metas, Term pc - -let intern_constr_may_eval ist = function - | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) - | ConstrContext (locid,c) -> - ConstrContext (intern_hyp ist locid,intern_constr ist c) - | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) - | ConstrTerm c -> ConstrTerm (intern_constr ist c) - -let name_cons accu = function -| Anonymous -> accu -| Name id -> Id.Set.add id accu - -let opt_cons accu = function -| None -> accu -| Some id -> Id.Set.add id accu - -(* Reads the hypotheses of a "match goal" rule *) -let rec intern_match_goal_hyps ist lfun = function - | (Hyp ((_,na) as locna,mp))::tl -> - let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in - let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in - let lfun' = name_cons (opt_cons lfun ido) na in - lfun', metas1@metas2, Hyp (locna,pat)::hyps - | (Def ((_,na) as locna,mv,mp))::tl -> - let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in - let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in - let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in - let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in - lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps - | [] -> lfun, [], [] - -(* Utilities *) -let extract_let_names lrc = - let fold accu ((loc, name), _) = - if Id.Set.mem name accu then user_err_loc - (loc, "glob_tactic", str "This variable is bound several times.") - else Id.Set.add name accu - in - List.fold_left fold Id.Set.empty lrc - -let clause_app f = function - { onhyps=None; concl_occs=nl } -> - { onhyps=None; concl_occs=nl } - | { onhyps=Some l; concl_occs=nl } -> - { onhyps=Some(List.map f l); concl_occs=nl} - -let map_raw wit f ist x = - in_gen (glbwit wit) (f ist (out_gen (rawwit wit) x)) - -(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) -let rec intern_atomic lf ist x = - match (x:raw_atomic_tactic_expr) with - (* Basic tactics *) - | TacIntroPattern l -> - TacIntroPattern (List.map (intern_intro_pattern lf ist) l) - | TacIntroMove (ido,hto) -> - TacIntroMove (Option.map (intern_ident lf ist) ido, - intern_move_location ist hto) - | TacExact c -> TacExact (intern_constr ist c) - | TacApply (a,ev,cb,inhyp) -> - TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, - Option.map (intern_in_hyp_as ist lf) inhyp) - | TacElim (ev,cb,cbo) -> - TacElim (ev,intern_constr_with_bindings_arg ist cb, - Option.map (intern_constr_with_bindings ist) cbo) - | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) - | TacMutualFix (id,n,l) -> - let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in - TacMutualFix (intern_ident lf ist id, n, List.map f l) - | TacMutualCofix (id,l) -> - let f (id,c) = (intern_ident lf ist id,intern_type ist c) in - TacMutualCofix (intern_ident lf ist id, List.map f l) - | TacAssert (b,otac,ipat,c) -> - TacAssert (b,Option.map (intern_pure_tactic ist) otac, - Option.map (intern_intro_pattern lf ist) ipat, - intern_constr_gen false (not (Option.is_empty otac)) ist c) - | TacGeneralize cl -> - TacGeneralize (List.map (fun (c,na) -> - intern_constr_with_occurrences ist c, - intern_name lf ist na) cl) - | TacLetTac (na,c,cls,b,eqpat) -> - let na = intern_name lf ist na in - TacLetTac (na,intern_constr ist c, - (clause_app (intern_hyp_location ist) cls),b, - (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) - - (* Derived basic tactics *) - | TacInductionDestruct (ev,isrec,(l,el)) -> - TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> - (intern_induction_arg ist c, - (Option.map (intern_intro_pattern_naming_loc lf ist) ipato, - Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), - Option.map (clause_app (intern_hyp_location ist)) cls)) l, - Option.map (intern_constr_with_bindings ist) el)) - | TacDoubleInduction (h1,h2) -> - let h1 = intern_quantified_hypothesis ist h1 in - let h2 = intern_quantified_hypothesis ist h2 in - TacDoubleInduction (h1,h2) - (* Context management *) - | TacRename l -> - TacRename (List.map (fun (id1,id2) -> - intern_hyp ist id1, - intern_hyp ist id2) l) - - (* Conversion *) - | TacReduce (r,cl) -> - dump_glob_red_expr r; - TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) - | TacChange (None,c,cl) -> - let is_onhyps = match cl.onhyps with - | None | Some [] -> true - | _ -> false - in - let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true - | _ -> false - in - TacChange (None, - (if is_onhyps && is_onconcl - then intern_type ist c else intern_constr ist c), - clause_app (intern_hyp_location ist) cl) - | TacChange (Some p,c,cl) -> - TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, - clause_app (intern_hyp_location ist) cl) - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite - (ev, - List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, - clause_app (intern_hyp_location ist) cl, - Option.map (intern_pure_tactic ist) by) - | TacInversion (inv,hyp) -> - TacInversion (intern_inversion_strength lf ist inv, - intern_quantified_hypothesis ist hyp) - -and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) - -and intern_tactic_seq onlytac ist = function - | TacAtom (loc,t) -> - let lf = ref ist.ltacvars in - let t = intern_atomic lf ist t in - !lf, TacAtom (adjust_loc loc, t) - | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) - | TacLetIn (isrec,l,u) -> - let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in - let ist' = { ist with ltacvars } in - let l = List.map (fun (n,b) -> - (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in - ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) - - | TacMatchGoal (lz,lr,lmr) -> - ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr) - | TacMatch (lz,c,lmr) -> - ist.ltacvars, - TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) - | TacId l -> ist.ltacvars, TacId (intern_message ist l) - | TacFail (g,n,l) -> - ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l) - | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac) - | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac) - | TacAbstract (tac,s) -> - ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s) - | TacThen (t1,t2) -> - let lfun', t1 = intern_tactic_seq onlytac ist t1 in - let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in - lfun'', TacThen (t1,t2) - | TacDispatch tl -> - ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl) - | TacExtendTac (tf,t,tl) -> - ist.ltacvars , - TacExtendTac (Array.map (intern_pure_tactic ist) tf, - intern_pure_tactic ist t, - Array.map (intern_pure_tactic ist) tl) - | TacThens3parts (t1,tf,t2,tl) -> - let lfun', t1 = intern_tactic_seq onlytac ist t1 in - let ist' = { ist with ltacvars = lfun' } in - (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) - lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, - Array.map (intern_pure_tactic ist') tl) - | TacThens (t,tl) -> - let lfun', t = intern_tactic_seq true ist t in - let ist' = { ist with ltacvars = lfun' } in - (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) - lfun', TacThens (t, List.map (intern_pure_tactic ist') tl) - | TacDo (n,tac) -> - ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac) - | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac) - | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac) - | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac) - | TacTimeout (n,tac) -> - ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac) - | TacTime (s,tac) -> - ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac) - | TacOr (tac1,tac2) -> - ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) - | TacOnce tac -> - ist.ltacvars, TacOnce (intern_pure_tactic ist tac) - | TacExactlyOnce tac -> - ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac) - | TacIfThenCatch (tac,tact,tace) -> - ist.ltacvars, - TacIfThenCatch ( - intern_pure_tactic ist tac, - intern_pure_tactic ist tact, - intern_pure_tactic ist tace) - | TacOrelse (tac1,tac2) -> - ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) - | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) - | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) - | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) - | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a - - (* For extensions *) - | TacAlias (loc,s,l) -> - let l = List.map (intern_tacarg !strict_check false ist) l in - ist.ltacvars, TacAlias (loc,s,l) - | TacML (loc,opn,l) -> - let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) - -and intern_tactic_as_arg loc onlytac ist a = - match intern_tacarg !strict_check onlytac ist a with - | TacCall _ | Reference _ - | TacGeneric _ as a -> TacArg (loc,a) - | Tacexp a -> a - | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected loc else TacArg (loc,a) - -and intern_tactic_or_tacarg ist = intern_tactic false ist - -and intern_pure_tactic ist = intern_tactic true ist - -and intern_tactic_fun ist (var,body) = - let lfun = List.fold_left opt_cons ist.ltacvars var in - (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) - -and intern_tacarg strict onlytac ist = function - | Reference r -> intern_non_tactic_reference strict ist r - | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f - | TacCall (loc,f,l) -> - TacCall (loc, - intern_applied_tactic_reference ist f, - List.map (intern_tacarg !strict_check false ist) l) - | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) - | TacPretype c -> TacPretype (intern_constr ist c) - | TacNumgoals -> TacNumgoals - | Tacexp t -> Tacexp (intern_tactic onlytac ist t) - | TacGeneric arg -> - let arg = intern_genarg ist arg in - TacGeneric arg - -(* Reads the rules of a Match Context or a Match *) -and intern_match_rule onlytac ist = function - | (All tc)::tl -> - All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl) - | (Pat (rl,mp,tc))::tl -> - let {ltacvars=lfun; genv=env} = ist in - let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in - let ido,metas2,pat = intern_pattern ist lfun mp in - let fold accu x = Id.Set.add x accu in - let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in - let ltacvars = List.fold_left fold ltacvars metas2 in - let ist' = { ist with ltacvars } in - Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl) - | [] -> [] - -and intern_genarg ist (GenArg (Rawwit wit, x)) = - match wit with - | ListArg wit -> - let map x = - let ans = intern_genarg ist (in_gen (rawwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map x) - | OptArg wit -> - let ans = match x with - | None -> in_gen (glbwit (wit_opt wit)) None - | Some x -> - let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in - in_gen (glbwit (wit_opt wit)) (Some s) - in - ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in - let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - | ExtraArg s -> - snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) - -(** Other entry points *) - -let glob_tactic x = - Flags.with_option strict_check - (intern_pure_tactic (make_empty_glob_sign ())) x - -let glob_tactic_env l env x = - let ltacvars = - List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in - Flags.with_option strict_check - (intern_pure_tactic - { ltacvars; genv = env }) - x - -let split_ltac_fun = function - | TacFun (l,t) -> (l,t) - | t -> ([],t) - -let pr_ltac_fun_arg = function - | None -> spc () ++ str "_" - | Some id -> spc () ++ pr_id id - -let print_ltac id = - try - let kn = Nametab.locate_tactic id in - let entries = Tacenv.ltac_entries () in - let tac = KNmap.find kn entries in - let filter mp = - try Some (Nametab.shortest_qualid_of_module mp) - with Not_found -> None - in - let mods = List.map_filter filter tac.Tacenv.tac_redef in - let redefined = match mods with - | [] -> mt () - | mods -> - let redef = prlist_with_sep fnl pr_qualid mods in - fnl () ++ str "Redefined by:" ++ fnl () ++ redef - in - let l,t = split_ltac_fun tac.Tacenv.tac_body in - hv 2 ( - hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ - prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") - ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined - with - Not_found -> - errorlabstrm "print_ltac" - (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") - -(** Registering *) - -let lift intern = (); fun ist x -> (ist, intern ist x) - -let () = - let intern_intro_pattern ist pat = - let lf = ref Id.Set.empty in - let ans = intern_intro_pattern lf ist pat in - let ist = { ist with ltacvars = !lf } in - (ist, ans) - in - Genintern.register_intern0 wit_intro_pattern intern_intro_pattern - -let () = - let intern_clause ist cl = - let ans = clause_app (intern_hyp_location ist) cl in - (ist, ans) - in - Genintern.register_intern0 wit_clause_dft_concl intern_clause - -let intern_ident' ist id = - let lf = ref Id.Set.empty in - (ist, intern_ident lf ist id) - -let () = - Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); - Genintern.register_intern0 wit_ref (lift intern_global_reference); - Genintern.register_intern0 wit_ident intern_ident'; - Genintern.register_intern0 wit_var (lift intern_hyp); - Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); - Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg); - Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); - Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); - Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); - Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); - Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); - Genintern.register_intern0 wit_red_expr (lift intern_red_expr); - Genintern.register_intern0 wit_bindings (lift intern_bindings); - Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); - Genintern.register_intern0 wit_constr_may_eval (lift intern_constr_may_eval); - () - -(***************************************************************************) -(* Backwarding recursive needs of tactic glob/interp/eval functions *) - -let _ = - let f l = - let ltacvars = - List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l - in - Flags.with_option strict_check - (intern_pure_tactic { (make_empty_glob_sign()) with ltacvars }) - in - Hook.set Hints.extern_intern_tac f diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli deleted file mode 100644 index 71ca354fa1..0000000000 --- a/tactics/tacintern.mli +++ /dev/null @@ -1,64 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glob_sign - (** same as [fully_empty_glob_sign], but with [Global.env()] as - environment *) - -(** Main globalization functions *) - -val glob_tactic : raw_tactic_expr -> glob_tactic_expr - -val glob_tactic_env : - Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr - -(** Low-level variants *) - -val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr - -val intern_tactic_or_tacarg : - glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr - -val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr - -val intern_constr_with_bindings : - glob_sign -> constr_expr * constr_expr bindings -> - glob_constr_and_expr * glob_constr_and_expr bindings - -val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located - -(** Adds a globalization function for extra generic arguments *) - -val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument - -(** printing *) -val print_ltac : Libnames.qualid -> std_ppcmds - -(** Reduction expressions *) - -val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr -val dump_glob_red_expr : raw_red_expr -> unit - -(* Hooks *) -val strict_check : bool ref diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml deleted file mode 100644 index 4506f81596..0000000000 --- a/tactics/tacinterp.ml +++ /dev/null @@ -1,2216 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* a typed_abstract_argument_type -> bool = fun v wit -> - let Val.Dyn (t, _) = v in - match Val.eq t (val_tag wit) with - | None -> false - | Some Refl -> true - -let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> None - | Some Refl -> Some x - -let in_gen wit v = Val.Dyn (val_tag wit, v) -let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x - -let val_tag wit = val_tag (topwit wit) - -let pr_argument_type arg = - let Val.Dyn (tag, _) = arg in - Val.repr tag - -let safe_msgnl s = - Proofview.NonLogical.catch - (Proofview.NonLogical.print_debug (s++fnl())) - (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) - -type value = Val.t - -(** Abstract application, to print ltac functions *) -type appl = - | UnnamedAppl (** For generic applications: nothing is printed *) - | GlbAppl of (Names.kernel_name * Val.t list) list - (** For calls to global constants, some may alias other. *) -let push_appl appl args = - match appl with - | UnnamedAppl -> UnnamedAppl - | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) -let pr_generic arg = (** FIXME *) - let Val.Dyn (tag, _) = arg in - str"<" ++ Val.repr tag ++ str ">" -let pr_appl h vs = - Pptactic.pr_ltac_constant h ++ spc () ++ - Pp.prlist_with_sep spc pr_generic vs -let rec name_with_list appl t = - match appl with - | [] -> t - | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) -let name_if_glob appl t = - match appl with - | UnnamedAppl -> t - | GlbAppl l -> name_with_list l t -let combine_appl appl1 appl2 = - match appl1,appl2 with - | UnnamedAppl,a | a,UnnamedAppl -> a - | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1) - -(* Values for interpretation *) -type tacvalue = - | VFun of appl*ltac_trace * value Id.Map.t * - Id.t option list * glob_tactic_expr - | VRec of value Id.Map.t ref * glob_tactic_expr - -let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = - Genarg.create_arg "tacvalue" - -let of_tacvalue v = in_gen (topwit wit_tacvalue) v -let to_tacvalue v = out_gen (topwit wit_tacvalue) v - -(** More naming applications *) -let name_vfun appl vle = - let vle = Value.normalize vle in - if has_type vle (topwit wit_tacvalue) then - match to_tacvalue vle with - | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) - | _ -> vle - else vle - -module TacStore = Geninterp.TacStore - -let f_avoid_ids : Id.t list TacStore.field = TacStore.field () -(* ids inherited from the call context (needed to get fresh ids) *) -let f_debug : debug_info TacStore.field = TacStore.field () -let f_trace : ltac_trace TacStore.field = TacStore.field () - -(* Signature for interpretation: val_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } - -let extract_trace ist = match TacStore.get ist.extra f_trace with -| None -> [] -| Some l -> l - -module Value = struct - - include Taccoerce.Value - - let of_closure ist tac = - let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - of_tacvalue closure - - let cast_error wit v = - let pr_v = mt () in (** FIXME *) - let Val.Dyn (tag, _) = v in - let tag = Val.repr tag in - errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ tag - ++ str " while type " ++ Genarg.pr_argument_type (unquote (rawwit wit)) ++ str " was expected.") - - let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> - let Val.Dyn (t', x) = v in - match Val.eq t t' with - | None -> None - | Some Refl -> Some x - - let try_prj wit v = match prj (val_tag wit) v with - | None -> cast_error wit v - | Some x -> x - - let rec val_cast : type a b c. (a, b, c) genarg_type -> Val.t -> c = - fun wit v -> match wit with - | ExtraArg _ -> try_prj wit v - | ListArg t -> - let Val.Dyn (tag, v) = v in - begin match tag with - | Val.List tag -> - let map x = val_cast t (Val.Dyn (tag, x)) in - List.map map v - | _ -> cast_error wit (Val.Dyn (tag, v)) - end - | OptArg t -> - let Val.Dyn (tag, v) = v in - begin match tag with - | Val.Opt tag -> - let map x = val_cast t (Val.Dyn (tag, x)) in - Option.map map v - | _ -> cast_error wit (Val.Dyn (tag, v)) - end - | PairArg (t1, t2) -> - let Val.Dyn (tag, v) = v in - begin match tag with - | Val.Pair (tag1, tag2) -> - let (v1, v2) = v in - let v1 = Val.Dyn (tag1, v1) in - let v2 = Val.Dyn (tag2, v2) in - (val_cast t1 v1, val_cast t2 v2) - | _ -> cast_error wit (Val.Dyn (tag, v)) - end - - let cast (Topwit wit) v = val_cast wit v - -end - -let print_top_val env v = mt () (** FIXME *) - -let dloc = Loc.ghost - -let catching_error call_trace fail (e, info) = - let inner_trace = - Option.default [] (Exninfo.get info ltac_trace_info) - in - if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info) - else begin - assert (Errors.noncritical e); (* preserved invariant *) - let new_trace = inner_trace @ call_trace in - let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in - fail located_exc - end - -let catch_error call_trace f x = - try f x - with e when Errors.noncritical e -> - let e = Errors.push e in - catching_error call_trace iraise e - -let catch_error_tac call_trace tac = - Proofview.tclORELSE - tac - (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) - -let curr_debug ist = match TacStore.get ist.extra f_debug with -| None -> DebugOff -| Some level -> level - -(** TODO: unify printing of generic Ltac values in case of coercion failure. *) - -(* Displays a value *) -let pr_value env v = - let v = Value.normalize v in - if has_type v (topwit wit_tacvalue) then str "a tactic" - else if has_type v (topwit wit_constr_context) then - let c = out_gen (topwit wit_constr_context) v in - match env with - | Some (env,sigma) -> pr_lconstr_env env sigma c - | _ -> str "a term" - else if has_type v (topwit wit_constr) then - let c = out_gen (topwit wit_constr) v in - match env with - | Some (env,sigma) -> pr_lconstr_env env sigma c - | _ -> str "a term" - else if has_type v (topwit wit_constr_under_binders) then - let c = out_gen (topwit wit_constr_under_binders) v in - match env with - | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c - | _ -> str "a term" - else - str "a value of type" ++ spc () ++ pr_argument_type v - -let pr_closure env ist body = - let pp_body = Pptactic.pr_glob_tactic env body in - let pr_sep () = fnl () in - let pr_iarg (id, arg) = - let arg = pr_argument_type arg in - hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) - in - let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in - pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs - -let pr_inspect env expr result = - let pp_expr = Pptactic.pr_glob_tactic env expr in - let pp_result = - if has_type result (topwit wit_tacvalue) then - match to_tacvalue result with - | VFun (_,_, ist, ul, b) -> - let body = if List.is_empty ul then b else (TacFun (ul, b)) in - str "a closure with body " ++ fnl() ++ pr_closure env ist body - | VRec (ist, body) -> - str "a recursive closure" ++ fnl () ++ pr_closure env !ist body - else - let pp_type = pr_argument_type result in - str "an object of type" ++ spc () ++ pp_type - in - pp_expr ++ fnl() ++ str "this is " ++ pp_result - -(* Transforms an id into a constr if possible, or fails with Not_found *) -let constr_of_id env id = - Term.mkVar (let _ = Environ.lookup_named id env in id) - -(** Generic arguments : table of interpretation functions *) - -let push_trace call ist = match TacStore.get ist.extra f_trace with -| None -> [call] -| Some trace -> call :: trace - -let propagate_trace ist loc id v = - let v = Value.normalize v in - if has_type v (topwit wit_tacvalue) then - let tacv = to_tacvalue v in - match tacv with - | VFun (appl,_,lfun,it,b) -> - let t = if List.is_empty it then b else TacFun (it,b) in - let ans = VFun (appl,push_trace(loc,LtacVarCall (id,t)) ist,lfun,it,b) in - of_tacvalue ans - | _ -> v - else v - -let append_trace trace v = - let v = Value.normalize v in - if has_type v (topwit wit_tacvalue) then - match to_tacvalue v with - | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b)) - | _ -> v - else v - -(* Dynamically check that an argument is a tactic *) -let coerce_to_tactic loc id v = - let v = Value.normalize v in - let fail () = user_err_loc - (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") - in - let v = Value.normalize v in - if has_type v (topwit wit_tacvalue) then - let tacv = to_tacvalue v in - match tacv with - | VFun _ -> v - | _ -> fail () - else fail () - -let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) -let value_of_ident id = - in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) - -let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 - -let extend_values_with_bindings (ln,lm) lfun = - let of_cub c = match c with - | [], c -> Value.of_constr c - | _ -> in_gen (topwit wit_constr_under_binders) c - in - (* For compatibility, bound variables are visible only if no other - binding of the same name exists *) - let accu = Id.Map.map value_of_ident ln in - let accu = lfun +++ accu in - Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu - -(***************************************************************************) -(* Evaluation/interpretation *) - -let is_variable env id = - Id.List.mem id (ids_of_named_context (Environ.named_context env)) - -(* Debug reference *) -let debug = ref DebugOff - -(* Sets the debugger mode *) -let set_debug pos = debug := pos - -(* Gives the state of debug *) -let get_debug () = !debug - -let debugging_step ist pp = match curr_debug ist with - | DebugOn lev -> - safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl()) - | _ -> Proofview.NonLogical.return () - -let debugging_exception_step ist signal_anomaly e pp = - let explain_exc = - if signal_anomaly then explain_logic_error - else explain_logic_error_no_anomaly in - debugging_step ist (fun () -> - pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) - -let error_ltac_variable loc id env v s = - user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ - strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ - strbrk "which cannot be coerced to " ++ str s ++ str".") - -(* Raise Not_found if not in interpretation sign *) -let try_interp_ltac_var coerce ist env (loc,id) = - let v = Id.Map.find id ist.lfun in - try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s - -let interp_ltac_var coerce ist env locid = - try try_interp_ltac_var coerce ist env locid - with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") - -let interp_ident ist env sigma id = - try try_interp_ltac_var (coerce_to_ident false env) ist (Some (env,sigma)) (dloc,id) - with Not_found -> id - -let pf_interp_ident id gl = interp_ident id (pf_env gl) (project gl) - -(* Interprets an optional identifier, bound or fresh *) -let interp_name ist env sigma = function - | Anonymous -> Anonymous - | Name id -> Name (interp_ident ist env sigma id) - -let interp_intro_pattern_var loc ist env sigma id = - try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id) - with Not_found -> IntroNaming (IntroIdentifier id) - -let interp_intro_pattern_naming_var loc ist env sigma id = - try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) - with Not_found -> IntroIdentifier id - -let interp_int ist locid = - try try_interp_ltac_var coerce_to_int ist None locid - with Not_found -> - user_err_loc(fst locid,"interp_int", - str "Unbound variable " ++ pr_id (snd locid) ++ str".") - -let interp_int_or_var ist = function - | ArgVar locid -> interp_int ist locid - | ArgArg n -> n - -let interp_int_or_var_as_list ist = function - | ArgVar (_,id as locid) -> - (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) - | ArgArg n as x -> [x] - -let interp_int_or_var_list ist l = - List.flatten (List.map (interp_int_or_var_as_list ist) l) - -(* Interprets a bound variable (especially an existing hypothesis) *) -let interp_hyp ist env sigma (loc,id as locid) = - (* Look first in lfun for a value coercible to a variable *) - try try_interp_ltac_var (coerce_to_hyp env) ist (Some (env,sigma)) locid - with Not_found -> - (* Then look if bound in the proof context at calling time *) - if is_variable env id then id - else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id)) - -let interp_hyp_list_as_list ist env sigma (loc,id as x) = - try coerce_to_hyp_list env (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x] - -let interp_hyp_list ist env sigma l = - List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l) - -let interp_move_location ist env sigma = function - | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id) - | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id) - | MoveFirst -> MoveFirst - | MoveLast -> MoveLast - -let interp_reference ist env sigma = function - | ArgArg (_,r) -> r - | ArgVar (loc, id) -> - try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id) - with Not_found -> - try - VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) - -let try_interp_evaluable env (loc, id) = - let v = Environ.lookup_named id env in - match v with - | LocalDef _ -> EvalVarRef id - | _ -> error_not_evaluable (VarRef id) - -let interp_evaluable ist env sigma = function - | ArgArg (r,Some (loc,id)) -> - (* Maybe [id] has been introduced by Intro-like tactics *) - begin - try try_interp_evaluable env (loc, id) - with Not_found -> - match r with - | EvalConstRef _ -> r - | _ -> error_global_not_found_loc loc (qualid_of_ident id) - end - | ArgArg (r,None) -> r - | ArgVar (loc, id) -> - try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id) - with Not_found -> - try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) - -(* Interprets an hypothesis name *) -let interp_occurrences ist occs = - Locusops.occurrences_map (interp_int_or_var_list ist) occs - -let interp_hyp_location ist env sigma ((occs,id),hl) = - ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl) - -let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) = - match occs,hl with - | AllOccurrences,InHyp -> - List.map (fun id -> ((AllOccurrences,id),InHyp)) - (interp_hyp_list_as_list ist env sigma id) - | _,_ -> [interp_hyp_location ist env sigma x] - -let interp_hyp_location_list ist env sigma l = - List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l) - -let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause = - { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol; - concl_occs=interp_occurrences ist occs } - -(* Interpretation of constructions *) - -(* Extract the constr list from lfun *) -let extract_ltac_constr_values ist env = - let fold id v accu = - try - let c = coerce_to_constr env v in - Id.Map.add id c accu - with CannotCoerceTo _ -> accu - in - Id.Map.fold fold ist.lfun Id.Map.empty -(** ppedrot: I have changed the semantics here. Before this patch, closure was - implemented as a list and a variable could be bound several times with - different types, resulting in its possible appearance on both sides. This - could barely be defined as a feature... *) - -(* Extract the identifier list from lfun: join all branches (what to do else?)*) -let rec intropattern_ids (loc,pat) = match pat with - | IntroNaming (IntroIdentifier id) -> [id] - | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> - List.flatten (List.map intropattern_ids l) - | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> - List.flatten (List.map intropattern_ids (List.flatten ll)) - | IntroAction (IntroInjection l) -> - List.flatten (List.map intropattern_ids l) - | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat - | IntroNaming (IntroAnonymous | IntroFresh _) - | IntroAction (IntroWildcard | IntroRewrite _) - | IntroForthcoming _ -> [] - -let extract_ids ids lfun = - let fold id v accu = - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - let (_, ipat) = out_gen (topwit wit_intro_pattern) v in - if Id.List.mem id ids then accu - else accu @ intropattern_ids (dloc, ipat) - else accu - in - Id.Map.fold fold lfun [] - -let default_fresh_id = Id.of_string "H" - -let interp_fresh_id ist env sigma l = - let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in - let avoid = match TacStore.get ist.extra f_avoid_ids with - | None -> [] - | Some l -> l - in - let avoid = (extract_ids ids ist.lfun) @ avoid in - let id = - if List.is_empty l then default_fresh_id - else - let s = - String.concat "" (List.map (function - | ArgArg s -> s - | ArgVar (_,id) -> Id.to_string (interp_ident ist env sigma id)) l) in - let s = if Lexer.is_keyword s then s^"0" else s in - Id.of_string s in - Tactics.fresh_id_in_env avoid id env - -(* Extract the uconstr list from lfun *) -let extract_ltac_constr_context ist env = - let open Glob_term in - let add_uconstr id env v map = - try Id.Map.add id (coerce_to_uconstr env v) map - with CannotCoerceTo _ -> map - in - let add_constr id env v map = - try Id.Map.add id (coerce_to_constr env v) map - with CannotCoerceTo _ -> map - in - let add_ident id env v map = - try Id.Map.add id (coerce_to_ident false env v) map - with CannotCoerceTo _ -> map - in - let fold id v {idents;typed;untyped} = - let idents = add_ident id env v idents in - let typed = add_constr id env v typed in - let untyped = add_uconstr id env v untyped in - { idents ; typed ; untyped } - in - let empty = { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in - Id.Map.fold fold ist.lfun empty - -(** Significantly simpler than [interp_constr], to interpret an - untyped constr, it suffices to adjoin a closure environment. *) -let interp_uconstr ist env = function - | (term,None) -> - { closure = extract_ltac_constr_context ist env ; term } - | (_,Some ce) -> - let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env in - let ltacvars = { - Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); - ltac_bound = Id.Map.domain ist.lfun; - } in - { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } - -let interp_gen kind ist allow_patvar flags env sigma (c,ce) = - let constrvars = extract_ltac_constr_context ist env in - let vars = { - Pretyping.ltac_constrs = constrvars.typed; - Pretyping.ltac_uconstrs = constrvars.untyped; - Pretyping.ltac_idents = constrvars.idents; - Pretyping.ltac_genargs = ist.lfun; - } in - let c = match ce with - | None -> c - (* If at toplevel (ce<>None), the error can be due to an incorrect - context at globalization time: we retype with the now known - intros/lettac/inversion hypothesis names *) - | Some c -> - let constr_context = - Id.Set.union - (Id.Map.domain constrvars.typed) - (Id.Set.union - (Id.Map.domain constrvars.untyped) - (Id.Map.domain constrvars.idents)) - in - let ltacvars = { - ltac_vars = constr_context; - ltac_bound = Id.Map.domain ist.lfun; - } in - let kind_for_intern = - match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in - intern_gen kind_for_intern ~allow_patvar ~ltacvars env c - in - let trace = - push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist in - let (evd,c) = - catch_error trace (understand_ltac flags env sigma vars kind) c - in - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (db_constr (curr_debug ist) env c); - (evd,c) - -let constr_flags = { - use_typeclasses = true; - use_unif_heuristics = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = true; - expand_evars = true } - -(* Interprets a constr; expects evars to be solved *) -let interp_constr_gen kind ist env sigma c = - interp_gen kind ist false constr_flags env sigma c - -let interp_constr = interp_constr_gen WithoutTypeConstraint - -let interp_type = interp_constr_gen IsType - -let open_constr_use_classes_flags = { - use_typeclasses = true; - use_unif_heuristics = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true } - -let open_constr_no_classes_flags = { - use_typeclasses = false; - use_unif_heuristics = true; - use_hook = Some solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true } - -let pure_open_constr_flags = { - use_typeclasses = false; - use_unif_heuristics = true; - use_hook = None; - fail_evar = false; - expand_evars = false } - -(* Interprets an open constr *) -let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist = - let flags = - if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags - else open_constr_use_classes_flags in - interp_gen expected_type ist false flags - -let interp_pure_open_constr ist = - interp_gen WithoutTypeConstraint ist false pure_open_constr_flags - -let interp_typed_pattern ist env sigma (c,_) = - let sigma, c = - interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in - pattern_of_constr env sigma c - -(* Interprets a constr expression casted by the current goal *) -let pf_interp_casted_constr ist gl c = - interp_constr_gen (OfType (pf_concl gl)) ist (pf_env gl) (project gl) c - -(* Interprets a constr expression *) -let pf_interp_constr ist gl = - interp_constr ist (pf_env gl) (project gl) - -let new_interp_constr ist c k = - let open Proofview in - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let (sigma, c) = interp_constr ist (Goal.env gl) (project gl) c in - Sigma.Unsafe.of_pair (k c, sigma) - end } - -let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = - let try_expand_ltac_var sigma x = - try match dest_fun x with - | GVar (_,id), _ -> - let v = Id.Map.find id ist.lfun in - sigma, List.map inj_fun (coerce_to_constr_list env v) - | _ -> - raise Not_found - with CannotCoerceTo _ | Not_found -> - (* dest_fun, List.assoc may raise Not_found *) - let sigma, c = interp_fun ist env sigma x in - sigma, [c] in - let sigma, l = List.fold_map try_expand_ltac_var sigma l in - sigma, List.flatten l - -let interp_constr_list ist env sigma c = - interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c - -let interp_open_constr_list = - interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr - -(* Interprets a type expression *) -let pf_interp_type ist env sigma = - interp_type ist env sigma - -(* Fully evaluate an untyped constr *) -let type_uconstr ?(flags = constr_flags) - ?(expected_type = WithoutTypeConstraint) ist c = - { delayed = begin fun env sigma -> - let open Pretyping in - let { closure; term } = c in - let vars = { - ltac_constrs = closure.typed; - ltac_uconstrs = closure.untyped; - ltac_idents = closure.idents; - ltac_genargs = ist.lfun; - } in - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = understand_ltac flags env sigma vars expected_type term in - Sigma.Unsafe.of_pair (c, sigma) - end } - - -(* Interprets a reduction expression *) -let interp_unfold ist env sigma (occs,qid) = - (interp_occurrences ist occs,interp_evaluable ist env sigma qid) - -let interp_flag ist env sigma red = - { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst } - -let interp_constr_with_occurrences ist env sigma (occs,c) = - let (sigma,c_interp) = interp_constr ist env sigma c in - sigma , (interp_occurrences ist occs, c_interp) - -let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = - let p = match a with - | Inl (ArgVar (loc,id)) -> - (* This is the encoding of an ltac var supposed to be bound - prioritary to an evaluable reference and otherwise to a constr - (it is an encoding to satisfy the "union" type given to Simpl) *) - let coerce_eval_ref_or_constr x = - try Inl (coerce_to_evaluable_ref env x) - with CannotCoerceTo _ -> - let c = coerce_to_closed_constr env x in - Inr (pattern_of_constr env sigma c) in - (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) - with Not_found -> - error_global_not_found_loc loc (qualid_of_ident id)) - | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) - | Inr c -> Inr (interp_typed_pattern ist env sigma c) in - interp_occurrences ist occs, p - -let interp_constr_with_occurrences_and_name_as_list = - interp_constr_in_compound_list - (fun c -> ((AllOccurrences,c),Anonymous)) - (function ((occs,c),Anonymous) when occs == AllOccurrences -> c - | _ -> raise Not_found) - (fun ist env sigma (occ_c,na) -> - let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in - sigma, (c_interp, - interp_name ist env sigma na)) - -let interp_red_expr ist env sigma = function - | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l) - | Fold l -> - let (sigma,l_interp) = interp_constr_list ist env sigma l in - sigma , Fold l_interp - | Cbv f -> sigma , Cbv (interp_flag ist env sigma f) - | Cbn f -> sigma , Cbn (interp_flag ist env sigma f) - | Lazy f -> sigma , Lazy (interp_flag ist env sigma f) - | Pattern l -> - let (sigma,l_interp) = - Evd.MonadR.List.map_right - (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma - in - sigma , Pattern l_interp - | Simpl (f,o) -> - sigma , Simpl (interp_flag ist env sigma f, - Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) - | CbvVm o -> - sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) - | CbvNative o -> - sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) - | (Red _ | Hnf | ExtraRedExpr _ as r) -> sigma , r - -let interp_may_eval f ist env sigma = function - | ConstrEval (r,c) -> - let (sigma,redexp) = interp_red_expr ist env sigma r in - let (sigma,c_interp) = f ist env sigma c in - let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in - (Sigma.to_evar_map sigma, c) - | ConstrContext ((loc,s),c) -> - (try - let (sigma,ic) = f ist env sigma c in - let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in - let evdref = ref sigma in - let c = subst_meta [Constr_matching.special_meta,ic] ctxt in - let c = Typing.e_solve_evars env evdref c in - !evdref , c - with - | Not_found -> - user_err_loc (loc, "interp_may_eval", - str "Unbound context identifier" ++ pr_id s ++ str".")) - | ConstrTypeOf c -> - let (sigma,c_interp) = f ist env sigma c in - Typing.type_of ~refresh:true env sigma c_interp - | ConstrTerm c -> - try - f ist env sigma c - with reraise -> - let reraise = Errors.push reraise in - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> - str"interpretation of term " ++ pr_glob_constr_env env (fst c))); - iraise reraise - -(* Interprets a constr expression possibly to first evaluate *) -let interp_constr_may_eval ist env sigma c = - let (sigma,csr) = - try - interp_may_eval interp_constr ist env sigma c - with reraise -> - let reraise = Errors.push reraise in - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term")); - iraise reraise - in - begin - (* spiwack: to avoid unnecessary modifications of tacinterp, as this - function already use effect, I call [run] hoping it doesn't mess - up with any assumption. *) - Proofview.NonLogical.run (db_constr (curr_debug ist) env csr); - sigma , csr - end - -(** TODO: should use dedicated printers *) -let rec message_of_value v = - let v = Value.normalize v in - let open Ftactic in - if has_type v (topwit wit_tacvalue) then - Ftactic.return (str "") - else if has_type v (topwit wit_constr) then - let v = out_gen (topwit wit_constr) v in - Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) v) end } - else if has_type v (topwit wit_constr_under_binders) then - let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) - end } - else if has_type v (topwit wit_unit) then - Ftactic.return (str "()") - else if has_type v (topwit wit_int) then - Ftactic.return (int (out_gen (topwit wit_int) v)) - else if has_type v (topwit wit_intro_pattern) then - let p = out_gen (topwit wit_intro_pattern) v in - let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in - Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) - end } - else if has_type v (topwit wit_constr_context) then - let c = out_gen (topwit wit_constr_context) v in - Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) c) end } - else if has_type v (topwit wit_uconstr) then - let c = out_gen (topwit wit_uconstr) v in - Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (pr_closed_glob_env (pf_env gl) - (project gl) c) - end } - else match Value.to_list v with - | Some l -> - Ftactic.List.map message_of_value l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - | None -> - let tag = pr_argument_type v in - Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) - -let interp_message_token ist = function - | MsgString s -> Ftactic.return (str s) - | MsgInt n -> Ftactic.return (int n) - | MsgIdent (loc,id) -> - let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in - match v with - | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found.")) - | Some v -> message_of_value v - -let interp_message ist l = - let open Ftactic in - Ftactic.List.map (interp_message_token ist) l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - -let rec interp_intro_pattern ist env sigma = function - | loc, IntroAction pat -> - let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in - sigma, (loc, IntroAction pat) - | loc, IntroNaming (IntroIdentifier id) -> - sigma, (loc, interp_intro_pattern_var loc ist env sigma id) - | loc, IntroNaming pat -> - sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat)) - | loc, IntroForthcoming _ as x -> sigma, x - -and interp_intro_pattern_naming loc ist env sigma = function - | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) - | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id - | IntroAnonymous as x -> x - -and interp_intro_pattern_action ist env sigma = function - | IntroOrAndPattern l -> - let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in - sigma, IntroOrAndPattern l - | IntroInjection l -> - let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in - sigma, IntroInjection l - | IntroApplyOn (c,ipat) -> - let c = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in - let sigma,ipat = interp_intro_pattern ist env sigma ipat in - sigma, IntroApplyOn (c,ipat) - | IntroWildcard | IntroRewrite _ as x -> sigma, x - -and interp_or_and_intro_pattern ist env sigma = function - | IntroAndPattern l -> - let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in - sigma, IntroAndPattern l - | IntroOrPattern ll -> - let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in - sigma, IntroOrPattern ll - -and interp_intro_pattern_list_as_list ist env sigma = function - | [loc,IntroNaming (IntroIdentifier id)] as l -> - (try sigma, coerce_to_intro_pattern_list loc env (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> - List.fold_map (interp_intro_pattern ist env) sigma l) - | l -> List.fold_map (interp_intro_pattern ist env) sigma l - -let interp_intro_pattern_naming_option ist env sigma = function - | None -> None - | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat) - -let interp_or_and_intro_pattern_option ist env sigma = function - | None -> sigma, None - | Some (ArgVar (loc,id)) -> - (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with - | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) - | _ -> - raise (CannotCoerceTo "a disjunctive/conjunctive introduction pattern")) - | Some (ArgArg (loc,l)) -> - let sigma,l = interp_or_and_intro_pattern ist env sigma l in - sigma, Some (loc,l) - -let interp_intro_pattern_option ist env sigma = function - | None -> sigma, None - | Some ipat -> - let sigma, ipat = interp_intro_pattern ist env sigma ipat in - sigma, Some ipat - -let interp_in_hyp_as ist env sigma (id,ipat) = - let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in - sigma,(interp_hyp ist env sigma id,ipat) - -let interp_quantified_hypothesis ist = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) - with Not_found -> NamedHyp id - -let interp_binding_name ist = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - (* If a name is bound, it has to be a quantified hypothesis *) - (* user has to use other names for variables if these ones clash with *) - (* a name intented to be used as a (non-variable) identifier *) - try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id) - with Not_found -> NamedHyp id - -let interp_declared_or_quantified_hypothesis ist env sigma = function - | AnonHyp n -> AnonHyp n - | NamedHyp id -> - try try_interp_ltac_var - (coerce_to_decl_or_quant_hyp env) ist (Some (env,sigma)) (dloc,id) - with Not_found -> NamedHyp id - -let interp_binding ist env sigma (loc,b,c) = - let sigma, c = interp_open_constr ist env sigma c in - sigma, (loc,interp_binding_name ist b,c) - -let interp_bindings ist env sigma = function -| NoBindings -> - sigma, NoBindings -| ImplicitBindings l -> - let sigma, l = interp_open_constr_list ist env sigma l in - sigma, ImplicitBindings l -| ExplicitBindings l -> - let sigma, l = List.fold_map (interp_binding ist env) sigma l in - sigma, ExplicitBindings l - -let interp_constr_with_bindings ist env sigma (c,bl) = - let sigma, bl = interp_bindings ist env sigma bl in - let sigma, c = interp_open_constr ist env sigma c in - sigma, (c,bl) - -let interp_open_constr_with_bindings ist env sigma (c,bl) = - let sigma, bl = interp_bindings ist env sigma bl in - let sigma, c = interp_open_constr ist env sigma c in - sigma, (c, bl) - -let loc_of_bindings = function -| NoBindings -> Loc.ghost -| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) -| ExplicitBindings l -> pi1 (List.last l) - -let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = - let loc1 = loc_of_glob_constr c in - let loc2 = loc_of_bindings bl in - let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in - Sigma.Unsafe.of_pair (c, sigma) - } in - (loc,f) - -let interp_induction_arg ist gl arg = - match arg with - | keep,ElimOnConstr c -> - keep,ElimOnConstr { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } - | keep,ElimOnAnonHyp n as x -> x - | keep,ElimOnIdent (loc,id) -> - let error () = user_err_loc (loc, "", - strbrk "Cannot coerce " ++ pr_id id ++ - strbrk " neither to a quantified hypothesis nor to a term.") - in - let try_cast_id id' = - if Tactics.is_quantified_hypothesis id' gl - then keep,ElimOnIdent (loc,id') - else - (keep, ElimOnConstr { delayed = begin fun env sigma -> - try Sigma.here (constr_of_id env id', NoBindings) sigma - with Not_found -> - user_err_loc (loc, "interp_induction_arg", - pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") - end }) - in - try - (** FIXME: should be moved to taccoerce *) - let v = Id.Map.find id ist.lfun in - let v = Value.normalize v in - if has_type v (topwit wit_intro_pattern) then - let v = out_gen (topwit wit_intro_pattern) v in - match v with - | _, IntroNaming (IntroIdentifier id) -> try_cast_id id - | _ -> error () - else if has_type v (topwit wit_var) then - let id = out_gen (topwit wit_var) v in - try_cast_id id - else if has_type v (topwit wit_int) then - keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) - else match Value.to_constr v with - | None -> error () - | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } - with Not_found -> - (* We were in non strict (interactive) mode *) - if Tactics.is_quantified_hypothesis id gl then - keep,ElimOnIdent (loc,id) - else - let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma,c) = interp_open_constr ist env sigma c in - Sigma.Unsafe.of_pair ((c,NoBindings), sigma) - } in - keep,ElimOnConstr f - -(* Associates variables with values and gives the remaining variables and - values *) -let head_with_value (lvar,lval) = - let rec head_with_value_rec lacc = function - | ([],[]) -> (lacc,[],[]) - | (vr::tvr,ve::tve) -> - (match vr with - | None -> head_with_value_rec lacc (tvr,tve) - | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) - | (vr,[]) -> (lacc,vr,[]) - | ([],ve) -> (lacc,[],ve) - in - head_with_value_rec [] (lvar,lval) - -(** [interp_context ctxt] interprets a context (as in - {!Matching.matching_result}) into a context value of Ltac. *) -let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt - -(* Reads a pattern by substituting vars of lfun *) -let use_types = false - -let eval_pattern lfun ist env sigma ((glob,_),pat as c) = - let bound_names = bound_glob_vars glob in - if use_types then - (bound_names,interp_typed_pattern ist env sigma c) - else - (bound_names,instantiate_pattern env sigma lfun pat) - -let read_pattern lfun ist env sigma = function - | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) - | Term c -> Term (eval_pattern lfun ist env sigma c) - -(* Reads the hypotheses of a Match Context rule *) -let cons_and_check_name id l = - if Id.List.mem id l then - user_err_loc (dloc,"read_match_goal_hyps", - str "Hypothesis pattern-matching variable " ++ pr_id id ++ - str " used twice in the same pattern.") - else id::l - -let rec read_match_goal_hyps lfun ist env sigma lidh = function - | (Hyp ((loc,na) as locna,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in - Hyp (locna,read_pattern lfun ist env sigma mp):: - (read_match_goal_hyps lfun ist env sigma lidh' tl) - | (Def ((loc,na) as locna,mv,mp))::tl -> - let lidh' = name_fold cons_and_check_name na lidh in - Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: - (read_match_goal_hyps lfun ist env sigma lidh' tl) - | [] -> [] - -(* Reads the rules of a Match Context or a Match *) -let rec read_match_rule lfun ist env sigma = function - | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl) - | (Pat (rl,mp,tc))::tl -> - Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc) - :: read_match_rule lfun ist env sigma tl - | [] -> [] - - -(* misc *) - -let interp_focussed wit f v = - Ftactic.nf_enter { enter = begin fun gl -> - let v = Genarg.out_gen (glbwit wit) v in - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let v = in_gen (topwit wit) (f env sigma v) in - Ftactic.return v - end } - -(* Interprets an l-tac expression into a value *) -let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = - (* The name [appl] of applied top-level Ltac names is ignored in - [value_interp]. It is installed in the second step by a call to - [name_vfun], because it gives more opportunities to detect a - [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never - register its name since it is syntactically a let, not a - function. *) - let value_interp ist = match tac with - | TacFun (it, body) -> - Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body))) - | TacLetIn (true,l,u) -> interp_letrec ist l u - | TacLetIn (false,l,u) -> interp_letin ist l u - | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr - | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr - | TacArg (loc,a) -> interp_tacarg ist a - | t -> - (** Delayed evaluation *) - Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) - in - let open Ftactic in - Control.check_for_interrupt (); - match curr_debug ist with - | DebugOn lev -> - let eval v = - let ist = { ist with extra = TacStore.set ist.extra f_debug v } in - value_interp ist >>= fun v -> return (name_vfun appl v) - in - Tactic_debug.debug_prompt lev tac eval - | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) - - -and eval_tactic ist tac : unit Proofview.tactic = match tac with - | TacAtom (loc,t) -> - let call = LtacAtomCall t in - catch_error_tac (push_trace(loc,call) ist) (interp_atomic ist t) - | TacFun _ | TacLetIn _ -> assert false - | TacMatchGoal _ | TacMatch _ -> assert false - | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) - | TacId s -> - let msgnl = - let open Ftactic in - interp_message ist s >>= fun msg -> - return (hov 0 msg , hov 0 msg) - in - let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in - let log (msg,_) = Proofview.Trace.log (fun () -> msg) in - let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in - Ftactic.run msgnl begin fun msgnl -> - print msgnl <*> log msgnl <*> break - end - | TacFail (g,n,s) -> - let msg = interp_message ist s in - let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in - let tac = - match g with - | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l) - | TacGlobal -> tac - in - Ftactic.run msg tac - | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac) - | TacShowHyps tac -> - Proofview.V82.tactic begin - tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) - end - | TacAbstract (tac,ido) -> - Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT - (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) - end } - | TacThen (t1,t) -> - Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) - | TacDispatch tl -> - Proofview.tclDISPATCH (List.map (interp_tactic ist) tl) - | TacExtendTac (tf,t,tl) -> - Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf) - (interp_tactic ist t) - (Array.map_to_list (interp_tactic ist) tl) - | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) - | TacThens3parts (t1,tf,t,tl) -> - Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1) - (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) - | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac) - | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) - | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac) - | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac) - | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac) - | TacOr (tac1,tac2) -> - Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2) - | TacOnce tac -> - Tacticals.New.tclONCE (interp_tactic ist tac) - | TacExactlyOnce tac -> - Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac) - | TacIfThenCatch (t,tt,te) -> - Tacticals.New.tclIFCATCH - (interp_tactic ist t) - (fun () -> interp_tactic ist tt) - (fun () -> interp_tactic ist te) - | TacOrelse (tac1,tac2) -> - Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) - | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) - | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) - | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) - | TacArg a -> interp_tactic ist (TacArg a) - | TacInfo tac -> - msg_warning - (strbrk "The general \"info\" tactic is currently not working." ++ spc()++ - strbrk "There is an \"Info\" command to replace it." ++fnl () ++ - strbrk "Some specific verbose tactics may also exist, such as info_eauto."); - eval_tactic ist tac - (* For extensions *) - | TacAlias (loc,s,l) -> - let (ids, body) = Tacenv.interp_alias s in - let (>>=) = Ftactic.bind in - let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in - let tac l = - let addvar x v accu = Id.Map.add x v accu in - let lfun = List.fold_right2 addvar ids l ist.lfun in - let trace = push_trace (loc,LtacNotationCall s) ist in - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in - val_interp ist body >>= fun v -> - Ftactic.lift (tactic_of_value ist v) - in - let tac = - Ftactic.with_env interp_vars >>= fun (env, lr) -> - let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in - Proofview.Trace.name_tactic name (tac lr) - (* spiwack: this use of name_tactic is not robust to a - change of implementation of [Ftactic]. In such a situation, - some more elaborate solution will have to be used. *) - in - let tac = - let len1 = List.length ids in - let len2 = List.length l in - if len1 = len2 then tac - else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ - expected " ++ int len1 ++ str ", found " ++ int len2) - in - Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - - | TacML (loc,opn,l) -> - let open Ftactic.Notations in - let trace = push_trace (loc,LtacMLCall tac) ist in - let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - let tac = Tacenv.interp_ml_tactic opn in - let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in - let tac args = - let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in - Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) - in - Ftactic.run args tac - -and force_vrec ist v : Val.t Ftactic.t = - let v = Value.normalize v in - if has_type v (topwit wit_tacvalue) then - let v = to_tacvalue v in - match v with - | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body - | v -> Ftactic.return (of_tacvalue v) - else Ftactic.return v - -and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = - match r with - | ArgVar (loc,id) -> - let v = - try Id.Map.find id ist.lfun - with Not_found -> in_gen (topwit wit_var) id - in - Ftactic.bind (force_vrec ist v) begin fun v -> - let v = propagate_trace ist loc id v in - if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v - end - | ArgArg (loc,r) -> - let ids = extract_ids [] ist.lfun in - let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in - let extra = TacStore.set ist.extra f_avoid_ids ids in - let extra = TacStore.set extra f_trace (push_trace loc_info ist) in - let ist = { lfun = Id.Map.empty; extra = extra; } in - let appl = GlbAppl[r,[]] in - val_interp ~appl ist (Tacenv.interp_ltac r) - -and interp_tacarg ist arg : Val.t Ftactic.t = - match arg with - | TacGeneric arg -> interp_genarg ist arg - | Reference r -> interp_ltac_reference dloc false ist r - | ConstrMayEval c -> - Ftactic.s_enter { s_enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in - Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) - end } - | TacCall (loc,r,[]) -> - interp_ltac_reference loc true ist r - | TacCall (loc,f,l) -> - let (>>=) = Ftactic.bind in - interp_ltac_reference loc true ist f >>= fun fv -> - Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> - interp_app loc ist fv largs - | TacFreshId l -> - Ftactic.enter { enter = begin fun gl -> - let id = interp_fresh_id ist (pf_env gl) (project gl) l in - Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) - end } - | TacPretype c -> - Ftactic.s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let env = Proofview.Goal.env gl in - let c = interp_uconstr ist env c in - let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in - Sigma (Ftactic.return (Value.of_constr c), sigma, p) - end } - | TacNumgoals -> - Ftactic.lift begin - let open Proofview.Notations in - Proofview.numgoals >>= fun i -> - Proofview.tclUNIT (Value.of_int i) - end - | Tacexp t -> val_interp ist t - -(* Interprets an application node *) -and interp_app loc ist fv largs : Val.t Ftactic.t = - let (>>=) = Ftactic.bind in - let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in - let fv = Value.normalize fv in - if has_type fv (topwit wit_tacvalue) then - match to_tacvalue fv with - (* if var=[] and body has been delayed by val_interp, then body - is not a tactic that expects arguments. - Otherwise Ltac goes into an infinite loop (val_interp puts - a VFun back on body, and then interp_app is called again...) *) - | (VFun(appl,trace,olfun,(_::_ as var),body) - |VFun(appl,trace,olfun,([] as var), - (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> - let (extfun,lvar,lval)=head_with_value (var,largs) in - let fold accu (id, v) = Id.Map.add id v accu in - let newlfun = List.fold_left fold olfun extfun in - if List.is_empty lvar then - begin Proofview.tclORELSE - begin - let ist = { - lfun = newlfun; - extra = TacStore.set ist.extra f_trace []; } in - catch_error_tac trace (val_interp ist body) >>= fun v -> - Ftactic.return (name_vfun (push_appl appl largs) v) - end - begin fun (e, info) -> - Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*> - Proofview.tclZERO ~info e - end - end >>= fun v -> - (* No errors happened, we propagate the trace *) - let v = append_trace trace v in - Proofview.tclLIFT begin - debugging_step ist - (fun () -> - str"evaluation returns"++fnl()++pr_value None v) - end <*> - if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval - else - Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) - | _ -> fail - else fail - -(* Gives the tactic corresponding to the tactic value *) -and tactic_of_value ist vle = - let vle = Value.normalize vle in - if has_type vle (topwit wit_tacvalue) then - match to_tacvalue vle with - | VFun (appl,trace,lfun,[],t) -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace []; } in - let tac = name_if_glob appl (eval_tactic ist t) in - catch_error_tac trace tac - | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") - else if has_type vle (topwit wit_tactic) then - let tac = out_gen (topwit wit_tactic) vle in - tactic_of_value ist tac - else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") - -(* Interprets the clauses of a recursive LetIn *) -and interp_letrec ist llc u = - Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) - let lref = ref ist.lfun in - let fold accu ((_, id), b) = - let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in - Id.Map.add id v accu - in - let lfun = List.fold_left fold ist.lfun llc in - let () = lref := lfun in - let ist = { ist with lfun } in - val_interp ist u - -(* Interprets the clauses of a LetIn *) -and interp_letin ist llc u = - let rec fold lfun = function - | [] -> - let ist = { ist with lfun } in - val_interp ist u - | ((_, id), body) :: defs -> - Ftactic.bind (interp_tacarg ist body) (fun v -> - fold (Id.Map.add id v lfun) defs) - in - fold ist.lfun llc - -(** [interp_match_success lz ist succ] interprets a single matching success - (of type {!Tactic_matching.t}). *) -and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = - let (>>=) = Ftactic.bind in - let lctxt = Id.Map.map interp_context context in - let hyp_subst = Id.Map.map Value.of_constr terms in - let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in - let ist = { ist with lfun } in - val_interp ist lhs >>= fun v -> - if has_type v (topwit wit_tacvalue) then match to_tacvalue v with - | VFun (appl,trace,lfun,[],t) -> - let ist = { - lfun = lfun; - extra = TacStore.set ist.extra f_trace trace; } in - let tac = eval_tactic ist t in - let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in - catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) - | _ -> Ftactic.return v - else Ftactic.return v - - -(** [interp_match_successes lz ist s] interprets the stream of - matching of successes [s]. If [lz] is set to true, then only the - first success is considered, otherwise further successes are tried - if the left-hand side fails. *) -and interp_match_successes lz ist s = - let general = - let break (e, info) = match e with - | FailError (0, _) -> None - | FailError (n, s) -> Some (FailError (pred n, s), info) - | _ -> None - in - Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans - in - match lz with - | General -> - general - | Select -> - begin - (** Only keep the first matching result, we don't backtrack on it *) - let s = Proofview.tclONCE s in - s >>= fun ans -> interp_match_success ist ans - end - | Once -> - (** Once a tactic has succeeded, do not backtrack anymore *) - Proofview.tclONCE general - -(* Interprets the Match expressions *) -and interp_match ist lz constr lmr = - let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE - (interp_ltac_constr ist constr) - begin function - | (e, info) -> - Proofview.tclLIFT (debugging_exception_step ist true e - (fun () -> str "evaluation of the matched expression")) <*> - Proofview.tclZERO ~info e - end - end >>= fun constr -> - Ftactic.enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in - interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) - end } - -(* Interprets the Match Context expressions *) -and interp_match_goal ist lz lr lmr = - Ftactic.nf_enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let hyps = Proofview.Goal.hyps gl in - let hyps = if lr then List.rev hyps else hyps in - let concl = Proofview.Goal.concl gl in - let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in - interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) - end } - -(* Interprets extended tactic generic arguments *) -and interp_genarg ist x : Val.t Ftactic.t = - let open Ftactic.Notations in - (** Ad-hoc handling of some types. *) - let tag = genarg_tag x in - if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then - interp_genarg_var_list ist x - else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then - interp_genarg_constr_list ist x - else - let GenArg (Glbwit wit, x) = x in - match wit with - | ListArg wit -> - let map x = - interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> - Ftactic.return (Value.cast (topwit wit) x) - in - Ftactic.List.map map x >>= fun l -> - Ftactic.return (Value.of_list (val_tag wit) l) - | OptArg wit -> - let ans = match x with - | None -> Ftactic.return (Value.of_option (val_tag wit) None) - | Some x -> - interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> - let x = Value.cast (topwit wit) x in - Ftactic.return (Value.of_option (val_tag wit) (Some x)) - in - ans - | PairArg (wit1, wit2) -> - let (p, q) = x in - interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> - interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> - let p = Value.cast (topwit wit1) p in - let q = Value.cast (topwit wit2) q in - Ftactic.return (Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q))) - | ExtraArg s -> - Geninterp.generic_interp ist (Genarg.in_gen (glbwit wit) x) - -(** returns [true] for genargs which have the same meaning - independently of goals. *) - -and interp_genarg_constr_list ist x = - Ftactic.nf_s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in - let (sigma,lc) = interp_constr_list ist env sigma lc in - let lc = Value.of_list (val_tag wit_constr) lc in - Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) - end } - -and interp_genarg_var_list ist x = - Ftactic.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in - let lc = interp_hyp_list ist env sigma lc in - Ftactic.return (Value.of_list (val_tag wit_var) lc) - end } - -(* Interprets tactic expressions : returns a "constr" *) -and interp_ltac_constr ist e : constr Ftactic.t = - let (>>=) = Ftactic.bind in - begin Proofview.tclORELSE - (val_interp ist e) - begin function (err, info) -> match err with - | Not_found -> - Ftactic.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - Proofview.tclLIFT begin - debugging_step ist (fun () -> - str "evaluation failed for" ++ fnl() ++ - Pptactic.pr_glob_tactic env e) - end - <*> Proofview.tclZERO Not_found - end } - | err -> Proofview.tclZERO ~info err - end - end >>= fun result -> - Ftactic.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let result = Value.normalize result in - try - let cresult = coerce_to_closed_constr env result in - Proofview.tclLIFT begin - debugging_step ist (fun () -> - Pptactic.pr_glob_tactic env e ++ fnl() ++ - str " has value " ++ fnl() ++ - pr_constr_env env sigma cresult) - end <*> - Ftactic.return cresult - with CannotCoerceTo _ -> - let env = Proofview.Goal.env gl in - Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ - str "offending expression: " ++ fnl() ++ pr_inspect env e result) - end } - - -(* Interprets tactic expressions : returns a "tactic" *) -and interp_tactic ist tac : unit Proofview.tactic = - Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v) - -(* Provides a "name" for the trace to atomic tactics *) -and name_atomic ?env tacexpr tac : unit Proofview.tactic = - begin match env with - | Some e -> Proofview.tclUNIT e - | None -> Proofview.tclENV - end >>= fun env -> - let name () = Pptactic.pr_tactic env (TacAtom (Loc.ghost,tacexpr)) in - Proofview.Trace.name_tactic name tac - -(* Interprets a primitive tactic *) -and interp_atomic ist tac : unit Proofview.tactic = - match tac with - (* Basic tactics *) - | TacIntroPattern l -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacIntroPattern l) - (* spiwack: print uninterpreted, not sure if it is the - expected behaviour. *) - (Tactics.intro_patterns l')) sigma - end } - | TacIntroMove (ido,hto) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let mloc = interp_move_location ist env sigma hto in - let ido = Option.map (interp_ident ist env sigma) ido in - name_atomic ~env - (TacIntroMove(ido,mloc)) - (Tactics.intro_move ido mloc) - end } - | TacExact c -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let (sigma, c_interp) = pf_interp_casted_constr ist gl c in - Sigma.Unsafe.of_pair (Proofview.V82.tactic (Tactics.exact_no_check c_interp), sigma) - end } - end - | TacApply (a,ev,cb,cl) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let l = List.map (fun (k,c) -> - let loc, f = interp_open_constr_with_bindings_loc ist c in - (k,(loc,f))) cb - in - let sigma,tac = match cl with - | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l - | Some cl -> - let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev id l cl in - Tacticals.New.tclWITHHOLES ev tac sigma - end } - end - | TacElim (ev,(keep,cb),cbo) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let sigma, cb = interp_constr_with_bindings ist env sigma cb in - let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in - let named_tac = - let tac = Tactics.elim ev keep cb cbo in - name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac - in - Tacticals.New.tclWITHHOLES ev named_tac sigma - end } - | TacCase (ev,(keep,cb)) -> - Proofview.Goal.enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let sigma, cb = interp_constr_with_bindings ist env sigma cb in - let named_tac = - let tac = Tactics.general_case_analysis ev keep cb in - name_atomic ~env (TacCase(ev,(keep,cb))) tac - in - Tacticals.New.tclWITHHOLES ev named_tac sigma - end } - | TacMutualFix (id,n,l) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let env = pf_env gl in - let f sigma (id,n,c) = - let (sigma,c_interp) = pf_interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,n,c_interp) in - let (sigma,l_interp) = - Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) - in - let tac = Proofview.V82.tactic (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) in - Sigma.Unsafe.of_pair (tac, sigma) - end } - end - | TacMutualCofix (id,l) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let env = pf_env gl in - let f sigma (id,c) = - let (sigma,c_interp) = pf_interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,c_interp) in - let (sigma,l_interp) = - Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) - in - let tac = Proofview.V82.tactic (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) in - Sigma.Unsafe.of_pair (tac, sigma) - end } - end - | TacAssert (b,t,ipat,c) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let (sigma,c) = - (if Option.is_empty t then interp_constr else interp_type) ist env sigma c - in - let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in - let tac = Option.map (interp_tactic ist) t in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacAssert(b,t,ipat,c)) - (Tactics.forward b tac ipat' c)) sigma - end } - | TacGeneralize cl -> - Proofview.Goal.enter { enter = begin fun gl -> - let sigma = project gl in - let env = Proofview.Goal.env gl in - let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacGeneralize cl) - (Proofview.V82.tactic (Tactics.generalize_gen cl))) sigma - end } - | TacLetTac (na,c,clp,b,eqpat) -> - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let clp = interp_clause ist env sigma clp in - let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in - if Locusops.is_nowhere clp then - (* We try to fully-typecheck the term *) - let (sigma,c_interp) = pf_interp_constr ist gl c in - let let_tac b na c cl eqpat = - let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - Tactics.letin_tac with_eq na c None cl - in - let na = interp_name ist env sigma na in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacLetTac(na,c_interp,clp,b,eqpat)) - (let_tac b na c_interp clp eqpat)) sigma - else - (* We try to keep the pattern structure as much as possible *) - let let_pat_tac b na c cl eqpat = - let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - Tactics.letin_pat_tac with_eq na c cl - in - let (sigma',c) = interp_pure_open_constr ist env sigma c in - name_atomic ~env - (TacLetTac(na,c,clp,b,eqpat)) - (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) - (let_pat_tac b (interp_name ist env sigma na) - ((sigma,sigma'),c) clp eqpat) sigma') - end } - - (* Derived basic tactics *) - | TacInductionDestruct (isrec,ev,(l,el)) -> - (* spiwack: some unknown part of destruct needs the goal to be - prenormalised. *) - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let sigma,l = - List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> - (* TODO: move sigma as a side-effect *) - (* spiwack: the [*p] variants are for printing *) - let cp = c in - let c = interp_induction_arg ist gl c in - let ipato = interp_intro_pattern_naming_option ist env sigma ipato in - let ipatsp = ipats in - let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in - let cls = Option.map (interp_clause ist env sigma) cls in - sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls)) - end sigma l - in - let l,lp = List.split l in - let sigma,el = - Option.fold_map (interp_constr_with_bindings ist env) sigma el in - let tac = name_atomic ~env - (TacInductionDestruct(isrec,ev,(lp,el))) - (Tactics.induction_destruct isrec ev (l,el)) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } - | TacDoubleInduction (h1,h2) -> - let h1 = interp_quantified_hypothesis ist h1 in - let h2 = interp_quantified_hypothesis ist h2 in - name_atomic - (TacDoubleInduction (h1,h2)) - (Elim.h_double_induction h1 h2) - (* Context management *) - | TacRename l -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = pf_env gl in - let sigma = project gl in - let l = - List.map (fun (id1,id2) -> - interp_hyp ist env sigma id1, - interp_ident ist env sigma (snd id2)) l - in - name_atomic ~env - (TacRename l) - (Tactics.rename_hyp l) - end } - - (* Conversion *) - | TacReduce (r,cl) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in - Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) - end } - end - | TacChange (None,c,cl) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter { enter = begin fun gl -> - let is_onhyps = match cl.onhyps with - | None | Some [] -> true - | _ -> false - in - let is_onconcl = match cl.concl_occs with - | AllOccurrences | NoOccurrences -> true - | _ -> false - in - let c_interp patvars = { Sigma.run = begin fun sigma -> - let lfun' = Id.Map.fold (fun id c lfun -> - Id.Map.add id (Value.of_constr c) lfun) - patvars ist.lfun - in - let sigma = Sigma.to_evar_map sigma in - let ist = { ist with lfun = lfun' } in - let (sigma, c) = - if is_onhyps && is_onconcl - then interp_type ist (pf_env gl) sigma c - else interp_constr ist (pf_env gl) sigma c - in - Sigma.Unsafe.of_pair (c, sigma) - end } in - Proofview.V82.tactic (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)) - end } - end - | TacChange (Some op,c,cl) -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"") begin - Proofview.V82.nf_evar_goals <*> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - Proofview.V82.tactic begin fun gl -> - let op = interp_typed_pattern ist env sigma op in - let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in - let c_interp patvars = { Sigma.run = begin fun sigma -> - let lfun' = Id.Map.fold (fun id c lfun -> - Id.Map.add id (Value.of_constr c) lfun) - patvars ist.lfun - in - let ist = { ist with lfun = lfun' } in - try - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - with e when to_catch e (* Hack *) -> - errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") - end } in - (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) - gl - end - end } - end - - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - Proofview.Goal.enter { enter = begin fun gl -> - let l' = List.map (fun (b,m,(keep,c)) -> - let f = { delayed = fun env sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in - Sigma.Unsafe.of_pair (c, sigma) - } in - (b,m,keep,f)) l in - let env = Proofview.Goal.env gl in - let sigma = project gl in - let cl = interp_clause ist env sigma cl in - name_atomic ~env - (TacRewrite (ev,l,cl,by)) - (Equality.general_multi_rewrite ev l' cl - (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), - Equality.Naive) - by)) - end } - | TacInversion (DepInversion (k,c,ids),hyp) -> - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let (sigma,c_interp) = - match c with - | None -> sigma , None - | Some c -> - let (sigma,c_interp) = pf_interp_constr ist gl c in - sigma , Some c_interp - in - let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in - let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) - (Inv.dinv k c_interp ids_interp dqhyps)) sigma - end } - | TacInversion (NonDepInversion (k,idl,ids),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let hyps = interp_hyp_list ist env sigma idl in - let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in - let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in - Tacticals.New.tclWITHHOLES false - (name_atomic ~env - (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) - (Inv.inv_clause k ids_interp hyps dqhyps)) sigma - end } - | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let (sigma,c_interp) = interp_constr ist env sigma c in - let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in - let hyps = interp_hyp_list ist env sigma idl in - let tac = name_atomic ~env - (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) - (Leminv.lemInv_clause dqhyps c_interp hyps) - in - Sigma.Unsafe.of_pair (tac, sigma) - end } - -(* Initial call for interpretation *) - -let default_ist () = - let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in - { lfun = Id.Map.empty; extra = extra } - -let eval_tactic t = - Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) - Proofview.tclLIFT db_initialize <*> - interp_tactic (default_ist ()) t - -let eval_tactic_ist ist t = - Proofview.tclLIFT db_initialize <*> - interp_tactic ist t - -(* globalization + interpretation *) - - -let interp_tac_gen lfun avoid_ids debug t = - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let extra = TacStore.set TacStore.empty f_debug debug in - let extra = TacStore.set extra f_avoid_ids avoid_ids in - let ist = { lfun = lfun; extra = extra } in - let ltacvars = Id.Map.domain lfun in - interp_tactic ist - (intern_pure_tactic { - ltacvars; genv = env } t) - end } - -let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t -let _ = Proof_global.set_interp_tac interp - -(* Used to hide interpretation for pretty-print, now just launch tactics *) -(* [global] means that [t] should be internalized outside of goals. *) -let hide_interp global t ot = - let hide_interp env = - let ist = { ltacvars = Id.Set.empty; genv = env } in - let te = intern_pure_tactic ist t in - let t = eval_tactic te in - match ot with - | None -> t - | Some t' -> Tacticals.New.tclTHEN t t' - in - if global then - Proofview.tclENV >>= fun env -> - hide_interp env - else - Proofview.Goal.enter { enter = begin fun gl -> - hide_interp (Proofview.Goal.env gl) - end } - -(***************************************************************************) -(** Register standard arguments *) - -let def_intern ist x = (ist, x) -let def_subst _ x = x -let def_interp ist x = Ftactic.return x - -let declare_uniform t = - Genintern.register_intern0 t def_intern; - Genintern.register_subst0 t def_subst; - Geninterp.register_interp0 t def_interp - -let () = - declare_uniform wit_unit - -let () = - declare_uniform wit_int - -let () = - declare_uniform wit_bool - -let () = - declare_uniform wit_string - -let () = - declare_uniform wit_pre_ident - -let lift f = (); fun ist x -> Ftactic.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - Ftactic.return (f ist env sigma x) -end } - -let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let (sigma, v) = f ist env sigma x in - Sigma.Unsafe.of_pair (Ftactic.return v, sigma) -end } - -let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> - let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in - Sigma.Unsafe.of_pair (bl, sigma) - } - -let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> - let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in - Sigma.Unsafe.of_pair (c, sigma) - } - -let () = - Geninterp.register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); - Geninterp.register_interp0 wit_ref (lift interp_reference); - Geninterp.register_interp0 wit_ident (lift interp_ident); - Geninterp.register_interp0 wit_var (lift interp_hyp); - Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); - Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); - Geninterp.register_interp0 wit_constr (lifts interp_constr); - Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); - Geninterp.register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); - Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); - Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); - Geninterp.register_interp0 wit_open_constr (lifts interp_open_constr); - Geninterp.register_interp0 wit_bindings interp_bindings'; - Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; - Geninterp.register_interp0 wit_constr_may_eval (lifts interp_constr_may_eval); - () - -let () = - let interp ist tac = Ftactic.return (Value.of_closure ist tac) in - Geninterp.register_interp0 wit_tactic interp - -let () = - let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in - Geninterp.register_interp0 wit_ltac interp - -let () = - Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> - Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) - end }) - -(***************************************************************************) -(* Other entry points *) - -let val_interp ist tac k = Ftactic.run (val_interp ist tac) k - -let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k - -let interp_redexp env sigma r = - let ist = default_ist () in - let gist = { fully_empty_glob_sign with genv = env; } in - interp_red_expr ist env sigma (intern_red_expr gist r) - -(***************************************************************************) -(* Backwarding recursive needs of tactic glob/interp/eval functions *) - -let _ = - let eval ty env sigma lfun arg = - let ist = { lfun = lfun; extra = TacStore.empty; } in - if Genarg.has_type arg (glbwit wit_tactic) then - let tac = Genarg.out_gen (glbwit wit_tactic) arg in - let tac = interp_tactic ist tac in - Pfedit.refine_by_tactic env sigma ty tac - else - failwith "not a tactic" - in - Hook.set Pretyping.genarg_interp_hook eval - -(** Used in tactic extension **) - -let dummy_id = Id.of_string "_" - -let lift_constr_tac_to_ml_tac vars tac = - let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let map = function - | None -> None - | Some id -> - let c = Id.Map.find id ist.lfun in - try Some (coerce_to_closed_constr env c) - with CannotCoerceTo ty -> - error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty - in - let args = List.map_filter map vars in - tac args ist - end } in - tac - -let vernac_debug b = - set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) - -let _ = - let open Goptions in - declare_bool_option - { optsync = false; - optdepr = false; - optname = "Ltac debug"; - optkey = ["Ltac";"Debug"]; - optread = (fun () -> get_debug () != Tactic_debug.DebugOff); - optwrite = vernac_debug } - -let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli deleted file mode 100644 index 31327873e9..0000000000 --- a/tactics/tacinterp.mli +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* t - val to_constr : t -> constr option - val of_int : int -> t - val to_int : t -> int option - val to_list : t -> t list option - val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t - val cast : 'a typed_abstract_argument_type -> Val.t -> 'a -end - -(** Values for interpretation *) -type value = Value.t - -module TacStore : Store.S with - type t = Geninterp.TacStore.t - and type 'a field = 'a Geninterp.TacStore.field - -(** Signature for interpretation: val\_interp and interpretation functions *) -type interp_sign = Geninterp.interp_sign = { - lfun : value Id.Map.t; - extra : TacStore.t } - -val f_avoid_ids : Id.t list TacStore.field -val f_debug : debug_info TacStore.field - -val extract_ltac_constr_values : interp_sign -> Environ.env -> - Pattern.constr_under_binders Id.Map.t -(** Given an interpretation signature, extract all values which are coercible to - a [constr]. *) - -(** Sets the debugger mode *) -val set_debug : debug_info -> unit - -(** Gives the state of debug *) -val get_debug : unit -> debug_info - -(** Adds an interpretation function for extra generic arguments *) - -val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t - -(** Interprets any expression *) -val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic - -(** Interprets an expression that evaluates to a constr *) -val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic - -val type_uconstr : - ?flags:Pretyping.inference_flags -> - ?expected_type:Pretyping.typing_constraint -> - interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open - -(** Interprets redexp arguments *) -val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr - -(** Interprets tactic expressions *) - -val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> - Id.t Loc.located -> Id.t - -val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> - glob_constr_and_expr bindings -> Evd.evar_map * constr bindings - -val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> - glob_constr_and_expr with_bindings -> Evd.evar_map * constr with_bindings - -(** Initial call for interpretation *) - -val eval_tactic : glob_tactic_expr -> unit Proofview.tactic - -val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic -(** Same as [eval_tactic], but with the provided [interp_sign]. *) - -val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic - -(** Globalization + interpretation *) - -val interp_tac_gen : value Id.Map.t -> Id.t list -> - debug_info -> raw_tactic_expr -> unit Proofview.tactic - -val interp : raw_tactic_expr -> unit Proofview.tactic - -(** Hides interpretation for pretty-print *) - -val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic - -(** Internals that can be useful for syntax extensions. *) - -val interp_ltac_var : (value -> 'a) -> interp_sign -> - (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a - -val interp_int : interp_sign -> Id.t Loc.located -> int - -val interp_int_or_var : interp_sign -> int or_var -> int - -val error_ltac_variable : Loc.t -> Id.t -> - (Environ.env * Evd.evar_map) option -> value -> string -> 'a - -(** Transforms a constr-expecting tactic into a tactic finding its arguments in - the Ltac environment according to the given names. *) -val lift_constr_tac_to_ml_tac : Id.t option list -> - (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic - -val default_ist : unit -> Geninterp.interp_sign -(** Empty ist with debug set on the current value. *) diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml deleted file mode 100644 index 4059877b75..0000000000 --- a/tactics/tacsubst.ml +++ /dev/null @@ -1,313 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l) - | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l) - -let subst_glob_with_bindings subst (c,bl) = - (subst_glob_constr subst c, subst_bindings subst bl) - -let subst_glob_with_bindings_arg subst (clear,c) = - (clear,subst_glob_with_bindings subst c) - -let rec subst_intro_pattern subst = function - | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p) - | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x - -and subst_intro_pattern_action subst = function - | IntroApplyOn (t,pat) -> - IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) - | IntroOrAndPattern l -> - IntroOrAndPattern (subst_intro_or_and_pattern subst l) - | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) - | IntroWildcard | IntroRewrite _ as x -> x - -and subst_intro_or_and_pattern subst = function - | IntroAndPattern l -> - IntroAndPattern (List.map (subst_intro_pattern subst) l) - | IntroOrPattern ll -> - IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) - -let subst_induction_arg subst = function - | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) - | clear,ElimOnAnonHyp n as x -> x - | clear,ElimOnIdent id as x -> x - -let subst_and_short_name f (c,n) = -(* assert (n=None); *)(* since tacdef are strictly globalized *) - (f c,None) - -let subst_or_var f = function - | ArgVar _ as x -> x - | ArgArg x -> ArgArg (f x) - -let dloc = Loc.ghost - -let subst_located f (_loc,id) = (dloc,f id) - -let subst_reference subst = - subst_or_var (subst_located (subst_kn subst)) - -(*CSC: subst_global_reference is used "only" for RefArgType, that propagates - to the syntactic non-terminals "global", used in commands such as - Print. It is also used for non-evaluable references. *) -open Pp -open Printer - -let subst_global_reference subst = - let subst_global ref = - let ref',t' = subst_global subst ref in - if not (eq_constr (Universes.constr_of_global ref') t') then - msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ - str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ - pr_global ref') ; - ref' - in - subst_or_var (subst_located subst_global) - -let subst_evaluable subst = - let subst_eval_ref = subst_evaluable_reference subst in - subst_or_var (subst_and_short_name subst_eval_ref) - -let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) - -let subst_glob_constr_or_pattern subst (c,p) = - (subst_glob_constr subst c,subst_pattern subst p) - -let subst_redexp subst = - Miscops.map_red_expr_gen - (subst_glob_constr subst) - (subst_evaluable subst) - (subst_glob_constr_or_pattern subst) - -let subst_raw_may_eval subst = function - | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c) - | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c) - | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c) - | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c) - -let subst_match_pattern subst = function - | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc)) - | Term pc -> Term (subst_glob_constr_or_pattern subst pc) - -let rec subst_match_goal_hyps subst = function - | Hyp (locs,mp) :: tl -> - Hyp (locs,subst_match_pattern subst mp) - :: subst_match_goal_hyps subst tl - | Def (locs,mv,mp) :: tl -> - Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) - :: subst_match_goal_hyps subst tl - | [] -> [] - -let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with - (* Basic tactics *) - | TacIntroPattern l -> TacIntroPattern (List.map (subst_intro_pattern subst) l) - | TacIntroMove _ as x -> x - | TacExact c -> TacExact (subst_glob_constr subst c) - | TacApply (a,ev,cb,cl) -> - TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) - | TacElim (ev,cb,cbo) -> - TacElim (ev,subst_glob_with_bindings_arg subst cb, - Option.map (subst_glob_with_bindings subst) cbo) - | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) - | TacMutualFix (id,n,l) -> - TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) - | TacMutualCofix (id,l) -> - TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) - | TacAssert (b,otac,na,c) -> - TacAssert (b,Option.map (subst_tactic subst) otac,na,subst_glob_constr subst c) - | TacGeneralize cl -> - TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) - | TacLetTac (id,c,clp,b,eqpat) -> - TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) - - (* Derived basic tactics *) - | TacInductionDestruct (isrec,ev,(l,el)) -> - let l' = List.map (fun (c,ids,cls) -> - subst_induction_arg subst c, ids, cls) l in - let el' = Option.map (subst_glob_with_bindings subst) el in - TacInductionDestruct (isrec,ev,(l',el')) - | TacDoubleInduction (h1,h2) as x -> x - - (* Context management *) - | TacRename l as x -> x - - (* Conversion *) - | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) - | TacChange (op,c,cl) -> - TacChange (Option.map (subst_glob_constr_or_pattern subst) op, - subst_glob_constr subst c, cl) - - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite (ev, - List.map (fun (b,m,c) -> - b,m,subst_glob_with_bindings_arg subst c) l, - cl,Option.map (subst_tactic subst) by) - | TacInversion (DepInversion (k,c,l),hyp) -> - TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) - | TacInversion (NonDepInversion _,_) as x -> x - | TacInversion (InversionUsing (c,cl),hyp) -> - TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) - -and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) - | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) - | TacLetIn (r,l,u) -> - let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in - TacLetIn (r,l,subst_tactic subst u) - | TacMatchGoal (lz,lr,lmr) -> - TacMatchGoal(lz,lr, subst_match_rule subst lmr) - | TacMatch (lz,c,lmr) -> - TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr) - | TacId _ | TacFail _ as x -> x - | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr) - | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr) - | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s) - | TacThen (t1,t2) -> - TacThen (subst_tactic subst t1, subst_tactic subst t2) - | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl) - | TacExtendTac (tf,t,tl) -> - TacExtendTac (Array.map (subst_tactic subst) tf, - subst_tactic subst t, - Array.map (subst_tactic subst) tl) - | TacThens (t,tl) -> - TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) - | TacThens3parts (t1,tf,t2,tl) -> - TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf, - subst_tactic subst t2,Array.map (subst_tactic subst) tl) - | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) - | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) - | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac) - | TacTry tac -> TacTry (subst_tactic subst tac) - | TacInfo tac -> TacInfo (subst_tactic subst tac) - | TacRepeat tac -> TacRepeat (subst_tactic subst tac) - | TacOr (tac1,tac2) -> - TacOr (subst_tactic subst tac1,subst_tactic subst tac2) - | TacOnce tac -> - TacOnce (subst_tactic subst tac) - | TacExactlyOnce tac -> - TacExactlyOnce (subst_tactic subst tac) - | TacIfThenCatch (tac,tact,tace) -> - TacIfThenCatch ( - subst_tactic subst tac, - subst_tactic subst tact, - subst_tactic subst tace) - | TacOrelse (tac1,tac2) -> - TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2) - | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) - | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) - | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) - - (* For extensions *) - | TacAlias (_,s,l) -> - let s = subst_kn subst s in - TacAlias (dloc,s,List.map (subst_tacarg subst) l) - | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) - -and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) - -and subst_tacarg subst = function - | Reference r -> Reference (subst_reference subst r) - | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | TacCall (_loc,f,l) -> - TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) - | TacFreshId _ as x -> x - | TacPretype c -> TacPretype (subst_glob_constr subst c) - | TacNumgoals -> TacNumgoals - | Tacexp t -> Tacexp (subst_tactic subst t) - | TacGeneric arg -> TacGeneric (subst_genarg subst arg) - -(* Reads the rules of a Match Context or a Match *) -and subst_match_rule subst = function - | (All tc)::tl -> - (All (subst_tactic subst tc))::(subst_match_rule subst tl) - | (Pat (rl,mp,tc))::tl -> - let hyps = subst_match_goal_hyps subst rl in - let pat = subst_match_pattern subst mp in - Pat (hyps,pat,subst_tactic subst tc) - ::(subst_match_rule subst tl) - | [] -> [] - -and subst_genarg subst (GenArg (Glbwit wit, x)) = - match wit with - | ListArg wit -> - let map x = - let ans = subst_genarg subst (in_gen (glbwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map x) - | OptArg wit -> - let ans = match x with - | None -> in_gen (glbwit (wit_opt wit)) None - | Some x -> - let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in - in_gen (glbwit (wit_opt wit)) (Some s) - in - ans - | PairArg (wit1, wit2) -> - let p, q = x in - let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in - let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - | ExtraArg s -> - Genintern.generic_substitute subst (in_gen (glbwit wit) x) - -(** Registering *) - -let () = - Genintern.register_subst0 wit_int_or_var (fun _ v -> v); - Genintern.register_subst0 wit_ref subst_global_reference; - Genintern.register_subst0 wit_ident (fun _ v -> v); - Genintern.register_subst0 wit_var (fun _ v -> v); - Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); - Genintern.register_subst0 wit_tactic subst_tactic; - Genintern.register_subst0 wit_ltac subst_tactic; - Genintern.register_subst0 wit_constr subst_glob_constr; - Genintern.register_subst0 wit_sort (fun _ v -> v); - Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); - Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); - Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); - Genintern.register_subst0 wit_red_expr subst_redexp; - Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; - Genintern.register_subst0 wit_bindings subst_bindings; - Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; - Genintern.register_subst0 wit_constr_may_eval subst_raw_may_eval; - () diff --git a/tactics/tacsubst.mli b/tactics/tacsubst.mli deleted file mode 100644 index c1bf272579..0000000000 --- a/tactics/tacsubst.mli +++ /dev/null @@ -1,30 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glob_tactic_expr -> glob_tactic_expr - -(** For generic arguments, we declare and store substitutions - in a table *) - -val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument - -(** Misc *) - -val subst_glob_constr_and_expr : - substitution -> glob_constr_and_expr -> glob_constr_and_expr - -val subst_glob_with_bindings : substitution -> - glob_constr_and_expr with_bindings -> - glob_constr_and_expr with_bindings diff --git a/tactics/tactic_debug.ml b/tactics/tactic_debug.ml deleted file mode 100644 index d661f9677c..0000000000 --- a/tactics/tactic_debug.ml +++ /dev/null @@ -1,412 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Printer.pr_constr_pattern p) rl - -(* This module intends to be a beginning of debugger for tactic expressions. - Currently, it is quite simple and we can hope to have, in the future, a more - complete panel of commands dedicated to a proof assistant framework *) - -(* Debug information *) -type debug_info = - | DebugOn of int - | DebugOff - -(* An exception handler *) -let explain_logic_error e = - Errors.print (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) - -let explain_logic_error_no_anomaly e = - Errors.print_no_report (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) - -let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) -let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) - -(* Prints the goal *) - -let db_pr_goal gl = - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let penv = print_named_context env in - let pc = print_constr_env env concl in - str" " ++ hv 0 (penv ++ fnl () ++ - str "============================" ++ fnl () ++ - str" " ++ pc) ++ fnl () - -let db_pr_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let pg = db_pr_goal gl in - Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) - end } - - -(* Prints the commands *) -let help () = - msg_tac_debug (str "Commands: = Continue" ++ fnl() ++ - str " h/? = Help" ++ fnl() ++ - str " r = Run times" ++ fnl() ++ - str " r = Run up to next idtac " ++ fnl() ++ - str " s = Skip" ++ fnl() ++ - str " x = Exit") - -(* Prints the goal and the command to be executed *) -let goal_com tac = - Proofview.tclTHEN - db_pr_goal - (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) - -(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] - expressions. It avoids parametrizing everything over a - reference. *) -let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) -let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) - -let rec drop_spaces inst i = - if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) - else i - -let possibly_unquote s = - if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then - String.sub s 1 (String.length s - 2) - else - s - -(* (Re-)initialize debugger *) -let db_initialize = - let open Proofview.NonLogical in - (skip:=0) >> (skipped:=0) >> (breakpoint:=None) - -let int_of_string s = - try Proofview.NonLogical.return (int_of_string s) - with e -> Proofview.NonLogical.raise e - -let string_get s i = - try Proofview.NonLogical.return (String.get s i) - with e -> Proofview.NonLogical.raise e - -(* Gives the number of steps or next breakpoint of a run command *) -let run_com inst = - let open Proofview.NonLogical in - string_get inst 0 >>= fun first_char -> - if first_char ='r' then - let i = drop_spaces inst 1 in - if String.length inst > i then - let s = String.sub inst i (String.length inst - i) in - if inst.[0] >= '0' && inst.[0] <= '9' then - int_of_string s >>= fun num -> - (if num<0 then invalid_arg "run_com" else return ()) >> - (skip:=num) >> (skipped:=0) - else - breakpoint:=Some (possibly_unquote s) - else - invalid_arg "run_com" - else - invalid_arg "run_com" - -(* Prints the run counter *) -let run ini = - let open Proofview.NonLogical in - if not ini then - begin - Proofview.NonLogical.print_notice (str"\b\r\b\r") >> - !skipped >>= fun skipped -> - msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) - end >> - !skipped >>= fun x -> - skipped := x+1 - else - return () - -(* Prints the prompt *) -let rec prompt level = - (* spiwack: avoid overriding by the open below *) - let runtrue = run true in - begin - let open Proofview.NonLogical in - Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> - let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in - Proofview.NonLogical.catch Proofview.NonLogical.read_line - begin function (e, info) -> match e with - | End_of_file -> exit - | e -> raise ~info e - end - >>= fun inst -> - match inst with - | "" -> return (DebugOn (level+1)) - | "s" -> return (DebugOff) - | "x" -> Proofview.NonLogical.print_char '\b' >> exit - | "h"| "?" -> - begin - help () >> - prompt level - end - | _ -> - Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) - begin function (e, info) -> match e with - | Failure _ | Invalid_argument _ -> prompt level - | e -> raise ~info e - end - end - -(* Prints the state and waits for an instruction *) -(* spiwack: the only reason why we need to take the continuation [f] - as an argument rather than returning the new level directly seems to - be that [f] is wrapped in with "explain_logic_error". I don't think - it serves any purpose in the current design, so we could just drop - that. *) -let debug_prompt lev tac f = - (* spiwack: avoid overriding by the open below *) - let runfalse = run false in - let open Proofview.NonLogical in - let (>=) = Proofview.tclBIND in - (* What to print and to do next *) - let newlevel = - Proofview.tclLIFT !skip >= fun initial_skip -> - if Int.equal initial_skip 0 then - Proofview.tclLIFT !breakpoint >= fun breakpoint -> - if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) - else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) - else Proofview.tclLIFT begin - (!skip >>= fun s -> skip:=s-1) >> - runfalse >> - !skip >>= fun new_skip -> - (if Int.equal new_skip 0 then skipped:=0 else return ()) >> - return (DebugOn (lev+1)) - end in - newlevel >= fun newlevel -> - (* What to execute *) - Proofview.tclOR - (f newlevel) - begin fun (reraise, info) -> - Proofview.tclTHEN - (Proofview.tclLIFT begin - (skip:=0) >> (skipped:=0) >> - if Logic.catchable_exception reraise then - msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) - else return () - end) - (Proofview.tclZERO ~info reraise) - end - -let is_debug db = - let open Proofview.NonLogical in - !breakpoint >>= fun breakpoint -> - match db, breakpoint with - | DebugOff, _ -> return false - | _, Some _ -> return false - | _ -> - !skip >>= fun skip -> - return (Int.equal skip 0) - -(* Prints a constr *) -let db_constr debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c) - else return () - -(* Prints the pattern rule *) -let db_pattern_rule debug num r = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ prmatchrl r) - end - else return () - -(* Prints the hypothesis pattern identifier if it exists *) -let hyp_bound = function - | Anonymous -> str " (unbound)" - | Name id -> str " (bound to " ++ pr_id id ++ str ")" - -(* Prints a matched hypothesis *) -let db_matched_hyp debug env (id,_,c) ido = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ - str " has been matched: " ++ print_constr_env env c) - else return () - -(* Prints the matched conclusion *) -let db_matched_concl debug env c = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c) - else return () - -(* Prints a success message when the goal has been matched *) -let db_mc_pattern_success debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ - str "Let us execute the right-hand side part..." ++ fnl()) - else return () - -(* Prints a failure message for an hypothesis pattern *) -let db_hyp_pattern_failure debug env sigma (na,hyp) = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ - str " cannot match: " ++ - prmatchpatt env sigma hyp) - else return () - -(* Prints a matching failure message for a rule *) -let db_matching_failure debug = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ - str "Let us try the next one...") - else return () - -(* Prints an evaluation failure message for a rule *) -let db_eval_failure debug s = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - let s = str "message \"" ++ s ++ str "\"" in - msg_tac_debug - (str "This rule has failed due to \"Fail\" tactic (" ++ - s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") - else return () - -(* Prints a logic failure message for a rule *) -let db_logic_failure debug err = - let open Proofview.NonLogical in - is_debug debug >>= fun db -> - if db then - begin - msg_tac_debug (explain_logic_error err) >> - msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ - str "Let us try the next one...") - end - else return () - -let is_breakpoint brkname s = match brkname, s with - | Some s, MsgString s'::_ -> String.equal s s' - | _ -> false - -let db_breakpoint debug s = - let open Proofview.NonLogical in - !breakpoint >>= fun opt_breakpoint -> - match debug with - | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> - breakpoint:=None - | _ -> - return () - -(** Extrating traces *) - -let is_defined_ltac trace = - let rec aux = function - | (_, Tacexpr.LtacNameCall f) :: tail -> - not (Tacenv.is_ltac_for_ml_tactic f) - | (_, Tacexpr.LtacAtomCall _) :: tail -> - false - | _ :: tail -> aux tail - | [] -> false in - aux (List.rev trace) - -let explain_ltac_call_trace last trace loc = - let calls = last :: List.rev_map snd trace in - let pr_call ck = match ck with - | Tacexpr.LtacNotationCall kn -> quote (KerName.print kn) - | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) - | Tacexpr.LtacMLCall t -> - quote (Pptactic.pr_glob_tactic (Global.env()) t) - | Tacexpr.LtacVarCall (id,t) -> - quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ - Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" - | Tacexpr.LtacAtomCall te -> - quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.ghost,te))) - | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> - quote (Printer.pr_glob_constr_env (Global.env()) c) ++ - (if not (Id.Map.is_empty vars) then - strbrk " (with " ++ - prlist_with_sep pr_comma - (fun (id,c) -> - pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) - (List.rev (Id.Map.bindings vars)) ++ str ")" - else mt()) - in - match calls with - | [] -> mt () - | _ -> - let kind_of_last_call = match List.last calls with - | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." - | _ -> ", last call failed." - in - hov 0 (str "In nested Ltac calls to " ++ - pr_enum pr_call calls ++ strbrk kind_of_last_call) - -let skip_extensions trace = - let rec aux = function - | (_,Tacexpr.LtacNameCall f as tac) :: _ - when Tacenv.is_ltac_for_ml_tactic f -> [tac] - | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) - :: _ -> [tac] - | t :: tail -> t :: aux tail - | [] -> [] in - List.rev (aux (List.rev trace)) - -let extract_ltac_trace trace eloc = - let trace = skip_extensions trace in - let (loc,c),tail = List.sep_last trace in - if is_defined_ltac trace then - (* We entered a user-defined tactic, - we display the trace with location of the call *) - let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in - Some msg, loc - else - (* We entered a primitive tactic, we don't display trace but - report on the finest location *) - let best_loc = - if not (Loc.is_ghost eloc) then eloc else - (* trace is with innermost call coming first *) - let rec aux = function - | (loc,_)::tail when not (Loc.is_ghost loc) -> loc - | _::tail -> aux tail - | [] -> Loc.ghost in - aux trace in - None, best_loc - -let get_ltac_trace (_, info) = - let ltac_trace = Exninfo.get info ltac_trace_info in - let loc = Option.default Loc.ghost (Loc.get_loc info) in - match ltac_trace with - | None -> None - | Some trace -> Some (extract_ltac_trace trace loc) - -let () = Cerrors.register_additional_error_info get_ltac_trace diff --git a/tactics/tactic_debug.mli b/tactics/tactic_debug.mli deleted file mode 100644 index 520fb41eff..0000000000 --- a/tactics/tactic_debug.mli +++ /dev/null @@ -1,80 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic - -(** Initializes debugger *) -val db_initialize : unit Proofview.NonLogical.t - -(** Prints a constr *) -val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints the pattern rule *) -val db_pattern_rule : - debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t - -(** Prints a matched hypothesis *) -val db_matched_hyp : - debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t - -(** Prints the matched conclusion *) -val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t - -(** Prints a success message when the goal has been matched *) -val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t - -(** Prints a failure message for an hypothesis pattern *) -val db_hyp_pattern_failure : - debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t - -(** Prints a matching failure message for a rule *) -val db_matching_failure : debug_info -> unit Proofview.NonLogical.t - -(** Prints an evaluation failure message for a rule *) -val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t - -(** An exception handler *) -val explain_logic_error: exn -> Pp.std_ppcmds - -(** For use in the Ltac debugger: some exception that are usually - consider anomalies are acceptable because they are caught later in - the process that is being debugged. One should not require - from users that they report these anomalies. *) -val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds - -(** Prints a logic failure message for a rule *) -val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t - -(** Prints a logic failure message for a rule *) -val db_breakpoint : debug_info -> - Id.t Loc.located message_token list -> unit Proofview.NonLogical.t - -val extract_ltac_trace : - Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml deleted file mode 100644 index a5ba3b8371..0000000000 --- a/tactics/tactic_option.ml +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = - declare_object - { (default_object name) with - cache_function = cache; - load_function = (fun _ -> load); - open_function = (fun _ -> load); - classify_function = (fun (local, tac) -> - if local then Dispose else Substitute (local, tac)); - subst_function = subst} - in - let put local tac = - set_default_tactic local tac; - Lib.add_anonymous_leaf (input (local, tac)) - in - let get () = !locality, Tacinterp.eval_tactic !default_tactic in - let print () = - Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ - (if !locality then str" (locally defined)" else str" (globally defined)") - in - put, get, print diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli deleted file mode 100644 index ed759a76db..0000000000 --- a/tactics/tactic_option.mli +++ /dev/null @@ -1,15 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* string -> - (* put *) (locality_flag -> glob_tactic_expr -> unit) * - (* get *) (unit -> locality_flag * unit Proofview.tactic) * - (* print *) (unit -> Pp.std_ppcmds) diff --git a/tactics/tauto.ml b/tactics/tauto.ml deleted file mode 100644 index a86fdb98a9..0000000000 --- a/tactics/tauto.ml +++ /dev/null @@ -1,282 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* c - | None -> failwith "tauto: anomaly" - -(** Parametrization of tauto *) - -type tauto_flags = { - -(* Whether conjunction and disjunction are restricted to binary connectives *) - binary_mode : bool; - -(* Whether compatibility for buggy detection of binary connective is on *) - binary_mode_bugged_detection : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* contravariant position in an hypothesis *) - strict_in_contravariant_hyp : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* an hypothesis and in the conclusion *) - strict_in_hyp_and_ccl : bool; - -(* Whether unit type includes equality types *) - strict_unit : bool; -} - -let wit_tauto_flags : tauto_flags uniform_genarg_type = - Genarg.create_arg "tauto_flags" - -let assoc_flags ist = - let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in - try Value.cast (topwit wit_tauto_flags) v with _ -> assert false - -(* Whether inner not are unfolded *) -let negation_unfolding = ref true - -(* Whether inner iff are unfolded *) -let iff_unfolding = ref false - -let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 - -open Goptions -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of not in intuition"; - optkey = ["Intuition";"Negation";"Unfolding"]; - optread = (fun () -> !negation_unfolding); - optwrite = (:=) negation_unfolding } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of iff in intuition"; - optkey = ["Intuition";"Iff";"Unfolding"]; - optread = (fun () -> !iff_unfolding); - optwrite = (:=) iff_unfolding } - -(** Base tactics *) - -let loc = Loc.ghost -let idtac = Proofview.tclUNIT () -let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) - -let intro = Tactics.intro - -let assert_ ?by c = - let tac = match by with - | None -> None - | Some tac -> Some (tclCOMPLETE tac) - in - Proofview.tclINDEPENDENT (Tactics.forward true tac None c) - -let apply c = Tactics.apply c - -let clear id = Proofview.V82.tactic (fun gl -> Tactics.clear [id] gl) - -let assumption = Tactics.assumption - -let split = Tactics.split_with_bindings false [Misctypes.NoBindings] - -(** Test *) - -let is_empty _ ist = - if is_empty_type (assoc_var "X1" ist) then idtac else fail - -(* Strictly speaking, this exceeds the propositional fragment as it - matches also equality types (and solves them if a reflexivity) *) -let is_unit_or_eq _ ist = - let flags = assoc_flags ist in - let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test (assoc_var "X1" ist) then idtac else fail - -let bugged_is_binary t = - isApp t && - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind (ind,u) -> - let (mib,mip) = Global.lookup_inductive ind in - Int.equal mib.Declarations.mind_nparams 2 - | _ -> false - -(** Dealing with conjunction *) - -let is_conj _ ist = - let flags = assoc_flags ist in - let ind = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && - is_conjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode ind - then idtac - else fail - -let flatten_contravariant_conj _ ist = - let flags = assoc_flags ist in - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_conjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode typ - with - | Some (_,args) -> - let newtyp = List.fold_right mkArrow args c in - let intros = tclMAP (fun _ -> intro) args in - let by = tclTHENLIST [intros; apply hyp; split; assumption] in - tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] - | _ -> fail - -(** Dealing with disjunction *) - -let is_disj _ ist = - let flags = assoc_flags ist in - let t = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && - is_disjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode t - then idtac - else fail - -let flatten_contravariant_disj _ ist = - let flags = assoc_flags ist in - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_disjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode - typ with - | Some (_,args) -> - let map i arg = - let typ = mkArrow arg c in - let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in - let by = tclTHENLIST [intro; apply hyp; ci; assumption] in - assert_ ~by typ - in - let tacs = List.mapi map args in - let tac0 = clear (destVar hyp) in - tclTHEN (tclTHENLIST tacs) tac0 - | _ -> fail - -let make_unfold name = - let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in - let const = Constant.make2 (MPfile dir) (Label.make name) in - (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) - -let u_iff = make_unfold "iff" -let u_not = make_unfold "not" - -let reduction_not_iff _ ist = - let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in - let tac = match !negation_unfolding, unfold_iff () with - | true, true -> make_reduce [u_not; u_iff] - | true, false -> make_reduce [u_not] - | false, true -> make_reduce [u_iff] - | false, false -> TacId [] - in - eval_tactic_ist ist tac - -let coq_nnpp_path = - let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in - Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") - -let apply_nnpp _ ist = - Proofview.tclBIND - (Proofview.tclUNIT ()) - begin fun () -> try - let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in - apply nnpp - with Not_found -> tclFAIL 0 (Pp.mt ()) - end - -(* This is the uniform mode dealing with ->, not, iff and types isomorphic to - /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. - For the moment not and iff are still always unfolded. *) -let tauto_uniform_unit_flags = { - binary_mode = true; - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = true; - strict_unit = false -} - -(* This is the compatibility mode (not used) *) -let tauto_legacy_flags = { - binary_mode = true; - binary_mode_bugged_detection = true; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -(* This is the improved mode *) -let tauto_power_flags = { - binary_mode = false; (* support n-ary connectives *) - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = false; (* supports non-regular connectives *) - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -let with_flags flags _ ist = - let f = (loc, Id.of_string "f") in - let x = (loc, Id.of_string "x") in - let arg = Val.Dyn (val_tag (topwit wit_tauto_flags), flags) in - let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in - eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) - -let register_tauto_tactic tac name0 args = - let ids = List.map (fun id -> Id.of_string id) args in - let ids = List.map (fun id -> Some id) ids in - let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in - let entry = { mltac_name = name; mltac_index = 0 } in - let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (loc, entry, [])) in - let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in - Mltop.declare_cache_obj obj tauto_plugin - -let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] -let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] -let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] -let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] -let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] -let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] -let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] -let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] -let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] -let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] diff --git a/tactics/tauto.mli b/tactics/tauto.mli deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 147759f5fc..f1ad2c2624 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -456,8 +456,8 @@ let variables is_install opt (args,defs) = -I \"$(COQLIB)library\" -I \"$(COQLIB)parsing\" -I \"$(COQLIB)engine\" -I \"$(COQLIB)pretyping\" \\ -I \"$(COQLIB)interp\" -I \"$(COQLIB)printing\" -I \"$(COQLIB)intf\" \\ -I \"$(COQLIB)proofs\" -I \"$(COQLIB)tactics\" -I \"$(COQLIB)tools\" \\ - -I \"$(COQLIB)toplevel\" -I \"$(COQLIB)stm\" -I \"$(COQLIB)grammar\" \\ - -I \"$(COQLIB)config\""; + -I \"$(COQLIB)toplevel\" -I \"$(COQLIB)ltac\" -I \"$(COQLIB)stm\" \\ + -I \"$(COQLIB)grammar\" -I \"$(COQLIB)config\""; List.iter (fun c -> print " \\ -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n"; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n"; -- cgit v1.2.3 From 920f1548e9245ddfc8b923c5039a5e09dc0c87d4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 31 Jul 2015 18:53:21 +0200 Subject: Adding eq/compare/hash for syntactic view at constant/inductive/constructor kernel_name pairs rather than viewing them from only the user or canonical part. Hopefully more uniformity in Constr.hasheq (using systematically == on subterms). A semantic change: Cooking now indexing again on full pairs of kernel names rather than only on the canonical names, so as to preserve user name. Also, in pair of kernel names, ensuring the compact representation is used as soon as both names are the same. --- kernel/constr.ml | 20 +++++++++----------- kernel/cooking.ml | 12 ++++++------ kernel/names.ml | 42 +++++++++++++++++++++++++++++++++++++++++- kernel/names.mli | 26 +++++++++++++++++++++++++- 4 files changed, 81 insertions(+), 19 deletions(-) diff --git a/kernel/constr.ml b/kernel/constr.ml index 7e103b1dab..2a80cf2016 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -732,12 +732,10 @@ let hasheq t1 t2 = n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2 - | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && array_eqeq l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && array_eqeq l1 l2 | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 - | Ind ((sp1,i1),u1), Ind ((sp2,i2),u2) -> - sp1 == sp2 && Int.equal i1 i2 && u1 == u2 - | Construct (((sp1,i1),j1),u1), Construct (((sp2,i2),j2),u2) -> - sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 && u1 == u2 + | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 + | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> @@ -815,19 +813,19 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Proj (p,c) -> let c, hc = sh_rec c in let p' = Projection.hcons p in - (Proj (p', c), combinesmall 17 (combine (Projection.hash p') hc)) + (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.hash p') hc)) | Const (c,u) -> let c' = sh_con c in let u', hu = sh_instance u in - (Const (c', u'), combinesmall 9 (combine (Constant.hash c) hu)) - | Ind ((kn,i) as ind,u) -> + (Const (c', u'), combinesmall 9 (combine (Constant.SyntacticOrd.hash c) hu)) + | Ind (ind,u) -> let u', hu = sh_instance u in (Ind (sh_ind ind, u'), - combinesmall 10 (combine (ind_hash ind) hu)) - | Construct ((((kn,i),j) as c,u))-> + combinesmall 10 (combine (ind_syntactic_hash ind) hu)) + | Construct (c,u) -> let u', hu = sh_instance u in (Construct (sh_construct c, u'), - combinesmall 11 (combine (constructor_hash c) hu)) + combinesmall 11 (combine (constructor_syntactic_hash c) hu)) | Case (ci,p,c,bl) -> let p, hp = sh_rec p and c, hc = sh_rec c in diff --git a/kernel/cooking.ml b/kernel/cooking.ml index f0e9255824..9476e8a839 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -44,15 +44,15 @@ module RefHash = struct type t = my_global_reference let equal gr1 gr2 = match gr1, gr2 with - | ConstRef c1, ConstRef c2 -> Constant.CanOrd.equal c1 c2 - | IndRef i1, IndRef i2 -> eq_ind i1 i2 - | ConstructRef c1, ConstructRef c2 -> eq_constructor c1 c2 + | ConstRef c1, ConstRef c2 -> Constant.SyntacticOrd.equal c1 c2 + | IndRef i1, IndRef i2 -> eq_syntactic_ind i1 i2 + | ConstructRef c1, ConstructRef c2 -> eq_syntactic_constructor c1 c2 | _ -> false open Hashset.Combine let hash = function - | ConstRef c -> combinesmall 1 (Constant.hash c) - | IndRef i -> combinesmall 2 (ind_hash i) - | ConstructRef c -> combinesmall 3 (constructor_hash c) + | ConstRef c -> combinesmall 1 (Constant.SyntacticOrd.hash c) + | IndRef i -> combinesmall 2 (ind_syntactic_hash i) + | ConstructRef c -> combinesmall 3 (constructor_syntactic_hash c) end module RefTable = Hashtbl.Make(RefHash) diff --git a/kernel/names.ml b/kernel/names.ml index f5d954e9ce..e9cb9fd74c 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -477,7 +477,7 @@ module KerPair = struct | Dual (kn,_) -> kn let same kn = Same kn - let make knu knc = if knu == knc then Same knc else Dual (knu,knc) + let make knu knc = if KerName.equal knu knc then Same knc else Dual (knu,knc) let make1 = same let make2 mp l = same (KerName.make2 mp l) @@ -524,6 +524,23 @@ module KerPair = struct let hash x = KerName.hash (canonical x) end + module SyntacticOrd = struct + type t = kernel_pair + let compare x y = match x, y with + | Same knx, Same kny -> KerName.compare knx kny + | Dual (knux,kncx), Dual (knuy,kncy) -> + let c = KerName.compare knux knuy in + if not (Int.equal c 0) then c + else KerName.compare kncx kncy + | Same _, _ -> -1 + | Dual _, _ -> 1 + let equal x y = x == y || compare x y = 0 + let hash = function + | Same kn -> KerName.hash kn + | Dual (knu, knc) -> + Hashset.Combine.combine (KerName.hash knu) (KerName.hash knc) + end + (** Default (logical) comparison and hash is on the canonical part *) let equal = CanOrd.equal let hash = CanOrd.hash @@ -590,6 +607,8 @@ let index_of_constructor (ind, i) = i let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2 let eq_user_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2 +let eq_syntactic_ind (m1, i1) (m2, i2) = + Int.equal i1 i2 && MutInd.SyntacticOrd.equal m1 m2 let ind_ord (m1, i1) (m2, i2) = let c = Int.compare i1 i2 in @@ -597,15 +616,22 @@ let ind_ord (m1, i1) (m2, i2) = let ind_user_ord (m1, i1) (m2, i2) = let c = Int.compare i1 i2 in if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c +let ind_syntactic_ord (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.SyntacticOrd.compare m1 m2 else c let ind_hash (m, i) = Hashset.Combine.combine (MutInd.hash m) (Int.hash i) let ind_user_hash (m, i) = Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i) +let ind_syntactic_hash (m, i) = + Hashset.Combine.combine (MutInd.SyntacticOrd.hash m) (Int.hash i) let eq_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_ind ind1 ind2 let eq_user_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_user_ind ind1 ind2 +let eq_syntactic_constructor (ind1, j1) (ind2, j2) = + Int.equal j1 j2 && eq_syntactic_ind ind1 ind2 let constructor_ord (ind1, j1) (ind2, j2) = let c = Int.compare j1 j2 in @@ -613,11 +639,16 @@ let constructor_ord (ind1, j1) (ind2, j2) = let constructor_user_ord (ind1, j1) (ind2, j2) = let c = Int.compare j1 j2 in if Int.equal c 0 then ind_user_ord ind1 ind2 else c +let constructor_syntactic_ord (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then ind_syntactic_ord ind1 ind2 else c let constructor_hash (ind, i) = Hashset.Combine.combine (ind_hash ind) (Int.hash i) let constructor_user_hash (ind, i) = Hashset.Combine.combine (ind_user_hash ind) (Int.hash i) +let constructor_syntactic_hash (ind, i) = + Hashset.Combine.combine (ind_syntactic_hash ind) (Int.hash i) module InductiveOrdered = struct type t = inductive @@ -805,6 +836,15 @@ struct let hash (c, b) = (if b then 0 else 1) + Constant.hash c + module SyntacticOrd = struct + type t = constant * bool + let compare (c, b) (c', b') = + if b = b' then Constant.SyntacticOrd.compare c c' else -1 + let equal (c, b as x) (c', b' as x') = + x == x' || b = b' && Constant.SyntacticOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c + end + module Self_Hashcons = struct type _t = t diff --git a/kernel/names.mli b/kernel/names.mli index 1e79f4dde4..6cfbca7baa 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -307,6 +307,12 @@ sig val hash : t -> int end + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + val equal : t -> t -> bool (** Default comparison, alias for [CanOrd.equal] *) @@ -381,6 +387,12 @@ sig val hash : t -> int end + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + val equal : t -> t -> bool (** Default comparison, alias for [CanOrd.equal] *) @@ -419,16 +431,22 @@ val inductive_of_constructor : constructor -> inductive val index_of_constructor : constructor -> int val eq_ind : inductive -> inductive -> bool val eq_user_ind : inductive -> inductive -> bool +val eq_syntactic_ind : inductive -> inductive -> bool val ind_ord : inductive -> inductive -> int val ind_hash : inductive -> int val ind_user_ord : inductive -> inductive -> int val ind_user_hash : inductive -> int +val ind_syntactic_ord : inductive -> inductive -> int +val ind_syntactic_hash : inductive -> int val eq_constructor : constructor -> constructor -> bool val eq_user_constructor : constructor -> constructor -> bool +val eq_syntactic_constructor : constructor -> constructor -> bool val constructor_ord : constructor -> constructor -> int -val constructor_user_ord : constructor -> constructor -> int val constructor_hash : constructor -> int +val constructor_user_ord : constructor -> constructor -> int val constructor_user_hash : constructor -> int +val constructor_syntactic_ord : constructor -> constructor -> int +val constructor_syntactic_hash : constructor -> int (** Better to have it here that in Closure, since required in grammar.cma *) type evaluable_global_reference = @@ -642,6 +660,12 @@ module Projection : sig val make : constant -> bool -> t + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + val constant : t -> constant val unfolded : t -> bool val unfold : t -> t -- cgit v1.2.3 From 2e557589920156fe84335e72c5e765347bcc7c9c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 2 Aug 2015 14:45:24 +0200 Subject: A patch renaming equal into eq in the module dealing with hash-consing, so as to avoid having too many kinds of equalities with same name. --- checker/univ.ml | 14 +++++++------- kernel/constr.ml | 8 ++++---- kernel/names.ml | 16 ++++++++-------- kernel/sorts.ml | 2 +- kernel/univ.ml | 22 +++++++++++----------- lib/cSet.ml | 2 +- lib/hashcons.ml | 12 ++++++------ lib/hashcons.mli | 12 ++++++------ lib/hashset.ml | 4 ++-- lib/hashset.mli | 2 +- 10 files changed, 47 insertions(+), 47 deletions(-) diff --git a/checker/univ.ml b/checker/univ.ml index cb2eaced77..96d8270137 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -33,7 +33,7 @@ module type Hashconsed = sig type t val hash : t -> int - val equal : t -> t -> bool + val eq : t -> t -> bool val hcons : t -> t end @@ -51,7 +51,7 @@ struct type t = _t type u = (M.t -> M.t) let hash = function Nil -> 0 | Cons (_, h, _) -> h - let equal l1 l2 = match l1, l2 with + let eq l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 | _ -> false @@ -131,7 +131,7 @@ module HList = struct let rec remove x = function | Nil -> nil | Cons (y, _, l) -> - if H.equal x y then l + if H.eq x y then l else cons y (remove x l) end @@ -229,7 +229,7 @@ module Level = struct type _t = t type t = _t type u = unit - let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data + let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash let hashcons () x = let data' = RawLevel.hcons x.data in @@ -320,7 +320,7 @@ struct let hashcons hdir (b,n as x) = let b' = hdir b in if b' == b then x else (b',n) - let equal l1 l2 = + let eq l1 l2 = l1 == l2 || match l1,l2 with | (b,n), (b',n') -> b == b' && n == n' @@ -339,7 +339,7 @@ struct let hcons = Hashcons.simple_hcons H.generate H.hcons Level.hcons let hash = ExprHash.hash - let equal x y = x == y || + let eq x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) @@ -1089,7 +1089,7 @@ struct a end - let equal t1 t2 = + let eq t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = diff --git a/kernel/constr.ml b/kernel/constr.ml index 2a80cf2016..db457f28ce 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -755,10 +755,10 @@ let hasheq t1 t2 = once and for all the table we'll use for hash-consing all constr *) module HashsetTerm = - Hashset.Make(struct type t = constr let equal = hasheq end) + Hashset.Make(struct type t = constr let eq = hasheq end) module HashsetTermArray = - Hashset.Make(struct type t = constr array let equal = array_eqeq end) + Hashset.Make(struct type t = constr array let eq = array_eqeq end) let term_table = HashsetTerm.create 19991 (* The associative table to hashcons terms. *) @@ -928,7 +928,7 @@ struct List.equal (==) info1.ind_tags info2.ind_tags && Array.equal (List.equal (==)) info1.cstr_tags info2.cstr_tags && info1.style == info2.style - let equal ci ci' = + let eq ci ci' = ci.ci_ind == ci'.ci_ind && Int.equal ci.ci_npar ci'.ci_npar && Array.equal Int.equal ci.ci_cstr_ndecls ci'.ci_cstr_ndecls && (* we use [Array.equal] on purpose *) @@ -970,7 +970,7 @@ module Hsorts = let hashcons huniv = function Prop c -> Prop c | Type u -> Type (huniv u) - let equal s1 s2 = + let eq s1 s2 = s1 == s2 || match (s1,s2) with (Prop c1, Prop c2) -> c1 == c2 diff --git a/kernel/names.ml b/kernel/names.ml index e9cb9fd74c..d8e91cfab7 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -102,7 +102,7 @@ struct let hashcons hident = function | Name id -> Name (hident id) | n -> n - let equal n1 n2 = + let eq n1 n2 = n1 == n2 || match (n1,n2) with | (Name id1, Name id2) -> id1 == id2 @@ -236,7 +236,7 @@ struct type t = _t type u = (Id.t -> Id.t) * (DirPath.t -> DirPath.t) let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) - let equal ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = + let eq ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = (x == y) || (Int.equal n1 n2 && s1 == s2 && dir1 == dir2) let hash = hash @@ -327,7 +327,7 @@ module ModPath = struct | MPfile dir -> MPfile (hdir dir) | MPbound m -> MPbound (huniqid m) | MPdot (md,l) -> MPdot (hashcons hfuns md, hstr l) - let rec equal d1 d2 = + let rec eq d1 d2 = d1 == d2 || match d1,d2 with | MPfile dir1, MPfile dir2 -> dir1 == dir2 @@ -423,7 +423,7 @@ module KerName = struct let hashcons (hmod,hdir,hstr) kn = let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; } - let equal kn1 kn2 = + let eq kn1 kn2 = kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath && kn1.knlabel == kn2.knlabel let hash = hash @@ -552,7 +552,7 @@ module KerPair = struct let hashcons hkn = function | Same kn -> Same (hkn kn) | Dual (knu,knc) -> make (hkn knu) (hkn knc) - let equal x y = (* physical comparison on subterms *) + let eq x y = (* physical comparison on subterms *) x == y || match x,y with | Same x, Same y -> x == y @@ -693,7 +693,7 @@ module Hind = Hashcons.Make( type t = inductive type u = MutInd.t -> MutInd.t let hashcons hmind (mind, i) = (hmind mind, i) - let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2 + let eq (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2 let hash = ind_hash end) @@ -702,7 +702,7 @@ module Hconstruct = Hashcons.Make( type t = constructor type u = inductive -> inductive let hashcons hind (ind, j) = (hind ind, j) - let equal (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2 + let eq (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2 let hash = constructor_hash end) @@ -851,7 +851,7 @@ struct type t = _t type u = Constant.t -> Constant.t let hashcons hc (c,b) = (hc c,b) - let equal ((c,b) as x) ((c',b') as y) = + let eq ((c,b) as x) ((c',b') as y) = x == y || (c == c' && b == b') let hash = hash end diff --git a/kernel/sorts.ml b/kernel/sorts.ml index a907368845..62013b38f1 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -98,7 +98,7 @@ module Hsorts = let u' = huniv u in if u' == u then c else Type u' | s -> s - let equal s1 s2 = match (s1,s2) with + let eq s1 s2 = match (s1,s2) with | (Prop c1, Prop c2) -> c1 == c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false diff --git a/kernel/univ.ml b/kernel/univ.ml index 21ffafedb4..117bc4e5fd 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -35,7 +35,7 @@ module type Hashconsed = sig type t val hash : t -> int - val equal : t -> t -> bool + val eq : t -> t -> bool val hcons : t -> t end @@ -53,7 +53,7 @@ struct type t = _t type u = (M.t -> M.t) let hash = function Nil -> 0 | Cons (_, h, _) -> h - let equal l1 l2 = match l1, l2 with + let eq l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 | _ -> false @@ -135,12 +135,12 @@ module HList = struct let rec remove x = function | Nil -> nil | Cons (y, _, l) -> - if H.equal x y then l + if H.eq x y then l else cons y (remove x l) let rec mem x = function | Nil -> false - | Cons (y, _, l) -> H.equal x y || mem x l + | Cons (y, _, l) -> H.eq x y || mem x l let rec compare cmp l1 l2 = match l1, l2 with | Nil, Nil -> 0 @@ -251,7 +251,7 @@ module Level = struct type _t = t type t = _t type u = unit - let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data + let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash let hashcons () x = let data' = RawLevel.hcons x.data in @@ -400,7 +400,7 @@ struct let hashcons hdir (b,n as x) = let b' = hdir b in if b' == b then x else (b',n) - let equal l1 l2 = + let eq l1 l2 = l1 == l2 || match l1,l2 with | (b,n), (b',n') -> b == b' && n == n' @@ -419,7 +419,7 @@ struct let hcons = Hashcons.simple_hcons H.generate H.hcons Level.hcons let hash = ExprHash.hash - let equal x y = x == y || + let eq x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) @@ -1287,7 +1287,7 @@ module Hconstraint = type t = univ_constraint type u = universe_level -> universe_level let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) - let equal (l1,k,l2) (l1',k',l2') = + let eq (l1,k,l2) (l1',k',l2') = l1 == l1' && k == k' && l2 == l2' let hash = Hashtbl.hash end) @@ -1299,7 +1299,7 @@ module Hconstraints = type u = univ_constraint -> univ_constraint let hashcons huc s = Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty - let equal s s' = + let eq s s' = List.for_all2eq (==) (Constraint.elements s) (Constraint.elements s') @@ -1671,7 +1671,7 @@ struct a end - let equal t1 t2 = + let eq t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = @@ -2046,7 +2046,7 @@ module Huniverse_set = type u = universe_level -> universe_level let hashcons huc s = LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty - let equal s s' = + let eq s s' = LSet.equal s s' let hash = Hashtbl.hash end) diff --git a/lib/cSet.ml b/lib/cSet.ml index 3eeff29fe1..037cdc3568 100644 --- a/lib/cSet.ml +++ b/lib/cSet.ml @@ -57,7 +57,7 @@ struct open Hashset.Combine type t = set type u = M.t -> M.t - let equal s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 []) + let eq s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 []) let hash s = Set.fold (fun v accu -> combine (H.hash v) accu) s 0 let hashcons = umap end diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 144d951303..4a72b015c5 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -15,7 +15,7 @@ * of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...). * [hashcons u x] is a function that hash-cons the sub-structures of x using * the hash-consing functions u provides. - * [equal] is a comparison function. It is allowed to use physical equality + * [eq] is a comparison function. It is allowed to use physical equality * on the sub-terms hash-consed by the hashcons function. * [hash] is the hash function given to the Hashtbl.Make function * @@ -27,7 +27,7 @@ module type HashconsedType = type t type u val hashcons : u -> t -> t - val equal : t -> t -> bool + val eq : t -> t -> bool val hash : t -> int end @@ -53,7 +53,7 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = (* We create the type of hashtables for t, with our comparison fun. * An invariant is that the table never contains two entries equals - * w.r.t (=), although the equality on keys is X.equal. This is + * w.r.t (=), although the equality on keys is X.eq. This is * granted since we hcons the subterms before looking up in the table. *) module Htbl = Hashset.Make(X) @@ -124,7 +124,7 @@ module Hlist (D:HashedType) = let hashcons (hrec,hdata) = function | x :: l -> hdata x :: hrec l | l -> l - let equal l1 l2 = + let eq l1 l2 = l1 == l2 || match l1, l2 with | [], [] -> true @@ -144,7 +144,7 @@ module Hstring = Make( type t = string type u = unit let hashcons () s =(* incr accesstr;*) s - external equal : string -> string -> bool = "caml_string_equal" "noalloc" + external eq : string -> string -> bool = "caml_string_equal" "noalloc" (** Copy from CString *) let rec hash len s i accu = if i = len then accu @@ -191,7 +191,7 @@ module Hobj = Make( type t = Obj.t type u = (Obj.t -> Obj.t) * unit let hashcons (hrec,_) = hash_obj hrec - let equal = comp_obj + let eq = comp_obj let hash = Hashtbl.hash end) diff --git a/lib/hashcons.mli b/lib/hashcons.mli index 04754ba1db..150899cef5 100644 --- a/lib/hashcons.mli +++ b/lib/hashcons.mli @@ -14,9 +14,9 @@ module type HashconsedType = sig (** {6 Generic hashconsing signature} - Given an equivalence relation [equal], a hashconsing function is a + Given an equivalence relation [eq], a hashconsing function is a function that associates the same canonical element to two elements - related by [equal]. Usually, the element chosen is canonical w.r.t. + related by [eq]. Usually, the element chosen is canonical w.r.t. physical equality [(==)], so as to reduce memory consumption and enhance efficiency of equality tests. @@ -32,15 +32,15 @@ module type HashconsedType = Usually a tuple of functions. *) val hashcons : u -> t -> t (** The actual hashconsing function, using its fist argument to recursively - hashcons substructures. It should be compatible with [equal], that is - [equal x (hashcons f x) = true]. *) - val equal : t -> t -> bool + hashcons substructures. It should be compatible with [eq], that is + [eq x (hashcons f x) = true]. *) + val eq : t -> t -> bool (** A comparison function. It is allowed to use physical equality on the sub-terms hashconsed by the [hashcons] function, but it should be insensible to shallow copy of the compared object. *) val hash : t -> int (** A hash function passed to the underlying hashtable structure. [hash] - should be compatible with [equal], i.e. if [equal x y = true] then + should be compatible with [eq], i.e. if [eq x y = true] then [hash x = hash y]. *) end diff --git a/lib/hashset.ml b/lib/hashset.ml index 6fb78f9a45..04009fdf3c 100644 --- a/lib/hashset.ml +++ b/lib/hashset.ml @@ -16,7 +16,7 @@ module type EqType = sig type t - val equal : t -> t -> bool + val eq : t -> t -> bool end type statistics = { @@ -183,7 +183,7 @@ module Make (E : EqType) = if i >= sz then ifnotfound index else if h = hashes.(i) then begin match Weak.get bucket i with - | Some v when E.equal v d -> v + | Some v when E.eq v d -> v | _ -> loop (i + 1) end else loop (i + 1) in diff --git a/lib/hashset.mli b/lib/hashset.mli index 05d4fe379a..733c89621c 100644 --- a/lib/hashset.mli +++ b/lib/hashset.mli @@ -16,7 +16,7 @@ module type EqType = sig type t - val equal : t -> t -> bool + val eq : t -> t -> bool end type statistics = { -- cgit v1.2.3 From a0e792236c9666df1069753f8f807c12f713dcfb Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 23 Mar 2016 16:03:47 +0100 Subject: refine: do check all unif problems are solved (Close: #4415, #4532) This fixes a class of bugs like refine foo; tactic. where tactic fails (by resuming the remaining, unsolvable, problems) while in 8.4 refine was failing. It is not clear to us (Maxime and myself) if we should call consider_remaining_unif_problems instead of check_problems_are_solved. --- proofs/proofview.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 6d7dcb9257..80569e2342 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1061,6 +1061,7 @@ struct let typecheck_proof c concl env sigma = let evdref = ref sigma in let () = Typing.check env evdref c concl in + Evarconv.check_problems_are_solved env !evdref; !evdref let (pr_constrv,pr_constr) = -- cgit v1.2.3 From 31ffc14b4b8d531777042d3ff02f34985bcec084 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 23 Mar 2016 18:26:00 +0100 Subject: Revert "refine: do check all unif problems are solved (Close: #4415, #4532)" This fix is too restrictive. Still, opening a goal for an evar with a pending conv_pb is unsafe since the user may prove (instantiate it) in a way not compatible with the conv_pb. Assigning an evar, in its lowest level API, should enforce that all related conv_pbs are satisfied by the instance. This also poses a UI problem, since there is not way to see these conv_pbs. One could print a goal and say: look, the proof term you give must validate this equation... Given that the good fix is not obvious, we revert! This reverts commit a0e792236c9666df1069753f8f807c12f713dcfb. --- proofs/proofview.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 80569e2342..6d7dcb9257 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -1061,7 +1061,6 @@ struct let typecheck_proof c concl env sigma = let evdref = ref sigma in let () = Typing.check env evdref c concl in - Evarconv.check_problems_are_solved env !evdref; !evdref let (pr_constrv,pr_constr) = -- cgit v1.2.3 From 396b598ba6984169e4215b1400989c3c67abc1aa Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 10 Feb 2016 10:35:01 -0800 Subject: add a .merlin target to the makefile --- tools/coq_makefile.ml | 34 ++++++++++++++++++++++++++++------ 1 file changed, 28 insertions(+), 6 deletions(-) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index c4b7618270..ff4b8bd600 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -43,6 +43,16 @@ let section s = print_com (String.make (l+2) '#'); print "\n" +(* These are the Coq library directories that are used for + * plugin development + *) +let lib_dirs = + ["kernel"; "lib"; "library"; "parsing"; + "pretyping"; "interp"; "printing"; "intf"; + "proofs"; "tactics"; "tools"; "toplevel"; + "stm"; "grammar"; "config"] + + let usage () = output_string stderr "Usage summary: @@ -452,12 +462,8 @@ let variables is_install opt (args,defs) = end; (* Caml executables and relative variables *) if !some_ml4file || !some_mlfile || !some_mlifile then begin - print "COQSRCLIBS?=-I \"$(COQLIB)kernel\" -I \"$(COQLIB)lib\" \\ - -I \"$(COQLIB)library\" -I \"$(COQLIB)parsing\" -I \"$(COQLIB)pretyping\" \\ - -I \"$(COQLIB)interp\" -I \"$(COQLIB)printing\" -I \"$(COQLIB)intf\" \\ - -I \"$(COQLIB)proofs\" -I \"$(COQLIB)tactics\" -I \"$(COQLIB)tools\" \\ - -I \"$(COQLIB)toplevel\" -I \"$(COQLIB)stm\" -I \"$(COQLIB)grammar\" \\ - -I \"$(COQLIB)config\""; + print "COQSRCLIBS?=" ; + List.iter (fun c -> print "-I \"$(COQLIB)"; print c ; print "\" \\\n") lib_dirs ; List.iter (fun c -> print " \\ -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n"; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n"; @@ -799,6 +805,21 @@ let check_overlapping_include (_,inc_i,inc_r) = Printf.eprintf "Warning: in options -R/-Q, %s and %s overlap\n" pdir pdir') l; in aux (inc_i@inc_r) +(* Generate a .merlin file that references the standard library and + * any -I included paths. + *) +let merlin targets (ml_inc,_,_) = + print ".merlin:\n"; + print "\t@echo 'FLG -rectypes' > .merlin\n" ; + List.iter (fun c -> + print "\t@echo \"B $(COQLIB)" ; print c ; print "\" >> .merlin\n") + lib_dirs ; + List.iter (fun (_,c) -> + print "\t@echo \"B " ; print c ; print "\" >> .merlin\n" ; + print "\t@echo \"S " ; print c ; print "\" >> .merlin\n") + ml_inc; + print "\n" + let do_makefile args = let has_file var = function |[] -> var := false @@ -841,6 +862,7 @@ let do_makefile args = section "Special targets."; standard opt; install targets inc is_install; + merlin targets inc; clean sds sps; make_makefile sds; implicit (); -- cgit v1.2.3 From 866b7539cca2bd48c230bc6ddf3acea89cb1450a Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sat, 13 Feb 2016 17:37:36 -0800 Subject: use printf instead of sequenced calls to print. --- tools/coq_makefile.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index ff4b8bd600..80217587d5 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -812,11 +812,11 @@ let merlin targets (ml_inc,_,_) = print ".merlin:\n"; print "\t@echo 'FLG -rectypes' > .merlin\n" ; List.iter (fun c -> - print "\t@echo \"B $(COQLIB)" ; print c ; print "\" >> .merlin\n") + printf "\t@echo \"B $(COQLIB) %s\" >> .merlin\n" c) lib_dirs ; List.iter (fun (_,c) -> - print "\t@echo \"B " ; print c ; print "\" >> .merlin\n" ; - print "\t@echo \"S " ; print c ; print "\" >> .merlin\n") + printf "\t@echo \"B %s\" >> .merlin\n" c; + printf "\t@echo \"S %s\" >> .merlin\n" c) ml_inc; print "\n" -- cgit v1.2.3 From a6d6bca5f024cbdc35924c2cb5e399eb8a2d9c16 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Mar 2016 18:19:08 +0100 Subject: Fix handling of arity of definitional classes. The user-provided sort was ignored for them. --- theories/Classes/CMorphisms.v | 2 +- toplevel/record.ml | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index c41eb2fa29..10f18fe70d 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -527,7 +527,7 @@ Hint Extern 7 (@Proper _ _ _) => proper_reflexive Section Normalize. Context (A : Type). - Class Normalizes (m : crelation A) (m' : crelation A) : Prop := + Class Normalizes (m : crelation A) (m' : crelation A) := normalizes : relation_equivalence m m'. (** Current strategy: add [flip] everywhere and reduce using [subrelation] diff --git a/toplevel/record.ml b/toplevel/record.ml index c5ae7e8913..6bdcdef01b 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -135,8 +135,8 @@ let typecheck_params_and_fields def id pl t ps nots fs = let _, univ = compute_constructor_level evars env_ar newfs in let ctx, aritysort = Reduction.dest_arity env0 arity in assert(List.is_empty ctx); (* Ensured by above analysis *) - if Sorts.is_prop aritysort || - (Sorts.is_set aritysort && is_impredicative_set env0) then + if not def && (Sorts.is_prop aritysort || + (Sorts.is_set aritysort && is_impredicative_set env0)) then arity, evars else let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in @@ -408,9 +408,9 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity match fields with | [(Name proj_name, _, field)] when def -> let class_body = it_mkLambda_or_LetIn field params in - let _class_type = it_mkProd_or_LetIn arity params in + let class_type = it_mkProd_or_LetIn arity params in let class_entry = - Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in + Declare.definition_entry ~types:class_type ~poly ~univs:ctx class_body in let cst = Declare.declare_constant (snd id) (DefinitionEntry class_entry, IsDefinition Definition) in -- cgit v1.2.3 From 25c6356326773ac56380b81de6f58d15caae8680 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 25 Mar 2016 01:42:38 +0100 Subject: Fix a bug in Program coercion code It was not accounting for the universe constraints generated by applications of the coercion. --- pretyping/coercion.ml | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 489a311bc6..d00445958f 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -129,7 +129,7 @@ let mu env evdref t = let rec aux v = let v' = hnf env !evdref v in match disc_subset v' with - Some (u, p) -> + | Some (u, p) -> let f, ct = aux u in let p = hnf_nodelta env !evdref p in (Some (fun x -> @@ -241,7 +241,6 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let remove_head a c = match kind_of_term c with | Lambda (n, t, t') -> c, t' - (*| Prod (n, t, t') -> t'*) | Evar (k, args) -> let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in evdref := evs; @@ -297,9 +296,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) with NoSubtacCoercion -> let typ = Typing.unsafe_type_of env evm c in let typ' = Typing.unsafe_type_of env evm c' in - (* if not (is_arity env evm typ) then *) coerce_application typ typ' c c' l l') - (* else subco () *) else subco () | x, y when Constr.equal c c' -> @@ -307,9 +304,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let evm = !evdref in let lam_type = Typing.unsafe_type_of env evm c in let lam_type' = Typing.unsafe_type_of env evm c' in - (* if not (is_arity env evm lam_type) then ( *) coerce_application lam_type lam_type' c c' l l' - (* ) else subco () *) else subco () | _ -> subco ()) | _, _ -> subco () @@ -335,10 +330,17 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) raise NoSubtacCoercion in coerce_unify env x y +let app_coercion env evdref coercion v = + match coercion with + | None -> v + | Some f -> + let v' = Typing.solve_evars env evdref (f v) in + whd_betaiota !evdref v' + let coerce_itf loc env evd v t c1 = let evdref = ref evd in let coercion = coerce loc env evdref t c1 in - let t = Option.map (app_opt env evdref coercion) v in + let t = Option.map (app_coercion env evdref coercion) v in !evdref, t let saturate_evd env evd = @@ -424,7 +426,7 @@ let inh_coerce_to_base loc env evd j = let evdref = ref evd in let ct, typ' = mu env evdref j.uj_type in let res = - { uj_val = app_opt env evdref ct j.uj_val; + { uj_val = app_coercion env evdref ct j.uj_val; uj_type = typ' } in !evdref, res else (evd, j) -- cgit v1.2.3 From ebc509ed2d7a644aaf2a7d6d352d3f5bb80d25b0 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 25 Mar 2016 11:22:19 +0100 Subject: Remove int64 emulation in bytecode interpreter. We now assume an int64 type is provided by the C compiler. The emulation file was already not compiling, so it is probably not used even on exotic architectures. These files come from OCaml, where they are no longer used either. --- kernel/byterun/coq_interp.c | 29 ++--- kernel/byterun/int64_emul.h | 270 ------------------------------------------ kernel/byterun/int64_native.h | 48 -------- myocamlbuild.ml | 4 +- 4 files changed, 13 insertions(+), 338 deletions(-) delete mode 100644 kernel/byterun/int64_emul.h delete mode 100644 kernel/byterun/int64_native.h diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index dc571699ef..bf383a33ac 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -22,18 +22,10 @@ #include "coq_memory.h" #include "coq_values.h" -/*spiwack : imports support functions for 64-bit integers */ -#include -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - /* spiwack: I append here a few macros for value/number manipulation */ #define uint32_of_value(val) (((uint32_t)val >> 1)) #define value_of_uint32(i) ((value)(((uint32_t)(i) << 1) | 1)) -#define UI64_of_uint32(lo) ((uint64_t)(I64_literal(0,(uint32_t)(lo)))) +#define UI64_of_uint32(lo) ((uint64_t)(lo)) #define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) /* /spiwack */ @@ -1201,8 +1193,8 @@ value coq_interprete print_instr("MULCINT31"); uint64_t p; /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ - p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); - if ( I64_is_zero(p) ) { + p = UI64_of_value (accu) * UI64_of_uint32 ((*sp++)^1); + if (p == 0) { accu = (value)1; } else { @@ -1211,8 +1203,8 @@ value coq_interprete of the non-constant constructor is then 1 */ Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ /*unsigned shift*/ - Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; /*higher part*/ - Field(accu, 1) = (value)(I64_to_int32(p)|1); /*lower part*/ + Field(accu, 0) = (value)((p >> 31)|1) ; /*higher part*/ + Field(accu, 1) = (value)((int32_t)p|1); /*lower part*/ } Next; } @@ -1224,19 +1216,20 @@ value coq_interprete int62 by the int31 */ uint64_t bigint; bigint = UI64_of_value(accu); - bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); + bigint = (bigint << 31) | UI64_of_value(*sp++); uint64_t divisor; divisor = UI64_of_value(*sp++); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - if (I64_is_zero (divisor)) { + if (divisor == 0) { Field(accu, 0) = 1; /* 2*0+1 */ Field(accu, 1) = 1; /* 2*0+1 */ } else { uint64_t quo, mod; - I64_udivmod(bigint, divisor, &quo, &mod); - Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); - Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); + quo = bigint / divisor; + mod = bigint % divisor; + Field(accu, 0) = value_of_uint32((uint32_t)(quo)); + Field(accu, 1) = value_of_uint32((uint32_t)(mod)); } Next; } diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h deleted file mode 100644 index 86bee72edb..0000000000 --- a/kernel/byterun/int64_emul.h +++ /dev/null @@ -1,270 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Software emulation of 64-bit integer arithmetic, for C compilers - that do not support it. */ - -#ifndef CAML_INT64_EMUL_H -#define CAML_INT64_EMUL_H - -#include - -#ifdef ARCH_BIG_ENDIAN -#define I64_literal(hi,lo) { hi, lo } -#else -#define I64_literal(hi,lo) { lo, hi } -#endif - -/* Unsigned comparison */ -static int I64_ucompare(uint64 x, uint64 y) -{ - if (x.h > y.h) return 1; - if (x.h < y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -#define I64_ult(x, y) (I64_ucompare(x, y) < 0) - -/* Signed comparison */ -static int I64_compare(int64 x, int64 y) -{ - if ((int32)x.h > (int32)y.h) return 1; - if ((int32)x.h < (int32)y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -/* Negation */ -static int64 I64_neg(int64 x) -{ - int64 res; - res.l = -x.l; - res.h = ~x.h; - if (res.l == 0) res.h++; - return res; -} - -/* Addition */ -static int64 I64_add(int64 x, int64 y) -{ - int64 res; - res.l = x.l + y.l; - res.h = x.h + y.h; - if (res.l < x.l) res.h++; - return res; -} - -/* Subtraction */ -static int64 I64_sub(int64 x, int64 y) -{ - int64 res; - res.l = x.l - y.l; - res.h = x.h - y.h; - if (x.l < y.l) res.h--; - return res; -} - -/* Multiplication */ -static int64 I64_mul(int64 x, int64 y) -{ - int64 res; - uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); - uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); - uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); - uint32 prod11 = (x.l >> 16) * (y.l >> 16); - res.l = prod00; - res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); - prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; - prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; - res.h += x.l * y.h + x.h * y.l; - return res; -} - -#define I64_is_zero(x) (((x).l | (x).h) == 0) - -#define I64_is_negative(x) ((int32) (x).h < 0) - -/* Bitwise operations */ -static int64 I64_and(int64 x, int64 y) -{ - int64 res; - res.l = x.l & y.l; - res.h = x.h & y.h; - return res; -} - -static int64 I64_or(int64 x, int64 y) -{ - int64 res; - res.l = x.l | y.l; - res.h = x.h | y.h; - return res; -} - -static int64 I64_xor(int64 x, int64 y) -{ - int64 res; - res.l = x.l ^ y.l; - res.h = x.h ^ y.h; - return res; -} - -/* Shifts */ -static int64 I64_lsl(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = x.l << s; - res.h = (x.h << s) | (x.l >> (32 - s)); - } else { - res.l = 0; - res.h = x.l << (s - 32); - } - return res; -} - -static int64 I64_lsr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = x.h >> s; - } else { - res.l = x.h >> (s - 32); - res.h = 0; - } - return res; -} - -static int64 I64_asr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = (int32) x.h >> s; - } else { - res.l = (int32) x.h >> (s - 32); - res.h = (int32) x.h >> 31; - } - return res; -} - -/* Division and modulus */ - -#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 -#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 - -static void I64_udivmod(uint64 modulus, uint64 divisor, - uint64 * quo, uint64 * mod) -{ - int64 quotient, mask; - int cmp; - - quotient.h = 0; quotient.l = 0; - mask.h = 0; mask.l = 1; - while ((int32) divisor.h >= 0) { - cmp = I64_ucompare(divisor, modulus); - I64_SHL1(divisor); - I64_SHL1(mask); - if (cmp >= 0) break; - } - while (mask.l | mask.h) { - if (I64_ucompare(modulus, divisor) >= 0) { - quotient.h |= mask.h; quotient.l |= mask.l; - modulus = I64_sub(modulus, divisor); - } - I64_SHR1(mask); - I64_SHR1(divisor); - } - *quo = quotient; - *mod = modulus; -} - -static int64 I64_div(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h ^ y.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) q = I64_neg(q); - return q; -} - -static int64 I64_mod(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) r = I64_neg(r); - return r; -} - -/* Coercions */ - -static int64 I64_of_int32(int32 x) -{ - int64 res; - res.l = x; - res.h = x >> 31; - return res; -} - -#define I64_to_int32(x) ((int32) (x).l) - -/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise - autoconfiguration would have selected native 64-bit integers */ -#define I64_of_intnat I64_of_int32 -#define I64_to_intnat I64_to_int32 - -static double I64_to_double(int64 x) -{ - double res; - int32 sign = x.h; - if (sign < 0) x = I64_neg(x); - res = ldexp((double) x.h, 32) + x.l; - if (sign < 0) res = -res; - return res; -} - -static int64 I64_of_double(double f) -{ - int64 res; - double frac, integ; - int neg; - - neg = (f < 0); - f = fabs(f); - frac = modf(ldexp(f, -32), &integ); - res.h = (uint32) integ; - res.l = (uint32) ldexp(frac, 32); - if (neg) res = I64_neg(res); - return res; -} - -#endif /* CAML_INT64_EMUL_H */ diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h deleted file mode 100644 index 657d0a07e0..0000000000 --- a/kernel/byterun/int64_native.h +++ /dev/null @@ -1,48 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Wrapper macros around native 64-bit integer arithmetic, - so that it has the same interface as the software emulation - provided in int64_emul.h */ - -#ifndef CAML_INT64_NATIVE_H -#define CAML_INT64_NATIVE_H - -#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) -#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y)) -#define I64_neg(x) (-(x)) -#define I64_add(x,y) ((x) + (y)) -#define I64_sub(x,y) ((x) - (y)) -#define I64_mul(x,y) ((x) * (y)) -#define I64_is_zero(x) ((x) == 0) -#define I64_is_negative(x) ((x) < 0) -#define I64_div(x,y) ((x) / (y)) -#define I64_mod(x,y) ((x) % (y)) -#define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64_t)(x) % (uint64_t)(y), \ - *(quo) = (uint64_t)(x) / (uint64_t)(y)) -#define I64_and(x,y) ((x) & (y)) -#define I64_or(x,y) ((x) | (y)) -#define I64_xor(x,y) ((x) ^ (y)) -#define I64_lsl(x,y) ((x) << (y)) -#define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64_t)(x) >> (y)) -#define I64_to_intnat(x) ((intnat) (x)) -#define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32_t) (x)) -#define I64_of_int32(x) ((int64_t) (x)) -#define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64_t)(x)) - -#endif /* CAML_INT64_NATIVE_H */ diff --git a/myocamlbuild.ml b/myocamlbuild.ml index ad1f8cbcc7..90df4f00c6 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -115,8 +115,8 @@ let core_mllib = List.map (fun s -> s^".mllib") core_libs let tolink = "tools/tolink.ml" let c_headers_base = - ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; "int64_emul.h"; - "coq_gc.h"; "coq_interp.h"; "coq_values.h"; "int64_native.h"; + ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; + "coq_gc.h"; "coq_interp.h"; "coq_values.h"; "coq_jumptbl.h"] let c_headers = List.map ((^) "kernel/byterun/") c_headers_base -- cgit v1.2.3 From 3bdbbc287bc0138541db2bfabadd8196269c8f56 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 25 Mar 2016 13:09:18 +0100 Subject: Test suite file for a bug in int31 arithmetic fixed a while ago. --- test-suite/failure/int31.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 test-suite/failure/int31.v diff --git a/test-suite/failure/int31.v b/test-suite/failure/int31.v new file mode 100644 index 0000000000..b1d112247f --- /dev/null +++ b/test-suite/failure/int31.v @@ -0,0 +1,17 @@ +Require Import Int31 BigN. + +Open Scope int31_scope. + +(* This used to go through because of an unbalanced stack bug in the bytecode +interpreter *) + +Lemma bad : False. +assert (1 = 2). +change 1 with (add31 (addmuldiv31 65 (add31 1 1) 2) 1). +Fail vm_compute; reflexivity. +(* +discriminate. +Qed. +*) +Abort. + -- cgit v1.2.3 From a54579dd20e04ea919f8fa887e15dd82051fa297 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 25 Mar 2016 13:17:23 +0100 Subject: Test suite file for a bug in BigQ arithmetic fixed a while ago. --- test-suite/success/bigQ.v | 66 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 test-suite/success/bigQ.v diff --git a/test-suite/success/bigQ.v b/test-suite/success/bigQ.v new file mode 100644 index 0000000000..7fd0cf669d --- /dev/null +++ b/test-suite/success/bigQ.v @@ -0,0 +1,66 @@ +Require Import BigQ. +Import List. + +Definition pi_4_approx_low' := +(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210782171804373210646804613922337450953858508244032293753591878060539465788294318856859293281629951093130167801471787011911886414492513677892193100809508943832528344473873460853362957387889412799458784754514139679847887887544849825173792522272708046699681079289358082661375778523609867456540595586031625044964543428047238934233579184772793670436643502740076366994465457847106782560289782615794595755672643440040123002018908935362541166831619056664637901929131328502017686713274283777724453661234225382109584471950444925886358166551424008707439387934109226545596919797083495958300914344992836193126080289565652575543234385558967555959267746932292860747199382633363026440008828134867747920263181610216905129926037611247017868033961426567047355301676870662406173724238530061264149506666345040372864118731705584795947926329181826992456072045382170981478151356381437136818835196834068650217794381425547036331194595892801393225038235274901050364737353586927051766717037643833477566087835266968086513005761986678747515870298138062157791066648217784877968385924845017637219384732843791052551854695220023477365706464590594542001161575677402761543188277502092362285265847964496740584911576627239093631932307473445797386335961743298553548881544486940399236133577915988716682746485564575640818803540680574730591500432326858763829791848612343662539095316357052823005419355719381626599487868023399182174939253393897549026675976384326749445831606130546375395770778462506203752920470130305293966478109733954117063941901686840180727195741528561335809865193566993349413786715403053579411364371500063193205131503024022217701373077790337150298315820556080596579100618643147698304927957576213733526923182742441048553793831725592624850721293495085399785588171300815789795594858916409701139277050529011775828846362873246196866089783324522718656445008090114701320562608474099248873638488023114015981013142490827777895317580810590743940417298263300561876701828404744082864248409230009391001735746615476377303707782123483770118391136826609366946585715225248587168403619476143657107412319421501162805102723455593551478028055839072686207007765300258935153546418515706362733656094770289090398825190320430416955807878686642673124733998295439657633866090085982598765253268688814792672416195730086607425842181518560588819896560847103627615434844684536463752986969865794019299978956052589825441828842338163389851892617560591840546654410705167593310272272965900821031821380595084783691324416454359888103920904935692840264474003367023256964191100139001239923263691779167792867186165635514824889759796850863175082506408142175595463676408992027105356481220754473245821534527625758942093801142305560662681150069082553674495761075895588095760081401141419460482860852822686860785424514171214889677926763812031823537071721974799922995763666175738785000806081164280471363125324839717808977470218218571800106898347366938927189989988149888641129263448064762730769285877330997355234347773807099829665997515649429224335217107760728789764718885665291038706425454675746218345291274054088843647602239258308472486102933167465443294268551209015027897159307743987020521392788721231001835675584104894174434637260464035122611721657641428625505184886116917149318963070896162119215386541876236027342810162765609201440423207771441367926085768438143507025739041041240810056881304230519058117534418374553879198061289605354335880794397478047346975609179199801003098836622253165101961484972165230151495472006888128587168049198312469715081555662345452800468933420359802645393289853553618279788400476187713990872203669487294118461245455333004125835663010526985716431187034663870796866708678078952110615910196519835267441831874676895301527286826106517027821074816850326548617513767142627360001181210946100011774672126943957522004190414960909074050454565964857276407084991922274068961845339154089866785707764290964299529444616711194034827611771558783466230353209661849406004241580029437779784290315347968833708422223285859451369907260780956405036020581705441364379616715041818815829810906212826084485200785283123265202151252852134381195424724503189247411069117189489985791487434549080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 + # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ +. + +Definition pi_4_approx_high' := +(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210788409308322071457087096445676662503017187903223859814905546579050729173916234740628466315449085686468204847296426235788544874405450791749423436215032927889914519102361378633666267941326393265376660400091389373564825046526561381561278586121772300141564909333667988204680492088607706214346458601842899721615765319505314310192693665547163360402786722105590252780194994950097926184146718893770363322073641336811404180286358079915338791029818581497746089864894356686643882883410392601500048021013346713450539807687779704798018559373507951388092945938366448668853081682176581336156031434604604833692503597621519809826880683536141897075567053733515342478008373282599947520770191238802249392773327261328133194484586433840861730959791563023761306622956165536481335792721379318928171897265310054788931201902441066997927781894934061720760080768154565282051604447333036111267534150649674590201404453202347064545359869105856798745664471694795576801148562495225166002814304124970965817043547048503388910163287916513427409193998045119986267987892522931703487420953769290650229176116308194977201080691718825944370436642709192983358059711255925052564016519597530235976618244111239816418652282585432539731271068892992142956810775762851238126881225206289553948196520384709574383566733478326330112084307565420647201107231840508040019131253750047046446929758911912155202166566751947087545292626353331520202690130850009389387290465497377022080531269511355734944672010542204118978272180881335465227900174033380001851066811103401787656367819132934758616060307366679580043123632565656840669377840733018248707250548277181001911990237151790533341326223932843775840498222236867608395855700891719880219904948672458645420169533565809609056209006342663841718949396996175294237942265325043426430990062217643279654512512640557763489491751115437780462208361129433667449740743123546232162409802316714286708788831227582498585478334315076725145986771341647015244092760289407649044493584479944044779273447198382196766547779885914425854375158084417582279211000449529495605127376707776277159376010648950025135061284601443461110447113346277147728593420397807946636800365109579479211273476195727270004743568492888900356505584731622538401071221591141889158461271000051210318027818802379539544396973228585821742794928813630781709195703717312953337431290682263448669168179857644544116657440168099166467471736180072984407514757289757495435699300593165669101965987430482600019222913485092771346963058673132443387835726110205958057187517487684058179749952286341120230051432903482992282688283815697442898155194928723360957436110770317998431272108100149791425689283090777721270428030993332057319821685391144252815655146410678839177846108260765981523812232294638190350688210999605869296307711846463311346627138400477211801219366400312514793356564308532012682051019030257269068628100171220662165246389309014292764479226570049772046255291379151017129899157296574099437276707879597755725339406865738613810979022640265737120949077721294633786520294559343155148383011293584240192753971366644780434237846862975993387453786681995831719537733846579480995517357440575781962659282856696638992709756358478461648462532279323701121386551383509193782388241965285971965887701816406255233933761008649762854363984142178331798953040874526844255758512982810004271235810681505829473926495256537353108899526434200682024946218302499640511518360332022463196599199779172637638655415918976955930735312156870786600023896830267884391447789311101069654521354446521135407720085038662159974712373018912537116964809382149581004863115431780452188813210275393919111435118030412595133958954313836191108258769640843644195537185904547405641078708492098917460393911427237155683288565433183738513871595286090814836422982384810033331519971102974091067660369548406192526284519976668985518575216481570167748402860759832933071281814538397923687510782620605409323050353840034866296214149657376249634795555007199540807313397329050410326609108411299737760271566308288500400587417017113933243099961248847368789383209110747378488312550109911605079801570534271874115018095746872468910162721975463388518648962869080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 + # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ +. + +Fixpoint numden_Rcontfrac_tailrecB (accu: list bigZ) (n1 d1: bigZ) (n2 d2: bigZ) (fuel: nat) {struct fuel}: + (list bigZ * bigQ * bigQ) := + let default := (rev_append accu nil, BigQ.div (BigQ.Qz n1) (BigQ.Qz d1), BigQ.div (BigQ.Qz n2) (BigQ.Qz d2)) in + match fuel with + | O => default + | S fuel' => + let '(q1, r1) := BigZ.div_eucl n1 d1 in + let '(q2, r2) := BigZ.div_eucl n2 d2 in + match BigZ.eqb q1 q2 with + | false => default + | true => + let r1_is_zero := BigZ.eqb r1 0 in + let r2_is_zero := BigZ.eqb r2 0 in + match Bool.eqb r1_is_zero r2_is_zero with + | false => default + | true => + match r1_is_zero with + | true => + match BigZ.eqb q1 1 with + | true => (rev_append accu nil, 1%bigQ, 1%bigQ) + | false => (rev_append ((q1 - 1)%bigZ :: accu) nil, 1%bigQ, 1%bigQ) + end + | false => numden_Rcontfrac_tailrecB (q1 :: accu) d1 r1 d2 r2 fuel' + end + end + end + end. + +Definition Bnum b := + match b with + | BigQ.Qz t => t + | BigQ.Qq n d => + if (d =? BigN.zero)%bigN then 0%bigZ else n + end. + +Definition Bden b := + match b with + | BigQ.Qz _ => 1%bigN + | BigQ.Qq _ d => if (d =? BigN.zero)%bigN then 1%bigN else d + end. + +Definition rat_Rcontfrac_tailrecB q1 q2 := + numden_Rcontfrac_tailrecB nil (Bnum q1) (BigZ.Pos (Bden q1)) (Bnum q2) (BigZ.Pos (Bden q2)). + +Definition pi_4_contfrac := + rat_Rcontfrac_tailrecB pi_4_approx_low' pi_4_approx_high' 3000. + +(* The following used to fail because of a non canonical representation of 0 in +the bytecode interpreter. Bug reported privately by Tahina Ramananandro. *) +Goal pi_4_contfrac = pi_4_contfrac. +vm_compute. +reflexivity. +Qed. -- cgit v1.2.3 From c4d62e3686926c27b172636ca8b746814d13a462 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Mar 2016 23:34:07 +0100 Subject: Moving type_uconstr to Pretyping. --- intf/tacexpr.mli | 2 +- ltac/eauto.ml | 2 +- ltac/extratactics.ml4 | 4 ++-- ltac/g_auto.ml4 | 2 +- ltac/tacinterp.ml | 18 ------------------ ltac/tacinterp.mli | 5 ----- pretyping/pretyping.ml | 25 +++++++++++++++++++++++++ pretyping/pretyping.mli | 8 ++++++++ 8 files changed, 38 insertions(+), 28 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index b1dc174d4b..0aa3b936ca 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -122,7 +122,7 @@ type open_glob_constr = unit * glob_constr_and_expr type binding_bound_vars = Id.Set.t type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern -type 'a delayed_open = +type 'a delayed_open = 'a Pretyping.delayed_open = { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open diff --git a/ltac/eauto.ml b/ltac/eauto.ml index 0449467598..9cfb805d4c 100644 --- a/ltac/eauto.ml +++ b/ltac/eauto.ml @@ -60,7 +60,7 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true } in - List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs (************************************************************************) (* PROLOG tactic *) diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 index 23aa8dcb47..96abc11999 100644 --- a/ltac/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -44,7 +44,7 @@ let with_delayed_uconstr ist c tac = fail_evar = false; expand_evars = true } in - let c = Tacinterp.type_uconstr ~flags ist c in + let c = Pretyping.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac let replace_in_clause_maybe_by ist c1 c2 cl tac = @@ -368,7 +368,7 @@ let refine_tac ist simple c = let env = Proofview.Goal.env gl in let flags = Pretyping.all_no_fail_flags in let expected_type = Pretyping.OfType concl in - let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in + let c = Pretyping.type_uconstr ~flags ~expected_type ist c in let update = { run = fun sigma -> c.delayed env sigma } in let refine = Refine.refine ~unsafe:false update in if simple then refine diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index 788443944f..bc98b7d6d4 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -48,7 +48,7 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true } in - List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 4506f81596..4c74984f83 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -723,24 +723,6 @@ let interp_open_constr_list = let pf_interp_type ist env sigma = interp_type ist env sigma -(* Fully evaluate an untyped constr *) -let type_uconstr ?(flags = constr_flags) - ?(expected_type = WithoutTypeConstraint) ist c = - { delayed = begin fun env sigma -> - let open Pretyping in - let { closure; term } = c in - let vars = { - ltac_constrs = closure.typed; - ltac_uconstrs = closure.untyped; - ltac_idents = closure.idents; - ltac_genargs = ist.lfun; - } in - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = understand_ltac flags env sigma vars expected_type term in - Sigma.Unsafe.of_pair (c, sigma) - end } - - (* Interprets a reduction expression *) let interp_unfold ist env sigma (occs,qid) = (interp_occurrences ist occs,interp_evaluable ist env sigma qid) diff --git a/ltac/tacinterp.mli b/ltac/tacinterp.mli index 31327873e9..92f12fc8f7 100644 --- a/ltac/tacinterp.mli +++ b/ltac/tacinterp.mli @@ -64,11 +64,6 @@ val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tac (** Interprets an expression that evaluates to a constr *) val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic -val type_uconstr : - ?flags:Pretyping.inference_flags -> - ?expected_type:Pretyping.typing_constraint -> - interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open - (** Interprets redexp arguments *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a765d30913..8baa668c7b 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -58,6 +58,8 @@ type ltac_var_map = { } type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr +type 'a delayed_open = + { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } (************************************************************************) (* This concerns Cases *) @@ -1107,3 +1109,26 @@ let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=W let understand_ltac flags env sigma lvar kind c = ise_pretype_gen flags env sigma lvar kind c + +let constr_flags = { + use_typeclasses = true; + use_unif_heuristics = true; + use_hook = None; + fail_evar = true; + expand_evars = true } + +(* Fully evaluate an untyped constr *) +let type_uconstr ?(flags = constr_flags) + ?(expected_type = WithoutTypeConstraint) ist c = + { delayed = begin fun env sigma -> + let { closure; term } = c in + let vars = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = ist.Geninterp.lfun; + } in + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = understand_ltac flags env sigma vars expected_type term in + Sigma.Unsafe.of_pair (c, sigma) + end } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 4c4c535d8c..91320f20a5 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -55,6 +55,9 @@ type inference_flags = { expand_evars : bool } +type 'a delayed_open = + { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } + val default_inference_flags : bool -> inference_flags val no_classes_no_fail_inference_flags : inference_flags @@ -114,6 +117,11 @@ val understand_judgment : env -> evar_map -> val understand_judgment_tcc : env -> evar_map ref -> glob_constr -> unsafe_judgment +val type_uconstr : + ?flags:inference_flags -> + ?expected_type:typing_constraint -> + Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open + (** Trying to solve remaining evars and remaining conversion problems possibly using type classes, heuristics, external tactic solver hook depending on given flags. *) -- cgit v1.2.3 From 9d5ddf9608d110498cc3c259c11cf6958a1a0d2e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Mar 2016 09:28:08 +0100 Subject: Moving Eauto and Class_tactics to tactics/. --- ltac/class_tactics.ml | 903 ---------------------------------------------- ltac/class_tactics.mli | 32 -- ltac/eauto.ml | 526 --------------------------- ltac/eauto.mli | 33 -- ltac/ltac.mllib | 2 - tactics/class_tactics.ml | 903 ++++++++++++++++++++++++++++++++++++++++++++++ tactics/class_tactics.mli | 32 ++ tactics/eauto.ml | 526 +++++++++++++++++++++++++++ tactics/eauto.mli | 33 ++ tactics/tactics.mllib | 2 + 10 files changed, 1496 insertions(+), 1496 deletions(-) delete mode 100644 ltac/class_tactics.ml delete mode 100644 ltac/class_tactics.mli delete mode 100644 ltac/eauto.ml delete mode 100644 ltac/eauto.mli create mode 100644 tactics/class_tactics.ml create mode 100644 tactics/class_tactics.mli create mode 100644 tactics/eauto.ml create mode 100644 tactics/eauto.mli diff --git a/ltac/class_tactics.ml b/ltac/class_tactics.ml deleted file mode 100644 index 4855598989..0000000000 --- a/ltac/class_tactics.ml +++ /dev/null @@ -1,903 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - if Evar.Map.mem ev !tosee then - visit ev (Evar.Map.find ev !tosee)) evs; - tosee := Evar.Map.remove ev !tosee; - l' := ev :: !l'; - in - while not (Evar.Map.is_empty !tosee) do - let ev, evi = Evar.Map.min_binding !tosee in - visit ev evi - done; - List.rev !l' - -let evars_to_goals p evm = - let goals = ref Evar.Map.empty in - let map ev evi = - let evi, goal = p evm ev evi in - let () = if goal then goals := Evar.Map.add ev evi !goals in - evi - in - let evm = Evd.raw_map_undefined map evm in - if Evar.Map.is_empty !goals then None - else Some (!goals, evm) - -(** Typeclasses instance search tactic / eauto *) - -open Auto - -open Unification - -let auto_core_unif_flags st freeze = { - modulo_conv_on_closed_terms = Some st; - use_metas_eagerly_in_conv_on_closed_terms = true; - use_evars_eagerly_in_conv_on_closed_terms = false; - modulo_delta = st; - modulo_delta_types = st; - check_applied_meta_types = false; - use_pattern_unification = true; - use_meta_bound_pattern_unification = true; - frozen_evars = freeze; - restrict_conv_on_strict_subterms = false; (* ? *) - modulo_betaiota = true; - modulo_eta = !typeclasses_modulo_eta; -} - -let auto_unif_flags freeze st = - let fl = auto_core_unif_flags st freeze in - { core_unify_flags = fl; - merge_unify_flags = fl; - subterm_unify_flags = fl; - allow_K_in_toplevel_higher_order_unification = false; - resolve_evars = false -} - -let rec eq_constr_mod_evars x y = - match kind_of_term x, kind_of_term y with - | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true - | _, _ -> compare_constr eq_constr_mod_evars x y - -let progress_evars t = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let concl = Proofview.Goal.concl gl in - let check = - Proofview.Goal.nf_enter { enter = begin fun gl' -> - let newconcl = Proofview.Goal.concl gl' in - if eq_constr_mod_evars concl newconcl - then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)") - else Proofview.tclUNIT () - end } - in t <*> check - end } - - -let e_give_exact flags poly (c,clenv) gl = - let (c, _, _) = c in - let c, gl = - if poly then - let clenv', subst = Clenv.refresh_undefined_univs clenv in - let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in - let c = Vars.subst_univs_level_constr subst c in - c, {gl with sigma = evd} - else c, gl - in - let t1 = pf_unsafe_type_of gl c in - tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl - -let unify_e_resolve poly flags = { enter = begin fun gls (c,clenv) -> - let clenv', c = connect_hint_clenv poly c clenv gls in - let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in - Clenvtac.clenv_refine true ~with_classes:false clenv' - end } - -let unify_resolve poly flags = { enter = begin fun gls (c,clenv) -> - let clenv', _ = connect_hint_clenv poly c clenv gls in - let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in - Clenvtac.clenv_refine false ~with_classes:false clenv' - end } - -let clenv_of_prods poly nprods (c, clenv) gl = - let (c, _, _) = c in - if poly || Int.equal nprods 0 then Some clenv - else - let ty = Tacmach.New.pf_unsafe_type_of gl c in - let diff = nb_prod ty - nprods in - if Pervasives.(>=) diff 0 then - (* Was Some clenv... *) - Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) - else None - -let with_prods nprods poly (c, clenv) f = - Proofview.Goal.nf_enter { enter = begin fun gl -> - match clenv_of_prods poly nprods (c, clenv) gl with - | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some clenv' -> f.enter gl (c, clenv') - end } - -(** Hack to properly solve dependent evars that are typeclasses *) - -let rec e_trivial_fail_db db_list local_db goal = - let tacl = - Proofview.V82.of_tactic Eauto.registered_e_assumption :: - (tclTHEN (Proofview.V82.of_tactic Tactics.intro) - (function g'-> - let d = pf_last_hyp g' in - let hintl = make_resolve_hyp (pf_env g') (project g') d in - (e_trivial_fail_db db_list - (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: - (List.map (fun (x,_,_,_,_) -> x) - (e_trivial_resolve db_list local_db (project goal) (pf_concl goal))) - in - tclFIRST (List.map tclCOMPLETE tacl) goal - -and e_my_find_search db_list local_db hdc complete sigma concl = - let prods, concl = decompose_prod_assum concl in - let nprods = List.length prods in - let freeze = - try - let cl = Typeclasses.class_info (fst hdc) in - if cl.cl_strict then - Evd.evars_of_term concl - else Evar.Set.empty - with e when Errors.noncritical e -> Evar.Set.empty - in - let hintl = - List.map_append - (fun db -> - let tacs = - if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto hdc concl db - else Hint_db.map_existential hdc concl db - in - let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in - List.map (fun x -> (flags, x)) tacs) - (local_db::db_list) - in - let tac_of_hint = - fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> - let tac = function - | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) - | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) - | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) - | Res_pf_THEN_trivial_fail (term,cl) -> - Proofview.V82.tactic (tclTHEN - (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) - (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) - | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]))) - | Extern tacast -> conclPattern concl p tacast - in - let tac = Proofview.V82.of_tactic (run_hint t tac) in - let tac = if complete then tclCOMPLETE tac else tac in - match repr_hint t with - | Extern _ -> (tac,b,true, name, lazy (pr_hint t)) - | _ -> -(* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) - (tac,b,false, name, lazy (pr_hint t)) - in List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db sigma concl = - try - e_my_find_search db_list local_db - (decompose_app_bound concl) true sigma concl - with Bound | Not_found -> [] - -let e_possible_resolve db_list local_db sigma concl = - try - e_my_find_search db_list local_db - (decompose_app_bound concl) false sigma concl - with Bound | Not_found -> [] - -let catchable = function - | Refiner.FailError _ -> true - | e -> Logic.catchable_exception e - -let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) - -let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) - -type autoinfo = { hints : hint_db; is_evar: existential_key option; - only_classes: bool; unique : bool; - auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; - auto_path : global_reference option list; - auto_cut : hints_path } -type autogoal = goal * autoinfo -type failure = NotApplicable | ReachedLimit -type 'ans fk = failure -> 'ans -type ('a,'ans) sk = 'a -> 'ans fk -> 'ans -type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } - -type auto_result = autogoal list sigma - -type atac = auto_result tac - -(* Some utility types to avoid the need of -rectypes *) - -type 'a optionk = - | Nonek - | Somek of 'a * 'a optionk fk - -type ('a,'b) optionk2 = - | Nonek2 of failure - | Somek2 of 'a * 'b * ('a,'b) optionk2 fk - -let make_resolve_hyp env sigma st flags only_classes pri decl = - let open Context.Named.Declaration in - let id = get_id decl in - let cty = Evarutil.nf_evar sigma (get_type decl) in - let rec iscl env ty = - let ctx, ar = decompose_prod_assum ty in - match kind_of_term (fst (decompose_app ar)) with - | Const (c,_) -> is_class (ConstRef c) - | Ind (i,_) -> is_class (IndRef i) - | _ -> - let env' = Environ.push_rel_context ctx env in - let ty' = whd_betadeltaiota env' ar in - if not (Term.eq_constr ty' ar) then iscl env' ty' - else false - in - let is_class = iscl env cty in - let keep = not only_classes || is_class in - if keep then - let c = mkVar id in - let name = PathHints [VarRef id] in - let hints = - if is_class then - let hints = build_subclasses ~check:false env sigma (VarRef id) None in - (List.map_append - (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) - (true,false,Flags.is_verbose()) pri false - (IsConstr (c,Univ.ContextSet.empty))) - hints) - else [] - in - (hints @ List.map_filter - (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) - with Failure _ | UserError _ -> None) - [make_exact_entry ~name env sigma pri false; - make_apply_entry ~name env sigma flags pri false]) - else [] - -let pf_filtered_hyps gls = - Goal.V82.hyps gls.Evd.sigma (sig_it gls) - -let make_hints g st only_classes sign = - let paths, hintlist = - List.fold_left - (fun (paths, hints) hyp -> - let consider = - let open Context.Named.Declaration in - try let t = Global.lookup_named (get_id hyp) |> get_type in - (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (get_type hyp)) - with Not_found -> true - in - if consider then - let path, hint = - PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp - in - (PathOr (paths, path), hint @ hints) - else (paths, hints)) - (PathEmpty, []) sign - in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) - -let make_autogoal_hints = - let cache = ref (true, Environ.empty_named_context_val, - Hint_db.empty full_transparent_state true) - in - fun only_classes ?(st=full_transparent_state) g -> - let sign = pf_filtered_hyps g in - let (onlyc, sign', cached_hints) = !cache in - if onlyc == only_classes && - (sign == sign' || Environ.eq_named_context_val sign sign') - && Hint_db.transparent_state cached_hints == st - then - cached_hints - else - let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in - cache := (only_classes, sign, hints); hints - -let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = - { skft = fun sk fk {it = gl,hints; sigma=s;} -> - let res = try Some (tac {it=gl; sigma=s;}) - with e when catchable e -> None in - match res with - | Some gls -> sk (f gls hints) fk - | None -> fk NotApplicable } - -let intro_tac : atac = - lift_tactic (Proofview.V82.of_tactic Tactics.intro) - (fun {it = gls; sigma = s} info -> - let gls' = - List.map (fun g' -> - let env = Goal.V82.env s g' in - let context = Environ.named_context_of_val (Goal.V82.hyps s g') in - let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) - (true,false,false) info.only_classes None (List.hd context) in - let ldb = Hint_db.add_list env s hint info.hints in - (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls - in {it = gls'; sigma = s;}) - -let normevars_tac : atac = - { skft = fun sk fk {it = (gl, info); sigma = s;} -> - let gl', sigma' = Goal.V82.nf_evar s gl in - let info' = { info with auto_last_tac = lazy (str"normevars") } in - sk {it = [gl', info']; sigma = sigma';} fk } - -let merge_failures x y = - match x, y with - | _, ReachedLimit - | ReachedLimit, _ -> ReachedLimit - | NotApplicable, NotApplicable -> NotApplicable - -let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft sk - (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls } - -let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac = - { skft = fun sk fk gls -> x.skft sk - (fun f -> (y f).skft sk fk gls) gls } - -let is_Prop env sigma concl = - let ty = Retyping.get_type_of env sigma concl in - match kind_of_term ty with - | Sort (Prop Null) -> true - | _ -> false - -let is_unique env concl = - try - let (cl,u), args = dest_class_app env concl in - cl.cl_unique - with e when Errors.noncritical e -> false - -let needs_backtrack env evd oev concl = - if Option.is_empty oev || is_Prop env evd concl then - occur_existential concl - else true - -let hints_tac hints = - { skft = fun sk fk {it = gl,info; sigma = s;} -> - let env = Goal.V82.env s gl in - let concl = Goal.V82.concl s gl in - let tacgl = {it = gl; sigma = s;} in - let poss = e_possible_resolve hints info.hints s concl in - let unique = is_unique env concl in - let rec aux i foundone = function - | (tac, _, b, name, pp) :: tl -> - let derivs = path_derivate info.auto_cut name in - let res = - try - if path_matches derivs [] then None else Some (tac tacgl) - with e when catchable e -> None - in - (match res with - | None -> aux i foundone tl - | Some {it = gls; sigma = s';} -> - if !typeclasses_debug then - msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev s gl); - let sgls = - evars_to_goals - (fun evm ev evi -> - if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && - (not info.only_classes || Typeclasses.is_class_evar evm evi) - then Typeclasses.mark_unresolvable evi, true - else evi, false) s' - in - let newgls, s' = - let gls' = List.map (fun g -> (None, g)) gls in - match sgls with - | None -> gls', s' - | Some (evgls, s') -> - if not !typeclasses_dependency_order then - (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') - else - (* Reorder with dependent subgoals. *) - let evm = List.fold_left - (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in - let gls = top_sort s' evm in - (List.map (fun ev -> Some ev, ev) gls, s') - in - let gls' = List.map_i - (fun j (evar, g) -> - let info = - { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; - is_evar = evar; - hints = - if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) - (Goal.V82.hyps s' gl)) - then make_autogoal_hints info.only_classes - ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s';} - else info.hints; - auto_cut = derivs } - in g, info) 1 newgls in - let glsv = {it = gls'; sigma = s';} in - let fk' = - (fun e -> - let do_backtrack = - if unique then occur_existential concl - else if info.unique then true - else if List.is_empty gls' then - needs_backtrack env s' info.is_evar concl - else true - in - let e' = match foundone with None -> e | Some e' -> merge_failures e e' in - if !typeclasses_debug then - msg_debug - ((if do_backtrack then str"Backtracking after " - else str "Not backtracking after ") - ++ Lazy.force pp); - if do_backtrack then aux (succ i) (Some e') tl - else fk e') - in - sk glsv fk') - | [] -> - if foundone == None && !typeclasses_debug then - msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ - Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ - spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); - match foundone with - | Some e -> fk e - | None -> fk NotApplicable - in aux 1 None poss } - -let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = - let rec aux s (acc : autogoal list list) fk = function - | (gl,info) :: gls -> - Control.check_for_interrupt (); - (match info.is_evar with - | Some ev when Evd.is_defined s ev -> aux s acc fk gls - | _ -> - second.skft - (fun {it=gls';sigma=s'} fk' -> - let fk'' = - if not info.unique && List.is_empty gls' && - not (needs_backtrack (Goal.V82.env s gl) s - info.is_evar (Goal.V82.concl s gl)) - then fk - else fk' - in - aux s' (gls'::acc) fk'' gls) - fk {it = (gl,info); sigma = s; }) - | [] -> Somek2 (List.rev acc, s, fk) - in fun {it = gls; sigma = s; } fk -> - let rec aux' = function - | Nonek2 e -> fk e - | Somek2 (res, s', fk') -> - let goals' = List.concat res in - sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e)) - in aux' (aux s [] (fun e -> Nonek2 e) gls) - -let then_tac (first : atac) (second : atac) : atac = - { skft = fun sk fk -> first.skft (then_list second sk) fk } - -let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = - t.skft (fun x _ -> Some x) (fun _ -> None) gl - -type run_list_res = auto_result optionk - -let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = - (then_list t (fun x fk -> Somek (x, fk))) - gl - (fun _ -> Nonek) - -let fail_tac reason : atac = - { skft = fun sk fk _ -> fk reason } - -let rec fix (t : 'a tac) : 'a tac = - then_tac t { skft = fun sk fk -> (fix t).skft sk fk } - -let rec fix_limit limit (t : 'a tac) : 'a tac = - if Int.equal limit 0 then fail_tac ReachedLimit - else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } - -let fix_iterative t = - let rec aux depth = - or_else_tac (fix_limit depth t) - (function - | NotApplicable as e -> fail_tac e - | ReachedLimit -> aux (succ depth)) - in aux 1 - -let fix_iterative_limit limit (t : 'a tac) : 'a tac = - let rec aux depth = - if Int.equal depth limit then fail_tac ReachedLimit - else or_tac (fix_limit depth t) { skft = fun sk fk -> (aux (succ depth)).skft sk fk } - in aux 1 - -let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g = - let hints = make_autogoal_hints only_classes ~st g in - (g.it, { hints = hints ; is_evar = ev; unique = unique; - only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); - auto_path = []; auto_cut = cut }) - - -let cut_of_hints h = - List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h - -let make_autogoals ?(only_classes=true) ?(unique=false) - ?(st=full_transparent_state) hints gs evm' = - let cut = cut_of_hints hints in - { it = List.map_i (fun i g -> - let (gl, auto) = make_autogoal ~only_classes ~unique - ~st cut (Some g) {it = g; sigma = evm'; } in - (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; } - -let get_result r = - match r with - | Nonek -> None - | Somek (gls, fk) -> Some (gls.sigma,fk) - -let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) p evm hints tac = - match evars_to_goals p evm with - | None -> None (* This happens only because there's no evar having p *) - | Some (goals, evm') -> - let goals = - if !typeclasses_dependency_order then - top_sort evm' goals - else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) - in - let res = run_list_tac tac p goals - (make_autogoals ~only_classes ~unique ~st hints goals evm') in - match get_result res with - | None -> raise Not_found - | Some (evm', fk) -> - Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) - -let eauto_tac hints = - then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) - -let eauto_tac ?limit hints = - if get_typeclasses_iterative_deepening () then - match limit with - | None -> fix_iterative (eauto_tac hints) - | Some limit -> fix_iterative_limit limit (eauto_tac hints) - else - match limit with - | None -> fix (eauto_tac hints) - | Some limit -> fix_limit limit (eauto_tac hints) - -let real_eauto ?limit unique st hints p evd = - let res = - run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints) - in - match res with - | None -> evd - | Some (evd', fk) -> - if unique then - (match get_result (fk NotApplicable) with - | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" - | None -> evd') - else evd' - -let resolve_all_evars_once debug limit unique p evd = - let db = searchtable_map typeclasses_db in - real_eauto ?limit unique (Hint_db.transparent_state db) [db] p evd - -let eauto ?(only_classes=true) ?st ?limit hints g = - let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in - match run_tac (eauto_tac ?limit hints) gl with - | None -> raise Not_found - | Some {it = goals; sigma = s; } -> - {it = List.map fst goals; sigma = s;} - -(** We compute dependencies via a union-find algorithm. - Beware of the imperative effects on the partition structure, - it should not be shared, but only used locally. *) - -module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) - -let deps_of_constraints cstrs evm p = - List.iter (fun (_, _, x, y) -> - let evx = Evarutil.undefined_evars_of_term evm x in - let evy = Evarutil.undefined_evars_of_term evm y in - Intpart.union_set (Evar.Set.union evx evy) p) - cstrs - -let evar_dependencies evm p = - Evd.fold_undefined - (fun ev evi _ -> - let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) - in Intpart.union_set evars p) - evm () - -let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = - let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in - let (gl,t,sigma) = - Goal.V82.mk_goal sigma nc gl Store.empty in - let gls = { it = gl ; sigma = sigma; } in - let hints = searchtable_map typeclasses_db in - let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in - let evd = sig_sig gls' in - let t' = let (ev, inst) = destEvar t in - mkEvar (ev, Array.of_list subst) - in - let term = Evarutil.nf_evar evd t' in - evd, term - -let _ = - Typeclasses.solve_instantiation_problem := - (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) - -(** [split_evars] returns groups of undefined evars according to dependencies *) - -let split_evars evm = - let p = Intpart.create () in - evar_dependencies evm p; - deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; - Intpart.partition p - -let is_inference_forced p evd ev = - try - let evi = Evd.find_undefined evd ev in - if Typeclasses.is_resolvable evi && snd (p ev evi) - then - let (loc, k) = evar_source ev evd in - match k with - | Evar_kinds.ImplicitArg (_, _, b) -> b - | Evar_kinds.QuestionMark _ -> false - | _ -> true - else true - with Not_found -> assert false - -let is_mandatory p comp evd = - Evar.Set.exists (is_inference_forced p evd) comp - -(** In case of unsatisfiable constraints, build a nice error message *) - -let error_unresolvable env comp evd = - let evd = Evarutil.nf_evar_map_undefined evd in - let is_part ev = match comp with - | None -> true - | Some s -> Evar.Set.mem ev s - in - let fold ev evi (found, accu) = - let ev_class = class_of_constr evi.evar_concl in - if not (Option.is_empty ev_class) && is_part ev then - (* focus on one instance if only one was searched for *) - if not found then (true, Some ev) - else (found, None) - else (found, accu) - in - let (_, ev) = Evd.fold_undefined fold evd (true, None) in - Pretype_errors.unsatisfiable_constraints - (Evarutil.nf_env_evar evd env) evd ev comp - -(** Check if an evar is concerned by the current resolution attempt, - (and in particular is in the current component), and also update - its evar_info. - Invariant : this should only be applied to undefined evars, - and return undefined evar_info *) - -let select_and_update_evars p oevd in_comp evd ev evi = - assert (evi.evar_body == Evar_empty); - try - let oevi = Evd.find_undefined oevd ev in - if Typeclasses.is_resolvable oevi then - Typeclasses.mark_unresolvable evi, - (in_comp ev && p evd ev evi) - else evi, false - with Not_found -> - Typeclasses.mark_unresolvable evi, p evd ev evi - -(** Do we still have unresolved evars that should be resolved ? *) - -let has_undefined p oevd evd = - let check ev evi = snd (p oevd ev evi) in - Evar.Map.exists check (Evd.undefined_map evd) - -(** Revert the resolvability status of evars after resolution, - potentially unprotecting some evars that were set unresolvable - just for this call to resolution. *) - -let revert_resolvability oevd evd = - let map ev evi = - try - if not (Typeclasses.is_resolvable evi) then - let evi' = Evd.find_undefined oevd ev in - if Typeclasses.is_resolvable evi' then - Typeclasses.mark_resolvable evi - else evi - else evi - with Not_found -> evi - in - Evd.raw_map_undefined map evd - -(** If [do_split] is [true], we try to separate the problem in - several components and then solve them separately *) - -exception Unresolved - -let resolve_all_evars debug m unique env p oevd do_split fail = - let split = if do_split then split_evars oevd else [Evar.Set.empty] in - let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true - in - let rec docomp evd = function - | [] -> revert_resolvability oevd evd - | comp :: comps -> - let p = select_and_update_evars p oevd (in_comp comp) in - try - let evd' = resolve_all_evars_once debug m unique p evd in - if has_undefined p oevd evd' then raise Unresolved; - docomp evd' comps - with Unresolved | Not_found -> - if fail && (not do_split || is_mandatory (p evd) comp evd) - then (* Unable to satisfy the constraints. *) - let comp = if do_split then Some comp else None in - error_unresolvable env comp evd - else (* Best effort: do nothing on this component *) - docomp evd comps - in docomp oevd split - -let initial_select_evars filter = - fun evd ev evi -> - filter ev (snd evi.Evd.evar_source) && - Typeclasses.is_class_evar evd evi - -let resolve_typeclass_evars debug m unique env evd filter split fail = - let evd = - try Evarconv.consider_remaining_unif_problems - ~ts:(Typeclasses.classes_transparent_state ()) env evd - with e when Errors.noncritical e -> evd - in - resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail - -let solve_inst debug depth env evd filter unique split fail = - resolve_typeclass_evars debug depth unique env evd filter split fail - -let _ = - Typeclasses.solve_instantiations_problem := - solve_inst false !typeclasses_depth - -let set_typeclasses_debug d = (:=) typeclasses_debug d; - Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth - -let get_typeclasses_debug () = !typeclasses_debug - -let set_typeclasses_depth d = (:=) typeclasses_depth d; - Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth - -let get_typeclasses_depth () = !typeclasses_depth - -open Goptions - -let set_typeclasses_debug = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "debug output for typeclasses proof search"; - optkey = ["Typeclasses";"Debug"]; - optread = get_typeclasses_debug; - optwrite = set_typeclasses_debug; } - -let set_typeclasses_depth = - declare_int_option - { optsync = true; - optdepr = false; - optname = "depth for typeclasses proof search"; - optkey = ["Typeclasses";"Depth"]; - optread = get_typeclasses_depth; - optwrite = set_typeclasses_depth; } - -let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = - try - let dbs = List.map_filter - (fun db -> try Some (searchtable_map db) - with e when Errors.noncritical e -> None) - dbs - in - let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in - eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl - with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl - -(** Take the head of the arity of a constr. - Used in the partial application tactic. *) - -let rec head_of_constr t = - let t = strip_outer_cast(collapse_appl t) in - match kind_of_term t with - | Prod (_,_,c2) -> head_of_constr c2 - | LetIn (_,_,_,c2) -> head_of_constr c2 - | App (f,args) -> head_of_constr f - | _ -> t - -let head_of_constr h c = - let c = head_of_constr c in - letin_tac None (Name h) c None Locusops.allHyps - -let not_evar c = match kind_of_term c with -| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") -| _ -> Proofview.tclUNIT () - -let is_ground c gl = - if Evarutil.is_ground_term (project gl) c then tclIDTAC gl - else tclFAIL 0 (str"Not ground") gl - -let autoapply c i gl = - let flags = auto_unif_flags Evar.Set.empty - (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in - let cty = pf_unsafe_type_of gl c in - let ce = mk_clenv_from gl (c,cty) in - let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),ce) } in - Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/ltac/class_tactics.mli b/ltac/class_tactics.mli deleted file mode 100644 index f1bcfa7dd4..0000000000 --- a/ltac/class_tactics.mli +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool - -val set_typeclasses_debug : bool -> unit -val get_typeclasses_debug : unit -> bool - -val set_typeclasses_depth : int option -> unit -val get_typeclasses_depth : unit -> int option - -val progress_evars : unit Proofview.tactic -> unit Proofview.tactic - -val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> - Hints.hint_db_name list -> tactic - -val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic - -val not_evar : constr -> unit Proofview.tactic - -val is_ground : constr -> tactic - -val autoapply : constr -> Hints.hint_db_name -> tactic diff --git a/ltac/eauto.ml b/ltac/eauto.ml deleted file mode 100644 index 9cfb805d4c..0000000000 --- a/ltac/eauto.ml +++ /dev/null @@ -1,526 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let t1 = Tacmach.New.pf_unsafe_type_of gl c in - let t2 = Tacmach.New.pf_concl gl in - if occur_existential t1 || occur_existential t2 then - Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) - else exact_check c - end } - -let assumption id = e_give_exact (mkVar id) - -let e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) - end } - -let registered_e_assumption = - Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) - (Tacmach.New.pf_ids_of_hyps gl)) - end } - -let eval_uconstrs ist cs = - let flags = { - Pretyping.use_typeclasses = false; - use_unif_heuristics = true; - use_hook = Some Pfedit.solve_by_implicit_tactic; - fail_evar = false; - expand_evars = true - } in - List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs - -(************************************************************************) -(* PROLOG tactic *) -(************************************************************************) - -(*s Tactics handling a list of goals. *) - -(* first_goal : goal list sigma -> goal sigma *) - -let first_goal gls = - let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in - if List.is_empty gl then error "first_goal"; - { Evd.it = List.hd gl; Evd.sigma = sig_0; } - -(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) - -let apply_tac_list tac glls = - let (sigr,lg) = unpackage glls in - match lg with - | (g1::rest) -> - let gl = apply_sig_tac sigr tac g1 in - repackage sigr (gl@rest) - | _ -> error "apply_tac_list" - -let one_step l gl = - [Proofview.V82.of_tactic Tactics.intro] - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) - @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) - -let rec prolog l n gl = - if n <= 0 then error "prolog - failure"; - let prol = (prolog l (n-1)) in - (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl - -let out_term = function - | IsConstr (c, _) -> c - | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) - -let prolog_tac l n = - Proofview.V82.tactic begin fun gl -> - let map c = - let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in - let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in - out_term c - in - let l = List.map map l in - try (prolog l n gl) - with UserError ("Refiner.tclFIRST",_) -> - errorlabstrm "Prolog.prolog" (str "Prolog failed.") - end - -open Auto -open Unification - -(***************************************************************************) -(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) -(***************************************************************************) - -let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) - -let unify_e_resolve poly flags (c,clenv) = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let clenv', c = connect_hint_clenv poly c clenv gl in - Proofview.V82.tactic - (fun gls -> - let clenv' = clenv_unique_resolver ~flags clenv' gls in - tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) - end } - -let hintmap_of hdc concl = - match hdc with - | None -> fun db -> Hint_db.map_none db - | Some hdc -> - if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) - else (fun db -> Hint_db.map_auto hdc concl db) - (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) - -let e_exact poly flags (c,clenv) = - let (c, _, _) = c in - let clenv', subst = - if poly then Clenv.refresh_undefined_univs clenv - else clenv, Univ.empty_level_subst - in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) - -let rec e_trivial_fail_db db_list local_db = - let next = Proofview.Goal.nf_enter { enter = begin fun gl -> - let d = Tacmach.New.pf_last_hyp gl in - let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in - e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) - end } in - Proofview.Goal.enter { enter = begin fun gl -> - let tacl = - registered_e_assumption :: - (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) - in - Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) - end } - -and e_my_find_search db_list local_db hdc concl = - let hint_of_db = hintmap_of hdc concl in - let hintl = - List.map_append (fun db -> - let flags = auto_flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, {pri = b; pat = p; code = t; poly = poly}) -> - let b = match Hints.repr_hint t with - | Unfold_nth _ -> 1 - | _ -> b - in - (b, - let tac = function - | Res_pf (term,cl) -> unify_resolve poly st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) - | Give_exact (c,cl) -> e_exact poly st (c,cl) - | Res_pf_THEN_trivial_fail (term,cl) -> - Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) - (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl - | Extern tacast -> conclPattern concl p tacast - in - let tac = run_hint t tac in - (tac, lazy (pr_hint t))) - in - List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in - try priority (e_my_find_search db_list local_db hd gl) - with Not_found -> [] - -let e_possible_resolve db_list local_db gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in - try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) - with Not_found -> [] - -let find_first_goal gls = - try first_goal gls with UserError _ -> assert false - -(*s The following module [SearchProblem] is used to instantiate the generic - exploration functor [Explore.Make]. *) - -type search_state = { - priority : int; - depth : int; (*r depth of search before failing *) - tacres : goal list sigma; - last_tactic : std_ppcmds Lazy.t; - dblist : hint_db list; - localdb : hint_db list; - prev : prev_search_state; - local_lemmas : Tacexpr.delayed_open_constr list; -} - -and prev_search_state = (* for info eauto *) - | Unknown - | Init - | State of search_state - -module SearchProblem = struct - - type state = search_state - - let success s = List.is_empty (sig_it s.tacres) - -(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) - - let filter_tactics glls l = -(* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) -(* let evars = Evarutil.nf_evars (Refiner.project glls) in *) -(* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) - let rec aux = function - | [] -> [] - | (tac, cost, pptac) :: tacl -> - try - let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in -(* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) -(* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) - (lgls, cost, pptac) :: aux tacl - with e when Errors.noncritical e -> - let e = Errors.push e in - Refiner.catch_failerror e; aux tacl - in aux l - - (* Ordering of states is lexicographic on depth (greatest first) then - number of remaining goals. *) - let compare s s' = - let d = s'.depth - s.depth in - let d' = Int.compare s.priority s'.priority in - let nbgoals s = List.length (sig_it s.tacres) in - if not (Int.equal d 0) then d - else if not (Int.equal d' 0) then d' - else Int.compare (nbgoals s) (nbgoals s') - - let branching s = - if Int.equal s.depth 0 then - [] - else - let ps = if s.prev == Unknown then Unknown else State s in - let lg = s.tacres in - let nbgl = List.length (sig_it lg) in - assert (nbgl > 0); - let g = find_first_goal lg in - let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in - let assumption_tacs = - let tacs = List.map map_assum (pf_ids_of_hyps g) in - let l = filter_tactics s.tacres tacs in - List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = List.tl s.localdb; - prev = ps; local_lemmas = s.local_lemmas}) l - in - let intro_tac = - let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in - List.map - (fun (lgls, cost, pp) -> - let g' = first_goal lgls in - let hintl = - make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in - let ldb = Hint_db.add_list (pf_env g') (project g') - hintl (List.hd s.localdb) in - { depth = s.depth; priority = cost; tacres = lgls; - last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb; prev = ps; - local_lemmas = s.local_lemmas}) - l - in - let rec_tacs = - let l = - filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) - in - List.map - (fun (lgls, cost, pp) -> - let nbgl' = List.length (sig_it lgls) in - if nbgl' < nbgl then - { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; - prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; - local_lemmas = s.local_lemmas } - else - let newlocal = - let hyps = pf_hyps g in - List.map (fun gl -> - let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in - let hyps' = pf_hyps gls in - if hyps' == hyps then List.hd s.localdb - else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) - (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) - in - { depth = pred s.depth; priority = cost; tacres = lgls; - dblist = s.dblist; last_tactic = pp; prev = ps; - localdb = newlocal @ List.tl s.localdb; - local_lemmas = s.local_lemmas }) - l - in - List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - - let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ - (Lazy.force s.last_tactic)) - -end - -module Search = Explore.Make(SearchProblem) - -(** Utilities for debug eauto / info eauto *) - -let global_debug_eauto = ref false -let global_info_eauto = ref false - -let _ = - Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; - Goptions.optname = "Debug Eauto"; - Goptions.optkey = ["Debug";"Eauto"]; - Goptions.optread = (fun () -> !global_debug_eauto); - Goptions.optwrite = (:=) global_debug_eauto } - -let _ = - Goptions.declare_bool_option - { Goptions.optsync = true; - Goptions.optdepr = false; - Goptions.optname = "Info Eauto"; - Goptions.optkey = ["Info";"Eauto"]; - Goptions.optread = (fun () -> !global_info_eauto); - Goptions.optwrite = (:=) global_info_eauto } - -let mk_eauto_dbg d = - if d == Debug || !global_debug_eauto then Debug - else if d == Info || !global_info_eauto then Info - else Off - -let pr_info_nop = function - | Info -> msg_debug (str "idtac.") - | _ -> () - -let pr_dbg_header = function - | Off -> () - | Debug -> msg_debug (str "(* debug eauto : *)") - | Info -> msg_debug (str "(* info eauto : *)") - -let pr_info dbg s = - if dbg != Info then () - else - let rec loop s = - match s.prev with - | Unknown | Init -> s.depth - | State sp -> - let mindepth = loop sp in - let indent = String.make (mindepth - sp.depth) ' ' in - msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); - mindepth - in - ignore (loop s) - -(** Eauto main code *) - -let make_initial_state dbg n gl dblist localdb lems = - { depth = n; - priority = 0; - tacres = tclIDTAC gl; - last_tactic = lazy (mt()); - dblist = dblist; - localdb = [localdb]; - prev = if dbg == Info then Init else Unknown; - local_lemmas = lems; - } - -let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in - let d = mk_eauto_dbg debug in - let tac = match in_depth,d with - | (true,Debug) -> Search.debug_depth_first - | (true,_) -> Search.depth_first - | (false,Debug) -> Search.debug_breadth_first - | (false,_) -> Search.breadth_first - in - try - pr_dbg_header d; - let s = tac (make_initial_state d p gl db_list local_db lems) in - pr_info d s; - s.tacres - with Not_found -> - pr_info_nop d; - error "eauto: search failed" - -(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) -(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) - -let eauto_with_bases ?(debug=Off) np lems db_list = - tclTRY (e_search_auto debug np lems db_list) - -let eauto ?(debug=Off) np lems dbnames = - let db_list = make_db_list dbnames in - tclTRY (e_search_auto debug np lems db_list) - -let full_eauto ?(debug=Off) n lems gl = - let dbnames = current_db_names () in - let dbnames = String.Set.remove "v62" dbnames in - let db_list = List.map searchtable_map (String.Set.elements dbnames) in - tclTRY (e_search_auto debug n lems db_list) gl - -let gen_eauto ?(debug=Off) np lems = function - | None -> Proofview.V82.tactic (full_eauto ~debug np lems) - | Some l -> Proofview.V82.tactic (eauto ~debug np lems l) - -let make_depth = function - | None -> !default_search_depth - | Some d -> d - -let make_dimension n = function - | None -> (true,make_depth n) - | Some d -> (false,d) - -let cons a l = a :: l - -let autounfolds db occs cls gl = - let unfolds = List.concat (List.map (fun dbname -> - let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - let hyps = pf_ids_of_hyps gl in - let ids = Idset.filter (fun id -> List.mem id hyps) ids in - Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in Proofview.V82.of_tactic (unfold_option unfolds cls) gl - -let autounfold db cls = - Proofview.V82.tactic begin fun gl -> - let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in - let tac = autounfolds db in - tclMAP (function - | OnHyp (id,occs,where) -> tac occs (Some (id,where)) - | OnConcl occs -> tac occs None) - cls gl - end - -let autounfold_tac db cls = - Proofview.tclUNIT () >>= fun () -> - let dbs = match db with - | None -> String.Set.elements (current_db_names ()) - | Some [] -> ["core"] - | Some l -> l - in - autounfold dbs cls - -let unfold_head env (ids, csts) c = - let rec aux c = - match kind_of_term c with - | Var id when Id.Set.mem id ids -> - (match Environ.named_body id env with - | Some b -> true, b - | None -> false, c) - | Const (cst,u as c) when Cset.mem cst csts -> - true, Environ.constant_value_in env c - | App (f, args) -> - (match aux f with - | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) - | false, _ -> - let done_, args' = - Array.fold_left_i (fun i (done_, acc) arg -> - if done_ then done_, arg :: acc - else match aux arg with - | true, arg' -> true, arg' :: acc - | false, arg' -> false, arg :: acc) - (false, []) args - in - if done_ then true, mkApp (f, Array.of_list (List.rev args')) - else false, c) - | _ -> - let done_ = ref false in - let c' = map_constr (fun c -> - if !done_ then c else - let x, c' = aux c in - done_ := x; c') c - in !done_, c' - in aux c - -let autounfold_one db cl = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let st = - List.fold_left (fun (i,c) dbname -> - let db = try searchtable_map dbname - with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db - in - let did, c' = unfold_head env st - (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) - in - if did then - match cl with - | Some hyp -> change_in_hyp None (make_change_arg c') hyp - | None -> convert_concl_no_check c' DEFAULTcast - else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") - end } diff --git a/ltac/eauto.mli b/ltac/eauto.mli deleted file mode 100644 index 8812093d5f..0000000000 --- a/ltac/eauto.mli +++ /dev/null @@ -1,33 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> unit Proofview.tactic - -val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic - -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> - hint_db_name list option -> unit Proofview.tactic - -val eauto_with_bases : - ?debug:Tacexpr.debug -> - bool * int -> - Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic - -val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic -val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic -val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic - -val make_dimension : int option -> int option -> bool * int diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index 7987d774d1..8e9f992f16 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -11,9 +11,7 @@ G_obligations Coretactics Autorewrite Extratactics -Eauto G_auto -Class_tactics G_class Rewrite G_rewrite diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml new file mode 100644 index 0000000000..4855598989 --- /dev/null +++ b/tactics/class_tactics.ml @@ -0,0 +1,903 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + if Evar.Map.mem ev !tosee then + visit ev (Evar.Map.find ev !tosee)) evs; + tosee := Evar.Map.remove ev !tosee; + l' := ev :: !l'; + in + while not (Evar.Map.is_empty !tosee) do + let ev, evi = Evar.Map.min_binding !tosee in + visit ev evi + done; + List.rev !l' + +let evars_to_goals p evm = + let goals = ref Evar.Map.empty in + let map ev evi = + let evi, goal = p evm ev evi in + let () = if goal then goals := Evar.Map.add ev evi !goals in + evi + in + let evm = Evd.raw_map_undefined map evm in + if Evar.Map.is_empty !goals then None + else Some (!goals, evm) + +(** Typeclasses instance search tactic / eauto *) + +open Auto + +open Unification + +let auto_core_unif_flags st freeze = { + modulo_conv_on_closed_terms = Some st; + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + modulo_delta = st; + modulo_delta_types = st; + check_applied_meta_types = false; + use_pattern_unification = true; + use_meta_bound_pattern_unification = true; + frozen_evars = freeze; + restrict_conv_on_strict_subterms = false; (* ? *) + modulo_betaiota = true; + modulo_eta = !typeclasses_modulo_eta; +} + +let auto_unif_flags freeze st = + let fl = auto_core_unif_flags st freeze in + { core_unify_flags = fl; + merge_unify_flags = fl; + subterm_unify_flags = fl; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + +let rec eq_constr_mod_evars x y = + match kind_of_term x, kind_of_term y with + | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true + | _, _ -> compare_constr eq_constr_mod_evars x y + +let progress_evars t = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let check = + Proofview.Goal.nf_enter { enter = begin fun gl' -> + let newconcl = Proofview.Goal.concl gl' in + if eq_constr_mod_evars concl newconcl + then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)") + else Proofview.tclUNIT () + end } + in t <*> check + end } + + +let e_give_exact flags poly (c,clenv) gl = + let (c, _, _) = c in + let c, gl = + if poly then + let clenv', subst = Clenv.refresh_undefined_univs clenv in + let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in + let c = Vars.subst_univs_level_constr subst c in + c, {gl with sigma = evd} + else c, gl + in + let t1 = pf_unsafe_type_of gl c in + tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl + +let unify_e_resolve poly flags = { enter = begin fun gls (c,clenv) -> + let clenv', c = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine true ~with_classes:false clenv' + end } + +let unify_resolve poly flags = { enter = begin fun gls (c,clenv) -> + let clenv', _ = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine false ~with_classes:false clenv' + end } + +let clenv_of_prods poly nprods (c, clenv) gl = + let (c, _, _) = c in + if poly || Int.equal nprods 0 then Some clenv + else + let ty = Tacmach.New.pf_unsafe_type_of gl c in + let diff = nb_prod ty - nprods in + if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) + Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) + else None + +let with_prods nprods poly (c, clenv) f = + Proofview.Goal.nf_enter { enter = begin fun gl -> + match clenv_of_prods poly nprods (c, clenv) gl with + | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") + | Some clenv' -> f.enter gl (c, clenv') + end } + +(** Hack to properly solve dependent evars that are typeclasses *) + +let rec e_trivial_fail_db db_list local_db goal = + let tacl = + Proofview.V82.of_tactic Eauto.registered_e_assumption :: + (tclTHEN (Proofview.V82.of_tactic Tactics.intro) + (function g'-> + let d = pf_last_hyp g' in + let hintl = make_resolve_hyp (pf_env g') (project g') d in + (e_trivial_fail_db db_list + (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: + (List.map (fun (x,_,_,_,_) -> x) + (e_trivial_resolve db_list local_db (project goal) (pf_concl goal))) + in + tclFIRST (List.map tclCOMPLETE tacl) goal + +and e_my_find_search db_list local_db hdc complete sigma concl = + let prods, concl = decompose_prod_assum concl in + let nprods = List.length prods in + let freeze = + try + let cl = Typeclasses.class_info (fst hdc) in + if cl.cl_strict then + Evd.evars_of_term concl + else Evar.Set.empty + with e when Errors.noncritical e -> Evar.Set.empty + in + let hintl = + List.map_append + (fun db -> + let tacs = + if Hint_db.use_dn db then (* Using dnet *) + Hint_db.map_eauto hdc concl db + else Hint_db.map_existential hdc concl db + in + let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) tacs) + (local_db::db_list) + in + let tac_of_hint = + fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> + let tac = function + | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) + | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) + | Res_pf_THEN_trivial_fail (term,cl) -> + Proofview.V82.tactic (tclTHEN + (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) + (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) + | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]))) + | Extern tacast -> conclPattern concl p tacast + in + let tac = Proofview.V82.of_tactic (run_hint t tac) in + let tac = if complete then tclCOMPLETE tac else tac in + match repr_hint t with + | Extern _ -> (tac,b,true, name, lazy (pr_hint t)) + | _ -> +(* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) + (tac,b,false, name, lazy (pr_hint t)) + in List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db sigma concl = + try + e_my_find_search db_list local_db + (decompose_app_bound concl) true sigma concl + with Bound | Not_found -> [] + +let e_possible_resolve db_list local_db sigma concl = + try + e_my_find_search db_list local_db + (decompose_app_bound concl) false sigma concl + with Bound | Not_found -> [] + +let catchable = function + | Refiner.FailError _ -> true + | e -> Logic.catchable_exception e + +let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) + +let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) + +type autoinfo = { hints : hint_db; is_evar: existential_key option; + only_classes: bool; unique : bool; + auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t; + auto_path : global_reference option list; + auto_cut : hints_path } +type autogoal = goal * autoinfo +type failure = NotApplicable | ReachedLimit +type 'ans fk = failure -> 'ans +type ('a,'ans) sk = 'a -> 'ans fk -> 'ans +type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } + +type auto_result = autogoal list sigma + +type atac = auto_result tac + +(* Some utility types to avoid the need of -rectypes *) + +type 'a optionk = + | Nonek + | Somek of 'a * 'a optionk fk + +type ('a,'b) optionk2 = + | Nonek2 of failure + | Somek2 of 'a * 'b * ('a,'b) optionk2 fk + +let make_resolve_hyp env sigma st flags only_classes pri decl = + let open Context.Named.Declaration in + let id = get_id decl in + let cty = Evarutil.nf_evar sigma (get_type decl) in + let rec iscl env ty = + let ctx, ar = decompose_prod_assum ty in + match kind_of_term (fst (decompose_app ar)) with + | Const (c,_) -> is_class (ConstRef c) + | Ind (i,_) -> is_class (IndRef i) + | _ -> + let env' = Environ.push_rel_context ctx env in + let ty' = whd_betadeltaiota env' ar in + if not (Term.eq_constr ty' ar) then iscl env' ty' + else false + in + let is_class = iscl env cty in + let keep = not only_classes || is_class in + if keep then + let c = mkVar id in + let name = PathHints [VarRef id] in + let hints = + if is_class then + let hints = build_subclasses ~check:false env sigma (VarRef id) None in + (List.map_append + (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) + (true,false,Flags.is_verbose()) pri false + (IsConstr (c,Univ.ContextSet.empty))) + hints) + else [] + in + (hints @ List.map_filter + (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) + with Failure _ | UserError _ -> None) + [make_exact_entry ~name env sigma pri false; + make_apply_entry ~name env sigma flags pri false]) + else [] + +let pf_filtered_hyps gls = + Goal.V82.hyps gls.Evd.sigma (sig_it gls) + +let make_hints g st only_classes sign = + let paths, hintlist = + List.fold_left + (fun (paths, hints) hyp -> + let consider = + let open Context.Named.Declaration in + try let t = Global.lookup_named (get_id hyp) |> get_type in + (* Section variable, reindex only if the type changed *) + not (Term.eq_constr t (get_type hyp)) + with Not_found -> true + in + if consider then + let path, hint = + PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp + in + (PathOr (paths, path), hint @ hints) + else (paths, hints)) + (PathEmpty, []) sign + in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) + +let make_autogoal_hints = + let cache = ref (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) + in + fun only_classes ?(st=full_transparent_state) g -> + let sign = pf_filtered_hyps g in + let (onlyc, sign', cached_hints) = !cache in + if onlyc == only_classes && + (sign == sign' || Environ.eq_named_context_val sign sign') + && Hint_db.transparent_state cached_hints == st + then + cached_hints + else + let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in + cache := (only_classes, sign, hints); hints + +let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac = + { skft = fun sk fk {it = gl,hints; sigma=s;} -> + let res = try Some (tac {it=gl; sigma=s;}) + with e when catchable e -> None in + match res with + | Some gls -> sk (f gls hints) fk + | None -> fk NotApplicable } + +let intro_tac : atac = + lift_tactic (Proofview.V82.of_tactic Tactics.intro) + (fun {it = gls; sigma = s} info -> + let gls' = + List.map (fun g' -> + let env = Goal.V82.env s g' in + let context = Environ.named_context_of_val (Goal.V82.hyps s g') in + let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) + (true,false,false) info.only_classes None (List.hd context) in + let ldb = Hint_db.add_list env s hint info.hints in + (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls + in {it = gls'; sigma = s;}) + +let normevars_tac : atac = + { skft = fun sk fk {it = (gl, info); sigma = s;} -> + let gl', sigma' = Goal.V82.nf_evar s gl in + let info' = { info with auto_last_tac = lazy (str"normevars") } in + sk {it = [gl', info']; sigma = sigma';} fk } + +let merge_failures x y = + match x, y with + | _, ReachedLimit + | ReachedLimit, _ -> ReachedLimit + | NotApplicable, NotApplicable -> NotApplicable + +let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = + { skft = fun sk fk gls -> x.skft sk + (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls } + +let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac = + { skft = fun sk fk gls -> x.skft sk + (fun f -> (y f).skft sk fk gls) gls } + +let is_Prop env sigma concl = + let ty = Retyping.get_type_of env sigma concl in + match kind_of_term ty with + | Sort (Prop Null) -> true + | _ -> false + +let is_unique env concl = + try + let (cl,u), args = dest_class_app env concl in + cl.cl_unique + with e when Errors.noncritical e -> false + +let needs_backtrack env evd oev concl = + if Option.is_empty oev || is_Prop env evd concl then + occur_existential concl + else true + +let hints_tac hints = + { skft = fun sk fk {it = gl,info; sigma = s;} -> + let env = Goal.V82.env s gl in + let concl = Goal.V82.concl s gl in + let tacgl = {it = gl; sigma = s;} in + let poss = e_possible_resolve hints info.hints s concl in + let unique = is_unique env concl in + let rec aux i foundone = function + | (tac, _, b, name, pp) :: tl -> + let derivs = path_derivate info.auto_cut name in + let res = + try + if path_matches derivs [] then None else Some (tac tacgl) + with e when catchable e -> None + in + (match res with + | None -> aux i foundone tl + | Some {it = gls; sigma = s';} -> + if !typeclasses_debug then + msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp + ++ str" on" ++ spc () ++ pr_ev s gl); + let sgls = + evars_to_goals + (fun evm ev evi -> + if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) && + (not info.only_classes || Typeclasses.is_class_evar evm evi) + then Typeclasses.mark_unresolvable evi, true + else evi, false) s' + in + let newgls, s' = + let gls' = List.map (fun g -> (None, g)) gls in + match sgls with + | None -> gls', s' + | Some (evgls, s') -> + if not !typeclasses_dependency_order then + (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s') + else + (* Reorder with dependent subgoals. *) + let evm = List.fold_left + (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in + let gls = top_sort s' evm in + (List.map (fun ev -> Some ev, ev) gls, s') + in + let gls' = List.map_i + (fun j (evar, g) -> + let info = + { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp; + is_evar = evar; + hints = + if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) + (Goal.V82.hyps s' gl)) + then make_autogoal_hints info.only_classes + ~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s';} + else info.hints; + auto_cut = derivs } + in g, info) 1 newgls in + let glsv = {it = gls'; sigma = s';} in + let fk' = + (fun e -> + let do_backtrack = + if unique then occur_existential concl + else if info.unique then true + else if List.is_empty gls' then + needs_backtrack env s' info.is_evar concl + else true + in + let e' = match foundone with None -> e | Some e' -> merge_failures e e' in + if !typeclasses_debug then + msg_debug + ((if do_backtrack then str"Backtracking after " + else str "Not backtracking after ") + ++ Lazy.force pp); + if do_backtrack then aux (succ i) (Some e') tl + else fk e') + in + sk glsv fk') + | [] -> + if foundone == None && !typeclasses_debug then + msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ + Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ + spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); + match foundone with + | Some e -> fk e + | None -> fk NotApplicable + in aux 1 None poss } + +let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = + let rec aux s (acc : autogoal list list) fk = function + | (gl,info) :: gls -> + Control.check_for_interrupt (); + (match info.is_evar with + | Some ev when Evd.is_defined s ev -> aux s acc fk gls + | _ -> + second.skft + (fun {it=gls';sigma=s'} fk' -> + let fk'' = + if not info.unique && List.is_empty gls' && + not (needs_backtrack (Goal.V82.env s gl) s + info.is_evar (Goal.V82.concl s gl)) + then fk + else fk' + in + aux s' (gls'::acc) fk'' gls) + fk {it = (gl,info); sigma = s; }) + | [] -> Somek2 (List.rev acc, s, fk) + in fun {it = gls; sigma = s; } fk -> + let rec aux' = function + | Nonek2 e -> fk e + | Somek2 (res, s', fk') -> + let goals' = List.concat res in + sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e)) + in aux' (aux s [] (fun e -> Nonek2 e) gls) + +let then_tac (first : atac) (second : atac) : atac = + { skft = fun sk fk -> first.skft (then_list second sk) fk } + +let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = + t.skft (fun x _ -> Some x) (fun _ -> None) gl + +type run_list_res = auto_result optionk + +let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res = + (then_list t (fun x fk -> Somek (x, fk))) + gl + (fun _ -> Nonek) + +let fail_tac reason : atac = + { skft = fun sk fk _ -> fk reason } + +let rec fix (t : 'a tac) : 'a tac = + then_tac t { skft = fun sk fk -> (fix t).skft sk fk } + +let rec fix_limit limit (t : 'a tac) : 'a tac = + if Int.equal limit 0 then fail_tac ReachedLimit + else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } + +let fix_iterative t = + let rec aux depth = + or_else_tac (fix_limit depth t) + (function + | NotApplicable as e -> fail_tac e + | ReachedLimit -> aux (succ depth)) + in aux 1 + +let fix_iterative_limit limit (t : 'a tac) : 'a tac = + let rec aux depth = + if Int.equal depth limit then fail_tac ReachedLimit + else or_tac (fix_limit depth t) { skft = fun sk fk -> (aux (succ depth)).skft sk fk } + in aux 1 + +let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g = + let hints = make_autogoal_hints only_classes ~st g in + (g.it, { hints = hints ; is_evar = ev; unique = unique; + only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none"); + auto_path = []; auto_cut = cut }) + + +let cut_of_hints h = + List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h + +let make_autogoals ?(only_classes=true) ?(unique=false) + ?(st=full_transparent_state) hints gs evm' = + let cut = cut_of_hints hints in + { it = List.map_i (fun i g -> + let (gl, auto) = make_autogoal ~only_classes ~unique + ~st cut (Some g) {it = g; sigma = evm'; } in + (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; } + +let get_result r = + match r with + | Nonek -> None + | Somek (gls, fk) -> Some (gls.sigma,fk) + +let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) p evm hints tac = + match evars_to_goals p evm with + | None -> None (* This happens only because there's no evar having p *) + | Some (goals, evm') -> + let goals = + if !typeclasses_dependency_order then + top_sort evm' goals + else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals) + in + let res = run_list_tac tac p goals + (make_autogoals ~only_classes ~unique ~st hints goals evm') in + match get_result res with + | None -> raise Not_found + | Some (evm', fk) -> + Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk) + +let eauto_tac hints = + then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) + +let eauto_tac ?limit hints = + if get_typeclasses_iterative_deepening () then + match limit with + | None -> fix_iterative (eauto_tac hints) + | Some limit -> fix_iterative_limit limit (eauto_tac hints) + else + match limit with + | None -> fix (eauto_tac hints) + | Some limit -> fix_limit limit (eauto_tac hints) + +let real_eauto ?limit unique st hints p evd = + let res = + run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints) + in + match res with + | None -> evd + | Some (evd', fk) -> + if unique then + (match get_result (fk NotApplicable) with + | Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions" + | None -> evd') + else evd' + +let resolve_all_evars_once debug limit unique p evd = + let db = searchtable_map typeclasses_db in + real_eauto ?limit unique (Hint_db.transparent_state db) [db] p evd + +let eauto ?(only_classes=true) ?st ?limit hints g = + let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in + match run_tac (eauto_tac ?limit hints) gl with + | None -> raise Not_found + | Some {it = goals; sigma = s; } -> + {it = List.map fst goals; sigma = s;} + +(** We compute dependencies via a union-find algorithm. + Beware of the imperative effects on the partition structure, + it should not be shared, but only used locally. *) + +module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) + +let deps_of_constraints cstrs evm p = + List.iter (fun (_, _, x, y) -> + let evx = Evarutil.undefined_evars_of_term evm x in + let evy = Evarutil.undefined_evars_of_term evm y in + Intpart.union_set (Evar.Set.union evx evy) p) + cstrs + +let evar_dependencies evm p = + Evd.fold_undefined + (fun ev evi _ -> + let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi) + in Intpart.union_set evars p) + evm () + +let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = + let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in + let (gl,t,sigma) = + Goal.V82.mk_goal sigma nc gl Store.empty in + let gls = { it = gl ; sigma = sigma; } in + let hints = searchtable_map typeclasses_db in + let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in + let evd = sig_sig gls' in + let t' = let (ev, inst) = destEvar t in + mkEvar (ev, Array.of_list subst) + in + let term = Evarutil.nf_evar evd t' in + evd, term + +let _ = + Typeclasses.solve_instantiation_problem := + (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) + +(** [split_evars] returns groups of undefined evars according to dependencies *) + +let split_evars evm = + let p = Intpart.create () in + evar_dependencies evm p; + deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; + Intpart.partition p + +let is_inference_forced p evd ev = + try + let evi = Evd.find_undefined evd ev in + if Typeclasses.is_resolvable evi && snd (p ev evi) + then + let (loc, k) = evar_source ev evd in + match k with + | Evar_kinds.ImplicitArg (_, _, b) -> b + | Evar_kinds.QuestionMark _ -> false + | _ -> true + else true + with Not_found -> assert false + +let is_mandatory p comp evd = + Evar.Set.exists (is_inference_forced p evd) comp + +(** In case of unsatisfiable constraints, build a nice error message *) + +let error_unresolvable env comp evd = + let evd = Evarutil.nf_evar_map_undefined evd in + let is_part ev = match comp with + | None -> true + | Some s -> Evar.Set.mem ev s + in + let fold ev evi (found, accu) = + let ev_class = class_of_constr evi.evar_concl in + if not (Option.is_empty ev_class) && is_part ev then + (* focus on one instance if only one was searched for *) + if not found then (true, Some ev) + else (found, None) + else (found, accu) + in + let (_, ev) = Evd.fold_undefined fold evd (true, None) in + Pretype_errors.unsatisfiable_constraints + (Evarutil.nf_env_evar evd env) evd ev comp + +(** Check if an evar is concerned by the current resolution attempt, + (and in particular is in the current component), and also update + its evar_info. + Invariant : this should only be applied to undefined evars, + and return undefined evar_info *) + +let select_and_update_evars p oevd in_comp evd ev evi = + assert (evi.evar_body == Evar_empty); + try + let oevi = Evd.find_undefined oevd ev in + if Typeclasses.is_resolvable oevi then + Typeclasses.mark_unresolvable evi, + (in_comp ev && p evd ev evi) + else evi, false + with Not_found -> + Typeclasses.mark_unresolvable evi, p evd ev evi + +(** Do we still have unresolved evars that should be resolved ? *) + +let has_undefined p oevd evd = + let check ev evi = snd (p oevd ev evi) in + Evar.Map.exists check (Evd.undefined_map evd) + +(** Revert the resolvability status of evars after resolution, + potentially unprotecting some evars that were set unresolvable + just for this call to resolution. *) + +let revert_resolvability oevd evd = + let map ev evi = + try + if not (Typeclasses.is_resolvable evi) then + let evi' = Evd.find_undefined oevd ev in + if Typeclasses.is_resolvable evi' then + Typeclasses.mark_resolvable evi + else evi + else evi + with Not_found -> evi + in + Evd.raw_map_undefined map evd + +(** If [do_split] is [true], we try to separate the problem in + several components and then solve them separately *) + +exception Unresolved + +let resolve_all_evars debug m unique env p oevd do_split fail = + let split = if do_split then split_evars oevd else [Evar.Set.empty] in + let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true + in + let rec docomp evd = function + | [] -> revert_resolvability oevd evd + | comp :: comps -> + let p = select_and_update_evars p oevd (in_comp comp) in + try + let evd' = resolve_all_evars_once debug m unique p evd in + if has_undefined p oevd evd' then raise Unresolved; + docomp evd' comps + with Unresolved | Not_found -> + if fail && (not do_split || is_mandatory (p evd) comp evd) + then (* Unable to satisfy the constraints. *) + let comp = if do_split then Some comp else None in + error_unresolvable env comp evd + else (* Best effort: do nothing on this component *) + docomp evd comps + in docomp oevd split + +let initial_select_evars filter = + fun evd ev evi -> + filter ev (snd evi.Evd.evar_source) && + Typeclasses.is_class_evar evd evi + +let resolve_typeclass_evars debug m unique env evd filter split fail = + let evd = + try Evarconv.consider_remaining_unif_problems + ~ts:(Typeclasses.classes_transparent_state ()) env evd + with e when Errors.noncritical e -> evd + in + resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail + +let solve_inst debug depth env evd filter unique split fail = + resolve_typeclass_evars debug depth unique env evd filter split fail + +let _ = + Typeclasses.solve_instantiations_problem := + solve_inst false !typeclasses_depth + +let set_typeclasses_debug d = (:=) typeclasses_debug d; + Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth + +let get_typeclasses_debug () = !typeclasses_debug + +let set_typeclasses_depth d = (:=) typeclasses_depth d; + Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth + +let get_typeclasses_depth () = !typeclasses_depth + +open Goptions + +let set_typeclasses_debug = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "debug output for typeclasses proof search"; + optkey = ["Typeclasses";"Debug"]; + optread = get_typeclasses_debug; + optwrite = set_typeclasses_debug; } + +let set_typeclasses_depth = + declare_int_option + { optsync = true; + optdepr = false; + optname = "depth for typeclasses proof search"; + optkey = ["Typeclasses";"Depth"]; + optread = get_typeclasses_depth; + optwrite = set_typeclasses_depth; } + +let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = + try + let dbs = List.map_filter + (fun db -> try Some (searchtable_map db) + with e when Errors.noncritical e -> None) + dbs + in + let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl + with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl + +(** Take the head of the arity of a constr. + Used in the partial application tactic. *) + +let rec head_of_constr t = + let t = strip_outer_cast(collapse_appl t) in + match kind_of_term t with + | Prod (_,_,c2) -> head_of_constr c2 + | LetIn (_,_,_,c2) -> head_of_constr c2 + | App (f,args) -> head_of_constr f + | _ -> t + +let head_of_constr h c = + let c = head_of_constr c in + letin_tac None (Name h) c None Locusops.allHyps + +let not_evar c = match kind_of_term c with +| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") +| _ -> Proofview.tclUNIT () + +let is_ground c gl = + if Evarutil.is_ground_term (project gl) c then tclIDTAC gl + else tclFAIL 0 (str"Not ground") gl + +let autoapply c i gl = + let flags = auto_unif_flags Evar.Set.empty + (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in + let cty = pf_unsafe_type_of gl c in + let ce = mk_clenv_from gl (c,cty) in + let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),ce) } in + Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli new file mode 100644 index 0000000000..f1bcfa7dd4 --- /dev/null +++ b/tactics/class_tactics.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool + +val set_typeclasses_debug : bool -> unit +val get_typeclasses_debug : unit -> bool + +val set_typeclasses_depth : int option -> unit +val get_typeclasses_depth : unit -> int option + +val progress_evars : unit Proofview.tactic -> unit Proofview.tactic + +val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> + Hints.hint_db_name list -> tactic + +val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic + +val not_evar : constr -> unit Proofview.tactic + +val is_ground : constr -> tactic + +val autoapply : constr -> Hints.hint_db_name -> tactic diff --git a/tactics/eauto.ml b/tactics/eauto.ml new file mode 100644 index 0000000000..9cfb805d4c --- /dev/null +++ b/tactics/eauto.ml @@ -0,0 +1,526 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + let t1 = Tacmach.New.pf_unsafe_type_of gl c in + let t2 = Tacmach.New.pf_concl gl in + if occur_existential t1 || occur_existential t2 then + Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (Proofview.V82.tactic (exact_no_check c)) + else exact_check c + end } + +let assumption id = e_give_exact (mkVar id) + +let e_assumption = + Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) + end } + +let registered_e_assumption = + Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) + (Tacmach.New.pf_ids_of_hyps gl)) + end } + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs + +(************************************************************************) +(* PROLOG tactic *) +(************************************************************************) + +(*s Tactics handling a list of goals. *) + +(* first_goal : goal list sigma -> goal sigma *) + +let first_goal gls = + let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in + if List.is_empty gl then error "first_goal"; + { Evd.it = List.hd gl; Evd.sigma = sig_0; } + +(* tactic -> tactic_list : Apply a tactic to the first goal in the list *) + +let apply_tac_list tac glls = + let (sigr,lg) = unpackage glls in + match lg with + | (g1::rest) -> + let gl = apply_sig_tac sigr tac g1 in + repackage sigr (gl@rest) + | _ -> error "apply_tac_list" + +let one_step l gl = + [Proofview.V82.of_tactic Tactics.intro] + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) + @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) + +let rec prolog l n gl = + if n <= 0 then error "prolog - failure"; + let prol = (prolog l (n-1)) in + (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl + +let out_term = function + | IsConstr (c, _) -> c + | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + +let prolog_tac l n = + Proofview.V82.tactic begin fun gl -> + let map c = + let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in + out_term c + in + let l = List.map map l in + try (prolog l n gl) + with UserError ("Refiner.tclFIRST",_) -> + errorlabstrm "Prolog.prolog" (str "Prolog failed.") + end + +open Auto +open Unification + +(***************************************************************************) +(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) +(***************************************************************************) + +let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) + +let unify_e_resolve poly flags (c,clenv) = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + Proofview.V82.tactic + (fun gls -> + let clenv' = clenv_unique_resolver ~flags clenv' gls in + tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) + end } + +let hintmap_of hdc concl = + match hdc with + | None -> fun db -> Hint_db.map_none db + | Some hdc -> + if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) + else (fun db -> Hint_db.map_auto hdc concl db) + (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) + +let e_exact poly flags (c,clenv) = + let (c, _, _) = c in + let clenv', subst = + if poly then Clenv.refresh_undefined_univs clenv + else clenv, Univ.empty_level_subst + in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c) + +let rec e_trivial_fail_db db_list local_db = + let next = Proofview.Goal.nf_enter { enter = begin fun gl -> + let d = Tacmach.New.pf_last_hyp gl in + let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in + e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) + end } in + Proofview.Goal.enter { enter = begin fun gl -> + let tacl = + registered_e_assumption :: + (Tacticals.New.tclTHEN Tactics.intro next) :: + (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) + in + Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) + end } + +and e_my_find_search db_list local_db hdc concl = + let hint_of_db = hintmap_of hdc concl in + let hintl = + List.map_append (fun db -> + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) + in + let tac_of_hint = + fun (st, {pri = b; pat = p; code = t; poly = poly}) -> + let b = match Hints.repr_hint t with + | Unfold_nth _ -> 1 + | _ -> b + in + (b, + let tac = function + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) + | Give_exact (c,cl) -> e_exact poly st (c,cl) + | Res_pf_THEN_trivial_fail (term,cl) -> + Tacticals.New.tclTHEN (unify_e_resolve poly st (term,cl)) + (e_trivial_fail_db db_list local_db) + | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl + | Extern tacast -> conclPattern concl p tacast + in + let tac = run_hint t tac in + (tac, lazy (pr_hint t))) + in + List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db gl = + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try priority (e_my_find_search db_list local_db hd gl) + with Not_found -> [] + +let e_possible_resolve db_list local_db gl = + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) + with Not_found -> [] + +let find_first_goal gls = + try first_goal gls with UserError _ -> assert false + +(*s The following module [SearchProblem] is used to instantiate the generic + exploration functor [Explore.Make]. *) + +type search_state = { + priority : int; + depth : int; (*r depth of search before failing *) + tacres : goal list sigma; + last_tactic : std_ppcmds Lazy.t; + dblist : hint_db list; + localdb : hint_db list; + prev : prev_search_state; + local_lemmas : Tacexpr.delayed_open_constr list; +} + +and prev_search_state = (* for info eauto *) + | Unknown + | Init + | State of search_state + +module SearchProblem = struct + + type state = search_state + + let success s = List.is_empty (sig_it s.tacres) + +(* let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *) + + let filter_tactics glls l = +(* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) +(* let evars = Evarutil.nf_evars (Refiner.project glls) in *) +(* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) + let rec aux = function + | [] -> [] + | (tac, cost, pptac) :: tacl -> + try + let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in +(* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) +(* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) + (lgls, cost, pptac) :: aux tacl + with e when Errors.noncritical e -> + let e = Errors.push e in + Refiner.catch_failerror e; aux tacl + in aux l + + (* Ordering of states is lexicographic on depth (greatest first) then + number of remaining goals. *) + let compare s s' = + let d = s'.depth - s.depth in + let d' = Int.compare s.priority s'.priority in + let nbgoals s = List.length (sig_it s.tacres) in + if not (Int.equal d 0) then d + else if not (Int.equal d' 0) then d' + else Int.compare (nbgoals s) (nbgoals s') + + let branching s = + if Int.equal s.depth 0 then + [] + else + let ps = if s.prev == Unknown then Unknown else State s in + let lg = s.tacres in + let nbgl = List.length (sig_it lg) in + assert (nbgl > 0); + let g = find_first_goal lg in + let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in + let assumption_tacs = + let tacs = List.map map_assum (pf_ids_of_hyps g) in + let l = filter_tactics s.tacres tacs in + List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = List.tl s.localdb; + prev = ps; local_lemmas = s.local_lemmas}) l + in + let intro_tac = + let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in + List.map + (fun (lgls, cost, pp) -> + let g' = first_goal lgls in + let hintl = + make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in + let ldb = Hint_db.add_list (pf_env g') (project g') + hintl (List.hd s.localdb) in + { depth = s.depth; priority = cost; tacres = lgls; + last_tactic = pp; dblist = s.dblist; + localdb = ldb :: List.tl s.localdb; prev = ps; + local_lemmas = s.local_lemmas}) + l + in + let rec_tacs = + let l = + filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + in + List.map + (fun (lgls, cost, pp) -> + let nbgl' = List.length (sig_it lgls) in + if nbgl' < nbgl then + { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; + prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; + local_lemmas = s.local_lemmas } + else + let newlocal = + let hyps = pf_hyps g in + List.map (fun gl -> + let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in + let hyps' = pf_hyps gls in + if hyps' == hyps then List.hd s.localdb + else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) + (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) + in + { depth = pred s.depth; priority = cost; tacres = lgls; + dblist = s.dblist; last_tactic = pp; prev = ps; + localdb = newlocal @ List.tl s.localdb; + local_lemmas = s.local_lemmas }) + l + in + List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + + let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + (Lazy.force s.last_tactic)) + +end + +module Search = Explore.Make(SearchProblem) + +(** Utilities for debug eauto / info eauto *) + +let global_debug_eauto = ref false +let global_info_eauto = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Debug Eauto"; + Goptions.optkey = ["Debug";"Eauto"]; + Goptions.optread = (fun () -> !global_debug_eauto); + Goptions.optwrite = (:=) global_debug_eauto } + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Info Eauto"; + Goptions.optkey = ["Info";"Eauto"]; + Goptions.optread = (fun () -> !global_info_eauto); + Goptions.optwrite = (:=) global_info_eauto } + +let mk_eauto_dbg d = + if d == Debug || !global_debug_eauto then Debug + else if d == Info || !global_info_eauto then Info + else Off + +let pr_info_nop = function + | Info -> msg_debug (str "idtac.") + | _ -> () + +let pr_dbg_header = function + | Off -> () + | Debug -> msg_debug (str "(* debug eauto : *)") + | Info -> msg_debug (str "(* info eauto : *)") + +let pr_info dbg s = + if dbg != Info then () + else + let rec loop s = + match s.prev with + | Unknown | Init -> s.depth + | State sp -> + let mindepth = loop sp in + let indent = String.make (mindepth - sp.depth) ' ' in + msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + mindepth + in + ignore (loop s) + +(** Eauto main code *) + +let make_initial_state dbg n gl dblist localdb lems = + { depth = n; + priority = 0; + tacres = tclIDTAC gl; + last_tactic = lazy (mt()); + dblist = dblist; + localdb = [localdb]; + prev = if dbg == Info then Init else Unknown; + local_lemmas = lems; + } + +let e_search_auto debug (in_depth,p) lems db_list gl = + let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in + let d = mk_eauto_dbg debug in + let tac = match in_depth,d with + | (true,Debug) -> Search.debug_depth_first + | (true,_) -> Search.depth_first + | (false,Debug) -> Search.debug_breadth_first + | (false,_) -> Search.breadth_first + in + try + pr_dbg_header d; + let s = tac (make_initial_state d p gl db_list local_db lems) in + pr_info d s; + s.tacres + with Not_found -> + pr_info_nop d; + error "eauto: search failed" + +(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *) +(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *) + +let eauto_with_bases ?(debug=Off) np lems db_list = + tclTRY (e_search_auto debug np lems db_list) + +let eauto ?(debug=Off) np lems dbnames = + let db_list = make_db_list dbnames in + tclTRY (e_search_auto debug np lems db_list) + +let full_eauto ?(debug=Off) n lems gl = + let dbnames = current_db_names () in + let dbnames = String.Set.remove "v62" dbnames in + let db_list = List.map searchtable_map (String.Set.elements dbnames) in + tclTRY (e_search_auto debug n lems db_list) gl + +let gen_eauto ?(debug=Off) np lems = function + | None -> Proofview.V82.tactic (full_eauto ~debug np lems) + | Some l -> Proofview.V82.tactic (eauto ~debug np lems l) + +let make_depth = function + | None -> !default_search_depth + | Some d -> d + +let make_dimension n = function + | None -> (true,make_depth n) + | Some d -> (false,d) + +let cons a l = a :: l + +let autounfolds db occs cls gl = + let unfolds = List.concat (List.map (fun dbname -> + let db = try searchtable_map dbname + with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + in + let (ids, csts) = Hint_db.unfolds db in + let hyps = pf_ids_of_hyps gl in + let ids = Idset.filter (fun id -> List.mem id hyps) ids in + Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts + (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) + in Proofview.V82.of_tactic (unfold_option unfolds cls) gl + +let autounfold db cls = + Proofview.V82.tactic begin fun gl -> + let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in + let tac = autounfolds db in + tclMAP (function + | OnHyp (id,occs,where) -> tac occs (Some (id,where)) + | OnConcl occs -> tac occs None) + cls gl + end + +let autounfold_tac db cls = + Proofview.tclUNIT () >>= fun () -> + let dbs = match db with + | None -> String.Set.elements (current_db_names ()) + | Some [] -> ["core"] + | Some l -> l + in + autounfold dbs cls + +let unfold_head env (ids, csts) c = + let rec aux c = + match kind_of_term c with + | Var id when Id.Set.mem id ids -> + (match Environ.named_body id env with + | Some b -> true, b + | None -> false, c) + | Const (cst,u as c) when Cset.mem cst csts -> + true, Environ.constant_value_in env c + | App (f, args) -> + (match aux f with + | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) + | false, _ -> + let done_, args' = + Array.fold_left_i (fun i (done_, acc) arg -> + if done_ then done_, arg :: acc + else match aux arg with + | true, arg' -> true, arg' :: acc + | false, arg' -> false, arg :: acc) + (false, []) args + in + if done_ then true, mkApp (f, Array.of_list (List.rev args')) + else false, c) + | _ -> + let done_ = ref false in + let c' = map_constr (fun c -> + if !done_ then c else + let x, c' = aux c in + done_ := x; c') c + in !done_, c' + in aux c + +let autounfold_one db cl = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let st = + List.fold_left (fun (i,c) dbname -> + let db = try searchtable_map dbname + with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) + in + let (ids, csts) = Hint_db.unfolds db in + (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db + in + let did, c' = unfold_head env st + (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) + in + if did then + match cl with + | Some hyp -> change_in_hyp None (make_change_arg c') hyp + | None -> convert_concl_no_check c' DEFAULTcast + else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") + end } diff --git a/tactics/eauto.mli b/tactics/eauto.mli new file mode 100644 index 0000000000..8812093d5f --- /dev/null +++ b/tactics/eauto.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> unit Proofview.tactic + +val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic + +val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> + hint_db_name list option -> unit Proofview.tactic + +val eauto_with_bases : + ?debug:Tacexpr.debug -> + bool * int -> + Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic + +val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic +val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic +val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic + +val make_dimension : int option -> int option -> bool * int diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index cb327e52c1..bbad1d8e64 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -17,5 +17,7 @@ Leminv Taccoerce Hints Auto +Eauto +Class_tactics Tactic_matching Term_dnet -- cgit v1.2.3 From a947e85e88ab0b9a5a4cfea81ecbeec6f52636ea Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Mar 2016 09:38:15 +0100 Subject: Making Eqdecide independent of Extratactics. --- ltac/eqdecide.ml | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/ltac/eqdecide.ml b/ltac/eqdecide.ml index 7d0df2f522..011296a8d0 100644 --- a/ltac/eqdecide.ml +++ b/ltac/eqdecide.ml @@ -22,7 +22,9 @@ open Tactics open Tacticals.New open Auto open Constr_matching +open Misctypes open Hipattern +open Pretyping open Tacmach.New open Coqlib open Proofview.Notations @@ -72,10 +74,15 @@ let mkBranches c1 c2 = clear_last; intros] +let discrHyp id = + let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + let solveNoteqBranch side = tclTHEN (choose_noteq side) (tclTHEN introf - (onLastHypId (fun id -> Extratactics.discrHyp id))) + (onLastHypId (fun id -> discrHyp id))) (* Constructs the type {c1=c2}+{~c1=c2} *) @@ -115,6 +122,11 @@ let rec rewrite_and_clear hyps = match hyps with let eqCase tac = tclTHEN intro (onLastHypId tac) +let injHyp id = + let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + let diseqCase hyps eqonleft = let diseq = Id.of_string "diseq" in let absurd = Id.of_string "absurd" in @@ -124,7 +136,7 @@ let diseqCase hyps eqonleft = (tclTHEN (red_in_concl) (tclTHEN (intro_using absurd) (tclTHEN (Simple.apply (mkVar diseq)) - (tclTHEN (Extratactics.injHyp absurd) + (tclTHEN (injHyp absurd) (full_trivial [])))))))) open Proofview.Notations -- cgit v1.2.3 From 63b914b51ddc9084bc2e059df266e2345dfe34b5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Mar 2016 09:59:52 +0100 Subject: Moving Eqdecide to tactics/. --- ltac/eqdecide.ml | 237 -------------------------------------------------- ltac/eqdecide.mli | 17 ---- ltac/ltac.mllib | 1 - tactics/eqdecide.ml | 237 ++++++++++++++++++++++++++++++++++++++++++++++++++ tactics/eqdecide.mli | 17 ++++ tactics/tactics.mllib | 1 + 6 files changed, 255 insertions(+), 255 deletions(-) delete mode 100644 ltac/eqdecide.ml delete mode 100644 ltac/eqdecide.mli create mode 100644 tactics/eqdecide.ml create mode 100644 tactics/eqdecide.mli diff --git a/ltac/eqdecide.ml b/ltac/eqdecide.ml deleted file mode 100644 index 011296a8d0..0000000000 --- a/ltac/eqdecide.ml +++ /dev/null @@ -1,237 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* (clear [destVar c]))) - -let choose_eq eqonleft = - if eqonleft then - left_with_bindings false Misctypes.NoBindings - else - right_with_bindings false Misctypes.NoBindings -let choose_noteq eqonleft = - if eqonleft then - right_with_bindings false Misctypes.NoBindings - else - left_with_bindings false Misctypes.NoBindings - -let mkBranches c1 c2 = - tclTHENLIST - [Proofview.V82.tactic (generalize [c2]); - Simple.elim c1; - intros; - onLastHyp Simple.case; - clear_last; - intros] - -let discrHyp id = - let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in - Tacticals.New.tclDELAYEDWITHHOLES false c tac - -let solveNoteqBranch side = - tclTHEN (choose_noteq side) - (tclTHEN introf - (onLastHypId (fun id -> discrHyp id))) - -(* Constructs the type {c1=c2}+{~c1=c2} *) - -let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) - -let mkDecideEqGoal eqonleft op rectype c1 c2 = - let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in - let disequality = mkApp(build_coq_not (), [|equality|]) in - if eqonleft then mkApp(op, [|equality; disequality |]) - else mkApp(op, [|disequality; equality |]) - - -(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) - -let idx = Id.of_string "x" -let idy = Id.of_string "y" - -let mkGenDecideEqGoal rectype g = - let hypnames = pf_ids_of_hyps g in - let xname = next_ident_away idx hypnames - and yname = next_ident_away idy hypnames in - (mkNamedProd xname rectype - (mkNamedProd yname rectype - (mkDecideEqGoal true (build_coq_sumbool ()) - rectype (mkVar xname) (mkVar yname)))) - -let rec rewrite_and_clear hyps = match hyps with -| [] -> Proofview.tclUNIT () -| id :: hyps -> - tclTHENLIST [ - Equality.rewriteLR (mkVar id); - clear [id]; - rewrite_and_clear hyps; - ] - -let eqCase tac = - tclTHEN intro (onLastHypId tac) - -let injHyp id = - let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in - let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in - Tacticals.New.tclDELAYEDWITHHOLES false c tac - -let diseqCase hyps eqonleft = - let diseq = Id.of_string "diseq" in - let absurd = Id.of_string "absurd" in - (tclTHEN (intro_using diseq) - (tclTHEN (choose_noteq eqonleft) - (tclTHEN (rewrite_and_clear (List.rev hyps)) - (tclTHEN (red_in_concl) - (tclTHEN (intro_using absurd) - (tclTHEN (Simple.apply (mkVar diseq)) - (tclTHEN (injHyp absurd) - (full_trivial [])))))))) - -open Proofview.Notations - -(* spiwack: a small wrapper around [Hipattern]. *) - -let match_eqdec c = - try Proofview.tclUNIT (match_eqdec c) - with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure - -(* /spiwack *) - -let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with -| [], [] -> - tclTHENLIST [ - choose_eq eqonleft; - rewrite_and_clear (List.rev hyps); - intros_reflexivity; - ] -| a1 :: largs, a2 :: rargs -> - Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl a1 in - let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in - let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in - let subtacs = - if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] - else [diseqCase hyps eqonleft;eqCase tac;default_auto] in - (tclTHENS (elim_type decide) subtacs) - end } -| _ -> invalid_arg "List.fold_right2" - -let solveEqBranch rectype = - Proofview.tclORELSE - begin - Proofview.Goal.enter { enter = begin fun gl -> - let concl = pf_nf_concl gl in - match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) -> - let (mib,mip) = Global.lookup_inductive rectype in - let nparams = mib.mind_nparams in - let getargs l = List.skipn nparams (snd (decompose_app l)) in - let rargs = getargs rhs - and largs = getargs lhs in - solveArg [] eqonleft op largs rargs - end } - end - begin function (e, info) -> match e with - | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") - | e -> Proofview.tclZERO ~info e - end - -(* The tactic Decide Equality *) - -let hd_app c = match kind_of_term c with - | App (h,_) -> h - | _ -> c - -let decideGralEquality = - Proofview.tclORELSE - begin - Proofview.Goal.enter { enter = begin fun gl -> - let concl = pf_nf_concl gl in - match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> - let headtyp = hd_app (pf_compute gl typ) in - begin match kind_of_term headtyp with - | Ind (mi,_) -> Proofview.tclUNIT mi - | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") - end >>= fun rectype -> - (tclTHEN - (mkBranches c1 c2) - (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) - end } - end - begin function (e, info) -> match e with - | PatternMatchingFailure -> - Tacticals.New.tclZEROMSG (Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.") - | e -> Proofview.tclZERO ~info e - end - -let decideEqualityGoal = tclTHEN intros decideGralEquality - -let decideEquality rectype = - Proofview.Goal.enter { enter = begin fun gl -> - let decide = mkGenDecideEqGoal rectype gl in - (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) - end } - - -(* The tactic Compare *) - -let compare c1 c2 = - Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl c1 in - let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in - (tclTHENS (cut decide) - [(tclTHEN intro - (tclTHEN (onLastHyp simplest_case) clear_last)); - decideEquality rectype]) - end } diff --git a/ltac/eqdecide.mli b/ltac/eqdecide.mli deleted file mode 100644 index cb48a5bcc8..0000000000 --- a/ltac/eqdecide.mli +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Constr.t -> unit Proofview.tactic diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index 8e9f992f16..28bfa5aa0a 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -16,6 +16,5 @@ G_class Rewrite G_rewrite Tauto -Eqdecide G_eqdecide G_ltac diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml new file mode 100644 index 0000000000..011296a8d0 --- /dev/null +++ b/tactics/eqdecide.ml @@ -0,0 +1,237 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (clear [destVar c]))) + +let choose_eq eqonleft = + if eqonleft then + left_with_bindings false Misctypes.NoBindings + else + right_with_bindings false Misctypes.NoBindings +let choose_noteq eqonleft = + if eqonleft then + right_with_bindings false Misctypes.NoBindings + else + left_with_bindings false Misctypes.NoBindings + +let mkBranches c1 c2 = + tclTHENLIST + [Proofview.V82.tactic (generalize [c2]); + Simple.elim c1; + intros; + onLastHyp Simple.case; + clear_last; + intros] + +let discrHyp id = + let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + +let solveNoteqBranch side = + tclTHEN (choose_noteq side) + (tclTHEN introf + (onLastHypId (fun id -> discrHyp id))) + +(* Constructs the type {c1=c2}+{~c1=c2} *) + +let make_eq () = +(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + +let mkDecideEqGoal eqonleft op rectype c1 c2 = + let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in + let disequality = mkApp(build_coq_not (), [|equality|]) in + if eqonleft then mkApp(op, [|equality; disequality |]) + else mkApp(op, [|disequality; equality |]) + + +(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) + +let idx = Id.of_string "x" +let idy = Id.of_string "y" + +let mkGenDecideEqGoal rectype g = + let hypnames = pf_ids_of_hyps g in + let xname = next_ident_away idx hypnames + and yname = next_ident_away idy hypnames in + (mkNamedProd xname rectype + (mkNamedProd yname rectype + (mkDecideEqGoal true (build_coq_sumbool ()) + rectype (mkVar xname) (mkVar yname)))) + +let rec rewrite_and_clear hyps = match hyps with +| [] -> Proofview.tclUNIT () +| id :: hyps -> + tclTHENLIST [ + Equality.rewriteLR (mkVar id); + clear [id]; + rewrite_and_clear hyps; + ] + +let eqCase tac = + tclTHEN intro (onLastHypId tac) + +let injHyp id = + let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + +let diseqCase hyps eqonleft = + let diseq = Id.of_string "diseq" in + let absurd = Id.of_string "absurd" in + (tclTHEN (intro_using diseq) + (tclTHEN (choose_noteq eqonleft) + (tclTHEN (rewrite_and_clear (List.rev hyps)) + (tclTHEN (red_in_concl) + (tclTHEN (intro_using absurd) + (tclTHEN (Simple.apply (mkVar diseq)) + (tclTHEN (injHyp absurd) + (full_trivial [])))))))) + +open Proofview.Notations + +(* spiwack: a small wrapper around [Hipattern]. *) + +let match_eqdec c = + try Proofview.tclUNIT (match_eqdec c) + with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure + +(* /spiwack *) + +let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with +| [], [] -> + tclTHENLIST [ + choose_eq eqonleft; + rewrite_and_clear (List.rev hyps); + intros_reflexivity; + ] +| a1 :: largs, a2 :: rargs -> + Proofview.Goal.enter { enter = begin fun gl -> + let rectype = pf_unsafe_type_of gl a1 in + let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in + let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in + let subtacs = + if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] + else [diseqCase hyps eqonleft;eqCase tac;default_auto] in + (tclTHENS (elim_type decide) subtacs) + end } +| _ -> invalid_arg "List.fold_right2" + +let solveEqBranch rectype = + Proofview.tclORELSE + begin + Proofview.Goal.enter { enter = begin fun gl -> + let concl = pf_nf_concl gl in + match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) -> + let (mib,mip) = Global.lookup_inductive rectype in + let nparams = mib.mind_nparams in + let getargs l = List.skipn nparams (snd (decompose_app l)) in + let rargs = getargs rhs + and largs = getargs lhs in + solveArg [] eqonleft op largs rargs + end } + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") + | e -> Proofview.tclZERO ~info e + end + +(* The tactic Decide Equality *) + +let hd_app c = match kind_of_term c with + | App (h,_) -> h + | _ -> c + +let decideGralEquality = + Proofview.tclORELSE + begin + Proofview.Goal.enter { enter = begin fun gl -> + let concl = pf_nf_concl gl in + match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> + let headtyp = hd_app (pf_compute gl typ) in + begin match kind_of_term headtyp with + | Ind (mi,_) -> Proofview.tclUNIT mi + | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") + end >>= fun rectype -> + (tclTHEN + (mkBranches c1 c2) + (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) + end } + end + begin function (e, info) -> match e with + | PatternMatchingFailure -> + Tacticals.New.tclZEROMSG (Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.") + | e -> Proofview.tclZERO ~info e + end + +let decideEqualityGoal = tclTHEN intros decideGralEquality + +let decideEquality rectype = + Proofview.Goal.enter { enter = begin fun gl -> + let decide = mkGenDecideEqGoal rectype gl in + (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) + end } + + +(* The tactic Compare *) + +let compare c1 c2 = + Proofview.Goal.enter { enter = begin fun gl -> + let rectype = pf_unsafe_type_of gl c1 in + let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in + (tclTHENS (cut decide) + [(tclTHEN intro + (tclTHEN (onLastHyp simplest_case) clear_last)); + decideEquality rectype]) + end } diff --git a/tactics/eqdecide.mli b/tactics/eqdecide.mli new file mode 100644 index 0000000000..cb48a5bcc8 --- /dev/null +++ b/tactics/eqdecide.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Constr.t -> unit Proofview.tactic diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index bbad1d8e64..37503decc6 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -21,3 +21,4 @@ Eauto Class_tactics Tactic_matching Term_dnet +Eqdecide -- cgit v1.2.3 From 222c24ff4361f1a35b267f6b406aa7b2da56e689 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Mar 2016 10:06:00 +0100 Subject: Making Autorewrite independent from Ltac. --- ltac/autorewrite.ml | 19 +++++++++++++------ ltac/autorewrite.mli | 4 ++-- ltac/extratactics.ml4 | 2 +- ltac/rewrite.ml | 5 ++++- 4 files changed, 20 insertions(+), 10 deletions(-) diff --git a/ltac/autorewrite.ml b/ltac/autorewrite.ml index ea598b61ca..4816f8a452 100644 --- a/ltac/autorewrite.ml +++ b/ltac/autorewrite.ml @@ -27,13 +27,13 @@ type rew_rule = { rew_lemma: constr; rew_pat: constr; rew_ctx: Univ.universe_context_set; rew_l2r: bool; - rew_tac: glob_tactic_expr option } + rew_tac: Genarg.glob_generic_argument option } let subst_hint subst hint = let cst' = subst_mps subst hint.rew_lemma in let typ' = subst_mps subst hint.rew_type in let pat' = subst_mps subst hint.rew_pat in - let t' = Option.smartmap (Tacsubst.subst_tactic subst) hint.rew_tac in + let t' = Option.smartmap (Genintern.generic_substitute subst) hint.rew_tac in if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else { hint with rew_lemma = cst'; rew_type = typ'; @@ -85,10 +85,10 @@ let print_rewrite_hintdb bas = str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ - Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) + Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = @@ -104,7 +104,12 @@ let one_base general_rewrite_maybe_in tac_main bas = Sigma.Unsafe.of_pair (tac, sigma) end } in let lrul = List.map (fun h -> - let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in + let tac = match h.rew_tac with + | None -> Proofview.tclUNIT () + | Some tac -> + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) + in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac @@ -300,6 +305,8 @@ let add_rew_rules base lrul = let counter = ref 0 in let env = Global.env () in let sigma = Evd.from_env env in + let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in + let intern tac = snd (Genintern.generic_intern ist tac) in let lrul = List.fold_left (fun dn (loc,(c,ctx),b,t) -> @@ -308,7 +315,7 @@ let add_rew_rules base lrul = let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; rew_pat = pat; rew_ctx = ctx; rew_l2r = b; - rew_tac = Option.map Tacintern.glob_tactic t} + rew_tac = Option.map intern t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) diff --git a/ltac/autorewrite.mli b/ltac/autorewrite.mli index 6196b04e18..ac613b57ce 100644 --- a/ltac/autorewrite.mli +++ b/ltac/autorewrite.mli @@ -11,7 +11,7 @@ open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) -type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option (** To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit @@ -29,7 +29,7 @@ type rew_rule = { rew_lemma: constr; rew_pat: constr; rew_ctx: Univ.universe_context_set; rew_l2r: bool; - rew_tac: glob_tactic_expr option } + rew_tac: Genarg.glob_generic_argument option } val find_rewrites : string -> rew_rule list diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 index 96abc11999..ba9f82fb96 100644 --- a/ltac/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -290,7 +290,7 @@ let add_rewrite_hint bases ort t lcsr = if poly then ctx else (Global.push_context_set false ctx; Univ.ContextSet.empty) in - Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in let eqs = List.map f lcsr in let add_hints base = add_rew_rules base eqs in List.iter add_hints bases diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index fb04bee070..2fe2eb42a6 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -612,7 +612,10 @@ let solve_remaining_by env sigma holes by = in (** Only solve independent holes *) let indep = List.map_filter map holes in - let solve_tac = Tacticals.New.tclCOMPLETE (Tacinterp.eval_tactic tac) in + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let solve_tac = Geninterp.generic_interp ist tac in + let solve_tac = Ftactic.run solve_tac (fun _ -> Proofview.tclUNIT ()) in + let solve_tac = Tacticals.New.tclCOMPLETE solve_tac in let solve sigma evk = let evi = try Some (Evd.find_undefined sigma evk) -- cgit v1.2.3 From e8114ee084cae195eb7615293cec0e28dcc0a3d8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Mar 2016 14:24:51 +0100 Subject: Moving Autorewrite back to tactics/. --- ltac/autorewrite.ml | 322 ------------------------------------------------ ltac/autorewrite.mli | 61 --------- ltac/ltac.mllib | 1 - tactics/autorewrite.ml | 322 ++++++++++++++++++++++++++++++++++++++++++++++++ tactics/autorewrite.mli | 61 +++++++++ tactics/tactics.mllib | 1 + 6 files changed, 384 insertions(+), 384 deletions(-) delete mode 100644 ltac/autorewrite.ml delete mode 100644 ltac/autorewrite.mli create mode 100644 tactics/autorewrite.ml create mode 100644 tactics/autorewrite.mli diff --git a/ltac/autorewrite.ml b/ltac/autorewrite.ml deleted file mode 100644 index 4816f8a452..0000000000 --- a/ltac/autorewrite.ml +++ /dev/null @@ -1,322 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - errorlabstrm "AutoRewrite" - (str "Rewriting base " ++ str bas ++ str " does not exist.") - -let find_rewrites bas = - List.rev_map snd (HintDN.find_all (find_base bas)) - -let find_matches bas pat = - let base = find_base bas in - let res = HintDN.search_pattern base pat in - List.map snd res - -let print_rewrite_hintdb bas = - (str "Database " ++ str bas ++ fnl () ++ - prlist_with_sep fnl - (fun h -> - str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ - Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ - Option.cata (fun tac -> str " then use tactic " ++ - Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) - (find_rewrites bas)) - -type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option - -(* Applies all the rules of one base *) -let one_base general_rewrite_maybe_in tac_main bas = - let lrul = find_rewrites bas in - let try_rewrite dir ctx c tc = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in - let c' = Vars.subst_univs_level_constr subst c in - let sigma = Sigma.to_evar_map sigma in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in - let tac = general_rewrite_maybe_in dir c' tc in - Sigma.Unsafe.of_pair (tac, sigma) - end } in - let lrul = List.map (fun h -> - let tac = match h.rew_tac with - | None -> Proofview.tclUNIT () - | Some tac -> - let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in - Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) - in - (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> - Tacticals.New.tclTHEN tac - (Tacticals.New.tclREPEAT_MAIN - (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) - (Proofview.tclUNIT()) lrul)) - -(* The AutoRewrite tactic *) -let autorewrite ?(conds=Naive) tac_main lbas = - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS - (List.fold_left (fun tac bas -> - Tacticals.New.tclTHEN tac - (one_base (fun dir c tac -> - let tac = (tac, conds) in - general_rewrite dir AllOccurrences true false ~tac c) - tac_main bas)) - (Proofview.tclUNIT()) lbas)) - -let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = - Proofview.Goal.nf_enter { enter = begin fun gl -> - (* let's check at once if id exists (to raise the appropriate error) *) - let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in - let general_rewrite_in id = - let id = ref id in - let to_be_cleared = ref false in - fun dir cstr tac gl -> - let last_hyp_id = - match Tacmach.pf_hyps gl with - d :: _ -> Context.Named.Declaration.get_id d - | _ -> (* even the hypothesis id is missing *) - raise (Logic.RefinerError (Logic.NoSuchHyp !id)) - in - let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false) gl in - let gls = gl'.Evd.it in - match gls with - g::_ -> - (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with - d ::_ -> - let lastid = Context.Named.Declaration.get_id d in - if not (Id.equal last_hyp_id lastid) then - begin - let gl'' = - if !to_be_cleared then - tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl - else gl' in - id := lastid ; - to_be_cleared := true ; - gl'' - end - else - begin - to_be_cleared := false ; - gl' - end - | _ -> assert false) (* there must be at least an hypothesis *) - | _ -> assert false (* rewriting cannot complete a proof *) - in - let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in - Tacticals.New.tclMAP (fun id -> - Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS - (List.fold_left (fun tac bas -> - Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) - idl - end } - -let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] - -let gen_auto_multi_rewrite conds tac_main lbas cl = - let try_do_hyps treat_id l = - autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas - in - if cl.concl_occs != AllOccurrences && - cl.concl_occs != NoOccurrences - then - Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") - else - let compose_tac t1 t2 = - match cl.onhyps with - | Some [] -> t1 - | _ -> Tacticals.New.tclTHENFIRST t1 t2 - in - compose_tac - (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) - (match cl.onhyps with - | Some l -> try_do_hyps (fun ((_,id),_) -> id) l - | None -> - (* try to rewrite in all hypothesis - (except maybe the rewritten one) *) - Proofview.Goal.nf_enter { enter = begin fun gl -> - let ids = Tacmach.New.pf_ids_of_hyps gl in - try_do_hyps (fun id -> id) ids - end }) - -let auto_multi_rewrite ?(conds=Naive) lems cl = - Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) - -let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = - let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in - match onconcl,cl.Locus.onhyps with - | false,Some [_] | true,Some [] | false,Some [] -> - (* autorewrite with .... in clause using tac n'est sur que - si clause represente soit le but soit UNE hypothese - *) - Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) - | _ -> - Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") - -(* Functions necessary to the library object declaration *) -let cache_hintrewrite (_,(rbase,lrl)) = - let base = try raw_find_base rbase with Not_found -> HintDN.empty in - let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 - in - let lrl = HintDN.refresh_metas lrl in - let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in - rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab - - -let subst_hintrewrite (subst,(rbase,list as node)) = - let list' = HintDN.subst subst list in - if list' == list then node else - (rbase,list') - -let classify_hintrewrite x = Libobject.Substitute x - - -(* Declaration of the Hint Rewrite library object *) -let inHintRewrite : string * HintDN.t -> Libobject.obj = - Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with - Libobject.cache_function = cache_hintrewrite; - Libobject.load_function = (fun _ -> cache_hintrewrite); - Libobject.subst_function = subst_hintrewrite; - Libobject.classify_function = classify_hintrewrite } - - -open Clenv - -type hypinfo = { - hyp_cl : clausenv; - hyp_prf : constr; - hyp_ty : types; - hyp_car : constr; - hyp_rel : constr; - hyp_l2r : bool; - hyp_left : constr; - hyp_right : constr; -} - -let decompose_applied_relation metas env sigma c ctype left2right = - let find_rel ty = - let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in - let eqclause = - if metas then eqclause - else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) - in - let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in - let rec split_last_two = function - | [c1;c2] -> [],(c1, c2) - | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res - | _ -> raise Not_found - in - try - let others,(c1,c2) = split_last_two args in - let ty1, ty2 = - Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 - in -(* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) -(* else *) - Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; - hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); - hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } - with Not_found -> None - in - match find_rel ctype with - | Some c -> Some c - | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' ctx) with - | Some c -> Some c - | None -> None - -let find_applied_relation metas loc env sigma c left2right = - let ctype = Typing.unsafe_type_of env sigma c in - match decompose_applied_relation metas env sigma c ctype left2right with - | Some c -> c - | None -> - user_err_loc (loc, "decompose_applied_relation", - str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ - spc () ++ str"of this term does not end with an applied relation.") - -(* To add rewriting rules to a base *) -let add_rew_rules base lrul = - let counter = ref 0 in - let env = Global.env () in - let sigma = Evd.from_env env in - let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in - let intern tac = snd (Genintern.generic_intern ist tac) in - let lrul = - List.fold_left - (fun dn (loc,(c,ctx),b,t) -> - let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in - let info = find_applied_relation false loc env sigma c b in - let pat = if b then info.hyp_left else info.hyp_right in - let rul = { rew_lemma = c; rew_type = info.hyp_ty; - rew_pat = pat; rew_ctx = ctx; rew_l2r = b; - rew_tac = Option.map intern t} - in incr counter; - HintDN.add pat (!counter, rul) dn) HintDN.empty lrul - in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) - diff --git a/ltac/autorewrite.mli b/ltac/autorewrite.mli deleted file mode 100644 index ac613b57ce..0000000000 --- a/ltac/autorewrite.mli +++ /dev/null @@ -1,61 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* raw_rew_rule list -> unit - -(** The AutoRewrite tactic. - The optional conditions tell rewrite how to handle matching and side-condition solving. - Default is Naive: first match in the clause, don't look at the side-conditions to - tell if the rewrite succeeded. *) -val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic -val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic - -(** Rewriting rules *) -type rew_rule = { rew_lemma: constr; - rew_type: types; - rew_pat: constr; - rew_ctx: Univ.universe_context_set; - rew_l2r: bool; - rew_tac: Genarg.glob_generic_argument option } - -val find_rewrites : string -> rew_rule list - -val find_matches : string -> constr -> rew_rule list - -val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic - -val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic - -val print_rewrite_hintdb : string -> Pp.std_ppcmds - -open Clenv - - -type hypinfo = { - hyp_cl : clausenv; - hyp_prf : constr; - hyp_ty : types; - hyp_car : constr; - hyp_rel : constr; - hyp_l2r : bool; - hyp_left : constr; - hyp_right : constr; -} - -val find_applied_relation : bool -> - Loc.t -> - Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo - diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index 28bfa5aa0a..e0c6f3ac0a 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -9,7 +9,6 @@ Tactic_option Extraargs G_obligations Coretactics -Autorewrite Extratactics G_auto G_class diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml new file mode 100644 index 0000000000..4816f8a452 --- /dev/null +++ b/tactics/autorewrite.ml @@ -0,0 +1,322 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + errorlabstrm "AutoRewrite" + (str "Rewriting base " ++ str bas ++ str " does not exist.") + +let find_rewrites bas = + List.rev_map snd (HintDN.find_all (find_base bas)) + +let find_matches bas pat = + let base = find_base bas in + let res = HintDN.search_pattern base pat in + List.map snd res + +let print_rewrite_hintdb bas = + (str "Database " ++ str bas ++ fnl () ++ + prlist_with_sep fnl + (fun h -> + str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ + Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ + Option.cata (fun tac -> str " then use tactic " ++ + Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) + (find_rewrites bas)) + +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option + +(* Applies all the rules of one base *) +let one_base general_rewrite_maybe_in tac_main bas = + let lrul = find_rewrites bas in + let try_rewrite dir ctx c tc = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c in + let sigma = Sigma.to_evar_map sigma in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in + let tac = general_rewrite_maybe_in dir c' tc in + Sigma.Unsafe.of_pair (tac, sigma) + end } in + let lrul = List.map (fun h -> + let tac = match h.rew_tac with + | None -> Proofview.tclUNIT () + | Some tac -> + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) + in + (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> + Tacticals.New.tclTHEN tac + (Tacticals.New.tclREPEAT_MAIN + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) + (Proofview.tclUNIT()) lrul)) + +(* The AutoRewrite tactic *) +let autorewrite ?(conds=Naive) tac_main lbas = + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS + (List.fold_left (fun tac bas -> + Tacticals.New.tclTHEN tac + (one_base (fun dir c tac -> + let tac = (tac, conds) in + general_rewrite dir AllOccurrences true false ~tac c) + tac_main bas)) + (Proofview.tclUNIT()) lbas)) + +let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = + Proofview.Goal.nf_enter { enter = begin fun gl -> + (* let's check at once if id exists (to raise the appropriate error) *) + let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in + let general_rewrite_in id = + let id = ref id in + let to_be_cleared = ref false in + fun dir cstr tac gl -> + let last_hyp_id = + match Tacmach.pf_hyps gl with + d :: _ -> Context.Named.Declaration.get_id d + | _ -> (* even the hypothesis id is missing *) + raise (Logic.RefinerError (Logic.NoSuchHyp !id)) + in + let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false) gl in + let gls = gl'.Evd.it in + match gls with + g::_ -> + (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with + d ::_ -> + let lastid = Context.Named.Declaration.get_id d in + if not (Id.equal last_hyp_id lastid) then + begin + let gl'' = + if !to_be_cleared then + tclTHEN (fun _ -> gl') (tclTRY (clear [!id])) gl + else gl' in + id := lastid ; + to_be_cleared := true ; + gl'' + end + else + begin + to_be_cleared := false ; + gl' + end + | _ -> assert false) (* there must be at least an hypothesis *) + | _ -> assert false (* rewriting cannot complete a proof *) + in + let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in + Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS + (List.fold_left (fun tac bas -> + Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas))) + idl + end } + +let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] + +let gen_auto_multi_rewrite conds tac_main lbas cl = + let try_do_hyps treat_id l = + autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas + in + if cl.concl_occs != AllOccurrences && + cl.concl_occs != NoOccurrences + then + Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") + else + let compose_tac t1 t2 = + match cl.onhyps with + | Some [] -> t1 + | _ -> Tacticals.New.tclTHENFIRST t1 t2 + in + compose_tac + (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) + (match cl.onhyps with + | Some l -> try_do_hyps (fun ((_,id),_) -> id) l + | None -> + (* try to rewrite in all hypothesis + (except maybe the rewritten one) *) + Proofview.Goal.nf_enter { enter = begin fun gl -> + let ids = Tacmach.New.pf_ids_of_hyps gl in + try_do_hyps (fun id -> id) ids + end }) + +let auto_multi_rewrite ?(conds=Naive) lems cl = + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) + +let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = + let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in + match onconcl,cl.Locus.onhyps with + | false,Some [_] | true,Some [] | false,Some [] -> + (* autorewrite with .... in clause using tac n'est sur que + si clause represente soit le but soit UNE hypothese + *) + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) + | _ -> + Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") + +(* Functions necessary to the library object declaration *) +let cache_hintrewrite (_,(rbase,lrl)) = + let base = try raw_find_base rbase with Not_found -> HintDN.empty in + let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 + in + let lrl = HintDN.refresh_metas lrl in + let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in + rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab + + +let subst_hintrewrite (subst,(rbase,list as node)) = + let list' = HintDN.subst subst list in + if list' == list then node else + (rbase,list') + +let classify_hintrewrite x = Libobject.Substitute x + + +(* Declaration of the Hint Rewrite library object *) +let inHintRewrite : string * HintDN.t -> Libobject.obj = + Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with + Libobject.cache_function = cache_hintrewrite; + Libobject.load_function = (fun _ -> cache_hintrewrite); + Libobject.subst_function = subst_hintrewrite; + Libobject.classify_function = classify_hintrewrite } + + +open Clenv + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +let decompose_applied_relation metas env sigma c ctype left2right = + let find_rel ty = + let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in + let eqclause = + if metas then eqclause + else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) + in + let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in + let rec split_last_two = function + | [c1;c2] -> [],(c1, c2) + | x::y::z -> + let l,res = split_last_two (y::z) in x::l, res + | _ -> raise Not_found + in + try + let others,(c1,c2) = split_last_two args in + let ty1, ty2 = + Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 + in +(* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) +(* else *) + Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; + hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); + hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } + with Not_found -> None + in + match find_rel ctype with + | Some c -> Some c + | None -> + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> Some c + | None -> None + +let find_applied_relation metas loc env sigma c left2right = + let ctype = Typing.unsafe_type_of env sigma c in + match decompose_applied_relation metas env sigma c ctype left2right with + | Some c -> c + | None -> + user_err_loc (loc, "decompose_applied_relation", + str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ + spc () ++ str"of this term does not end with an applied relation.") + +(* To add rewriting rules to a base *) +let add_rew_rules base lrul = + let counter = ref 0 in + let env = Global.env () in + let sigma = Evd.from_env env in + let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in + let intern tac = snd (Genintern.generic_intern ist tac) in + let lrul = + List.fold_left + (fun dn (loc,(c,ctx),b,t) -> + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let info = find_applied_relation false loc env sigma c b in + let pat = if b then info.hyp_left else info.hyp_right in + let rul = { rew_lemma = c; rew_type = info.hyp_ty; + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; + rew_tac = Option.map intern t} + in incr counter; + HintDN.add pat (!counter, rul) dn) HintDN.empty lrul + in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) + diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli new file mode 100644 index 0000000000..ac613b57ce --- /dev/null +++ b/tactics/autorewrite.mli @@ -0,0 +1,61 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* raw_rew_rule list -> unit + +(** The AutoRewrite tactic. + The optional conditions tell rewrite how to handle matching and side-condition solving. + Default is Naive: first match in the clause, don't look at the side-conditions to + tell if the rewrite succeeded. *) +val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic +val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic + +(** Rewriting rules *) +type rew_rule = { rew_lemma: constr; + rew_type: types; + rew_pat: constr; + rew_ctx: Univ.universe_context_set; + rew_l2r: bool; + rew_tac: Genarg.glob_generic_argument option } + +val find_rewrites : string -> rew_rule list + +val find_matches : string -> constr -> rew_rule list + +val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic + +val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic + +val print_rewrite_hintdb : string -> Pp.std_ppcmds + +open Clenv + + +type hypinfo = { + hyp_cl : clausenv; + hyp_prf : constr; + hyp_ty : types; + hyp_car : constr; + hyp_rel : constr; + hyp_l2r : bool; + hyp_left : constr; + hyp_right : constr; +} + +val find_applied_relation : bool -> + Loc.t -> + Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo + diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 37503decc6..ab8069225d 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -22,3 +22,4 @@ Class_tactics Tactic_matching Term_dnet Eqdecide +Autorewrite -- cgit v1.2.3 From 7e7b5684d8f8066b90fca3395104af7241b8aed6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 25 Mar 2016 16:46:50 +0100 Subject: Univs: fix get_current_context (bug #4603, part I) Return an evar_map with the right universes, when there are no focused subgoals or the proof is finished. --- printing/printer.ml | 3 ++- proofs/pfedit.ml | 3 ++- stm/lemmas.ml | 10 ++++++++-- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/printing/printer.ml b/printing/printer.ml index 63755d7ff7..4e740bffe2 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -30,7 +30,8 @@ let delayed_emacs_cmd s = let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> - (Evd.empty, Global.env()) + let env = Global.env () in + (Evd.from_env env, env) (**********************************************************************) (** Terms *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index b635cc9632..2f5c1d1c2b 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -85,7 +85,8 @@ let get_current_goal_context () = with NoSuchGoal -> (* spiwack: returning empty evar_map, since if there is no goal, under focus, there is no accessible evar either *) - (Evd.empty, Global.env ()) + let env = Global.env () in + (Evd.from_env env, env) let current_proof_statement () = match Proof_global.V82.get_current_initial_conclusions () with diff --git a/stm/lemmas.ml b/stm/lemmas.ml index f06abfcce7..fb64a10c6c 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -511,5 +511,11 @@ let save_proof ?proof = function let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> - let env = Global.env () in - (Evd.from_env env, env) + try (* No more focused goals ? *) + let p = Pfedit.get_pftreestate () in + let evd = Proof.in_proof p (fun x -> x) in + (evd, Global.env ()) + with Proof_global.NoCurrentProof -> + let env = Global.env () in + (Evd.from_env env, env) + -- cgit v1.2.3 From 111e5edfe388d2f41ddef11800dac55b060b280b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 28 Mar 2016 15:01:05 +0200 Subject: Was too restrictive in syntactic definitions, not imagining that they could be used with arguments which are binding variables, as was done in ssrfun.v. --- toplevel/metasyntax.ml | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 6277a8146a..7c1f05cd3e 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -1299,12 +1299,7 @@ let add_syntactic_definition ident (vars,c) local onlyparse = } in let nvars, pat = interp_notation_constr nenv c in let () = nonprintable := nenv.ninterp_only_parse in - let map id = - let (isonlybinding,sc, _) = Id.Map.find id nvars in - (* if a notation contains an ltac:, the body is not analyzed - and onlybinding detection fails *) - assert (!nonprintable || not isonlybinding); - (id, sc) in + let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in List.map map vars, pat in let onlyparse = match onlyparse with -- cgit v1.2.3 From 59586ce49266f6b709cb53e4647b8907a7a08eb8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Mar 2016 16:07:44 +0200 Subject: Fixing an evar leak in Rewrite introduced by 968dfdb15. --- ltac/rewrite.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index 2fe2eb42a6..20d4651efa 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -359,7 +359,7 @@ end) = struct let env' = Environ.push_rel_context rels env in let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in - let evars = Sigma.to_evar_map sigma in + let evars = Sigma.to_evar_map evars in let evars, inst = app_poly env (evars,Evar.Set.empty) rewrite_relation_class [| evar; mkApp (c, params) |] in -- cgit v1.2.3 From 044d9f62bf0e1140268a3236e4bb53f10d716078 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 28 Mar 2016 16:24:48 +0200 Subject: Updating .gitignore. --- .gitignore | 20 +++----------------- 1 file changed, 3 insertions(+), 17 deletions(-) diff --git a/.gitignore b/.gitignore index 5c932ad02a..b50bca3cf3 100644 --- a/.gitignore +++ b/.gitignore @@ -107,8 +107,6 @@ dev/ocamlweb-doc/lex.ml ide/coq_lex.ml ide/config_lexer.ml ide/utf8_convert.ml -ide/highlight.ml -plugins/dp/dp_zenon.ml tools/gallina_lexer.ml tools/coqwc.ml tools/coqdep_lexer.ml @@ -121,29 +119,17 @@ lib/xml_lexer.ml g_*.ml ide/project_file.ml -lib/pp.ml parsing/compat.ml grammar/q_util.ml grammar/q_constr.ml -grammar/q_coqast.ml grammar/tacextend.ml grammar/vernacextend.ml grammar/argextend.ml -parsing/pcoq.ml parsing/lexer.ml -plugins/setoid_ring/newring.ml -plugins/field/field.ml -plugins/nsatz/nsatz.ml -tactics/tauto.ml -tactics/eauto.ml tactics/hipattern.ml -tactics/class_tactics.ml -tactics/coretactics.ml -tactics/rewrite.ml -tactics/eqdecide.ml -tactics/extratactics.ml -tactics/extraargs.ml -toplevel/whelp.ml +ltac/coretactics.ml +ltac/extratactics.ml +ltac/extraargs.ml ide/coqide_main.ml # other auto-generated files -- cgit v1.2.3 From d670c6b6ceab80f1c3b6b74ffb53579670c0e621 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 28 Mar 2016 17:53:43 +0200 Subject: Fixing an incorrect use of prod_appvect on a term which was not a product in setoid_rewrite. Before commit e8c47b652, it was raising an error which has been turned to an anomaly. This impacted Compcert where the former error was (apparently) caught so that setoid_rewrite was returning back to ordinary rewrite. --- ltac/rewrite.ml | 2 +- test-suite/success/setoid_test.v | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index 20d4651efa..cf2a01052f 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -1046,7 +1046,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | x -> x in let res = - { rew_car = prod_appvect r.rew_car args; + { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); rew_prf = prf; rew_evars = r.rew_evars } in diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 0465c4b3fb..4c173a3cd5 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -166,3 +166,11 @@ Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort. Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y. Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort. +(* This should not raise an anomaly as it did for some time in early 2016 *) + +Definition t := nat -> bool. +Definition h (a b : t) := forall n, a n = b n. +Goal forall a b, h a b -> a 0 = true. +intros. +rewrite H. (* Fallback on ordinary rewrite without anomaly *) +Abort. -- cgit v1.2.3 From dc36fd7fe118136277d8dc525c528fef38b46d70 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 29 Mar 2016 13:26:15 +0200 Subject: Update version number for 8.5pl1 --- configure.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ml b/configure.ml index 7ab197094d..48bcf34e11 100644 --- a/configure.ml +++ b/configure.ml @@ -11,8 +11,8 @@ #load "str.cma" open Printf -let coq_version = "8.5" -let coq_macos_version = "8.5.0" (** "[...] should be a string comprised of +let coq_version = "8.5pl1" +let coq_macos_version = "8.5.1" (** "[...] should be a string comprised of three non-negative, period-separed integers [...]" *) let vo_magic = 8500 let state_magic = 58500 -- cgit v1.2.3 From 051c9a8a1112174769670cb0dc8cebb85ccb803c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 30 Mar 2016 12:06:53 +0200 Subject: Removing dead code in Genarg. --- lib/genarg.ml | 51 ++------------------------------------------------- 1 file changed, 2 insertions(+), 49 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index 0deb34afd7..a43466c627 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -98,13 +98,13 @@ let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> std_ppcmds = funct str "*" ++ spc () ++ pr_genarg_type t2 ++ str ")" | ExtraArg s -> str (ArgT.repr s) -let rec argument_type_eq arg1 arg2 = match arg1, arg2 with +let argument_type_eq arg1 arg2 = match arg1, arg2 with | ArgumentType t1, ArgumentType t2 -> match genarg_type_eq t1 t2 with | None -> false | Some Refl -> true -let rec pr_argument_type (ArgumentType t) = pr_genarg_type t +let pr_argument_type (ArgumentType t) = pr_genarg_type t type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision *) @@ -115,11 +115,6 @@ type rlevel = [ `rlevel ] type glevel = [ `glevel ] type tlevel = [ `tlevel ] -type _ level = -| Rlevel : rlevel level -| Glevel : glevel level -| Tlevel : tlevel level - type (_, _) abstract_argument_type = | Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type | Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type @@ -183,48 +178,6 @@ type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type -type ('a, 'b, 'c, 'l) cast = -| Rcast : 'a -> ('a, 'b, 'c, rlevel) cast -| Gcast : 'b -> ('a, 'b, 'c, glevel) cast -| Tcast : 'c -> ('a, 'b, 'c, tlevel) cast - -let raw : ('a, 'b, 'c, rlevel) cast -> _ = function Rcast x -> x -let glb : ('a, 'b, 'c, glevel) cast -> _ = function Gcast x -> x -let top : ('a, 'b, 'c, tlevel) cast -> _ = function Tcast x -> x - -(** Type transformers *) - -type ('r, 'l) list_unpacker = - { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a list, 'b list, 'c list, 'l) cast -> 'r } - -let list_unpack (type l) (pack : (_, l) list_unpacker) (GenArg (t, obj) : l generic_argument) = match t with -| Rawwit (ListArg t) -> pack.list_unpacker t (Rcast obj) -| Glbwit (ListArg t) -> pack.list_unpacker t (Gcast obj) -| Topwit (ListArg t) -> pack.list_unpacker t (Tcast obj) -| _ -> failwith "out_gen" - -type ('r, 'l) opt_unpacker = - { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a option, 'b option, 'c option, 'l) cast -> 'r } - -let opt_unpack (type l) (pack : (_, l) opt_unpacker) (GenArg (t, obj) : l generic_argument) = match t with -| Rawwit (OptArg t) -> pack.opt_unpacker t (Rcast obj) -| Glbwit (OptArg t) -> pack.opt_unpacker t (Gcast obj) -| Topwit (OptArg t) -> pack.opt_unpacker t (Tcast obj) -| _ -> failwith "out_gen" - -type ('r, 'l) pair_unpacker = - { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2. - ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> - (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r } - -let pair_unpack (type l) (pack : (_, l) pair_unpacker) (GenArg (t, obj) : l generic_argument) = match t with -| Rawwit (PairArg (t1, t2)) -> pack.pair_unpacker t1 t2 (Rcast obj) -| Glbwit (PairArg (t1, t2)) -> pack.pair_unpacker t1 t2 (Gcast obj) -| Topwit (PairArg (t1, t2)) -> pack.pair_unpacker t1 t2 (Tcast obj) -| _ -> failwith "out_gen" - (** Creating args *) module type Param = sig type ('raw, 'glb, 'top) t end -- cgit v1.2.3 From c0aefc5323cb4393297adcaffd2967ab93ab815e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 30 Mar 2016 12:09:21 +0200 Subject: Ensuring that the type of base generic arguments contain triples. --- lib/genarg.ml | 17 +++++++++++++++-- lib/genarg.mli | 10 +++++----- 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/lib/genarg.ml b/lib/genarg.ml index a43466c627..5d5b29c99d 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -10,7 +10,20 @@ open Pp open Util module ValT = Dyn.Make(struct end) -module ArgT = Dyn.Make(struct end) +module ArgT = +struct + module DYN = Dyn.Make(struct end) + module Map = DYN.Map + type ('a, 'b, 'c) tag = ('a * 'b * 'c) DYN.tag + type any = Any : ('a, 'b, 'c) tag -> any + let eq = DYN.eq + let repr = DYN.repr + let create = DYN.create + let name s = match DYN.name s with + | None -> None + | Some (DYN.Any t) -> + Some (Any (Obj.magic t)) (** All created tags are made of triples *) +end module Val = struct @@ -57,7 +70,7 @@ struct end type (_, _, _) genarg_type = -| ExtraArg : ('a * 'b * 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type +| ExtraArg : ('a, 'b, 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type | ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type | OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type | PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> diff --git a/lib/genarg.mli b/lib/genarg.mli index 30b96c7000..6cc7893dc4 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -70,15 +70,15 @@ ExtraArgType of string '_a '_b module ArgT : sig - type 'a tag - val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option - val repr : 'a tag -> string - type any = Any : 'a tag -> any + type ('a, 'b, 'c) tag + val eq : ('a1, 'b1, 'c1) tag -> ('a2, 'b2, 'c2) tag -> ('a1 * 'b1 * 'c1, 'a2 * 'b2 * 'c2) CSig.eq option + val repr : ('a, 'b, 'c) tag -> string + type any = Any : ('a, 'b, 'c) tag -> any val name : string -> any option end type (_, _, _) genarg_type = -| ExtraArg : ('a * 'b * 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type +| ExtraArg : ('a, 'b, 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type | ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type | OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type | PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> -- cgit v1.2.3 From f5e85670b9c106fbde736654c32f4042c6a39d3f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 17:16:38 +0200 Subject: Moving the Tactic Notation entry parser from Pcoq to Tacentries. --- ltac/tacentries.ml | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++++ parsing/pcoq.ml | 110 ----------------------------------------------------- parsing/pcoq.mli | 8 +--- 3 files changed, 111 insertions(+), 116 deletions(-) diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index 711cd8d9d0..e247a138dd 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -11,6 +11,7 @@ open Errors open Util open Names open Libobject +open Genarg open Pcoq open Egramml open Egramcoq @@ -18,6 +19,114 @@ open Vernacexpr open Libnames open Nameops +(**********************************************************************) +(* Interpret entry names of the form "ne_constr_list" as entry keys *) + +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let atactic n = + let open Extend in + if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) + else Aentryl (name_of_entry Tactic.tactic_expr, n) + +type entry_name = EntryName : + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name + +let try_get_entry u s = + let open Extend in + (** Order the effects: get_entry can raise Not_found *) + let TypedEntry (typ, e) = get_entry u s in + EntryName (typ, Aentry (name_of_entry e)) + +(** Quite ad-hoc *) +let get_tacentry n m = + let open Extend in + let check_lvl n = + Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + if check_lvl n then EntryName (rawwit Constrarg.wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit Constrarg.wit_tactic, Anext) + else EntryName (rawwit Constrarg.wit_tactic, atactic n) + +let rec parse_user_entry s sep = + let open Extend in + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + Ulist1 entry + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 3 (l-12)) "" in + Ulist1sep (entry, sep) + else if l > 5 && coincide s "_list" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + Ulist0 entry + else if l > 9 && coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 0 (l-9)) "" in + Ulist0sep (entry, sep) + else if l > 4 && coincide s "_opt" (l-4) then + let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + Uopt entry + else if l > 5 && coincide s "_mods" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-1)) "" in + Umodifiers entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) + else + let s = match s with "hyp" -> "var" | _ -> s in + Uentry s + +let arg_list = function Rawwit t -> Rawwit (ListArg t) +let arg_opt = function Rawwit t -> Rawwit (OptArg t) + +let interp_entry_name up_level s sep = + let open Extend in + let rec eval = function + | Ulist1 e -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist1 g) + | Ulist1sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist1sep (g, sep)) + | Ulist0 e -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist0 g) + | Ulist0sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist0sep (g, sep)) + | Uopt e -> + let EntryName (t, g) = eval e in + EntryName (arg_opt t, Aopt g) + | Umodifiers e -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Amodifiers g) + | Uentry s -> + begin + try try_get_entry uprim s with Not_found -> + try try_get_entry uconstr s with Not_found -> + try try_get_entry utactic s with Not_found -> + error ("Unknown entry "^s^".") + end + | Uentryl (s, n) -> + (** FIXME: do better someday *) + assert (String.equal s "tactic"); + get_tacentry n up_level + in + eval (parse_user_entry s sep) + (**********************************************************************) (* Tactic Notation *) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 207b43064c..75144addb2 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -57,16 +57,6 @@ type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a G.entry -> ty let object_of_typed_entry (TypedEntry (_, e)) = Gramobj.weaken_entry e let weaken_entry x = Gramobj.weaken_entry x -(** General entry keys *) - -(** This intermediate abstract representation of entries can - both be reified into mlexpr for the ML extensions and - dynamically interpreted as entries for the Coq level extensions -*) - -type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) symbol -> entry_name - (** Grammar extensions *) (** NB: [extend_statment = @@ -740,108 +730,8 @@ let grammar_extend e reinit ext = let ext = of_coq_extend_statement ext in unsafe_grammar_extend e reinit ext -(**********************************************************************) -(* Interpret entry names of the form "ne_constr_list" as entry keys *) - -let coincide s pat off = - let len = String.length pat in - let break = ref true in - let i = ref 0 in - while !break && !i < len do - let c = Char.code s.[off + !i] in - let d = Char.code pat.[!i] in - break := Int.equal c d; - incr i - done; - !break - let name_of_entry e = Entry.unsafe_of_name (Gram.Entry.name e) -let atactic n = - if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) - else Aentryl (name_of_entry Tactic.tactic_expr, n) - -let try_get_entry u s = - (** Order the effects: get_entry can raise Not_found *) - let TypedEntry (typ, e) = get_entry u s in - EntryName (typ, Aentry (name_of_entry e)) - -(** Quite ad-hoc *) -let get_tacentry n m = - let check_lvl n = - Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - if check_lvl n then EntryName (rawwit wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext) - else EntryName (rawwit wit_tactic, atactic n) - -let rec parse_user_entry s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let entry = parse_user_entry (String.sub s 3 (l-8)) "" in - Ulist1 entry - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 3 (l-12)) "" in - Ulist1sep (entry, sep) - else if l > 5 && coincide s "_list" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-5)) "" in - Ulist0 entry - else if l > 9 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 0 (l-9)) "" in - Ulist0sep (entry, sep) - else if l > 4 && coincide s "_opt" (l-4) then - let entry = parse_user_entry (String.sub s 0 (l-4)) "" in - Uopt entry - else if l > 5 && coincide s "_mods" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-1)) "" in - Umodifiers entry - else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then - let n = Char.code s.[6] - 48 in - Uentryl ("tactic", n) - else - let s = match s with "hyp" -> "var" | _ -> s in - Uentry s - -let arg_list = function Rawwit t -> Rawwit (ListArg t) -let arg_opt = function Rawwit t -> Rawwit (OptArg t) - -let rec interp_entry_name up_level s sep = - let rec eval = function - | Ulist1 e -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist1 g) - | Ulist1sep (e, sep) -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist1sep (g, sep)) - | Ulist0 e -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist0 g) - | Ulist0sep (e, sep) -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Alist0sep (g, sep)) - | Uopt e -> - let EntryName (t, g) = eval e in - EntryName (arg_opt t, Aopt g) - | Umodifiers e -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Amodifiers g) - | Uentry s -> - begin - try try_get_entry uprim s with Not_found -> - try try_get_entry uconstr s with Not_found -> - try try_get_entry utactic s with Not_found -> - error ("Unknown entry "^s^".") - end - | Uentryl (s, n) -> - (** FIXME: do better someday *) - assert (String.equal s "tactic"); - get_tacentry n up_level - in - eval (parse_user_entry s sep) - let list_entry_names () = let add_entry key (TypedEntry (entry, _)) accu = (key, unquote entry) :: accu in let ans = Hashtbl.fold add_entry (get_utable uprim) [] in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 35973a4d72..afe8889096 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -268,13 +268,9 @@ val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** Binding general entry keys to symbols *) -type entry_name = EntryName : - 'a raw_abstract_argument_type * (raw_tactic_expr, 'a) Extend.symbol -> entry_name +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a Gram.entry -> typed_entry -(** [interp_entry_name lev n sep] returns the entry corresponding to the name - [n] of the form "ne_constr_list" in a tactic entry of level [lev] with - separator [sep]. *) -val interp_entry_name : int -> string -> string -> entry_name +val get_entry : gram_universe -> string -> typed_entry (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * argument_type) list -- cgit v1.2.3 From 63cef1ee8de62312df9afc2d515578df9c4cb9b1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 17:36:52 +0200 Subject: Abstracting away the Summary-synchronized grammar-modifying commands. We provide an API so that external code such as plugins can define grammar extensions synchronized with the summary. This API is not perfect yet and is a mere abstraction of the current behaviour. In particular, it expects the user to modify the parser in an imperative way. --- parsing/egramcoq.ml | 69 +++++++++++++++++++++++++++++++--------------------- parsing/egramcoq.mli | 14 +++++++++++ 2 files changed, 55 insertions(+), 28 deletions(-) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 8c4930806e..5e89567cc4 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -217,7 +217,7 @@ let extend_constr_pat_notation ng = let ext = ETConstr (level, ()), ng.notgram_assoc in extend_constr e ext (make_cases_pattern_action mkact) true ng.notgram_prods -let extend_constr_notation ng = +let extend_constr_notation (_, ng) = (* Add the notation in constr *) let nb = extend_constr_constr_notation ng in (* Add the notation in cases_pattern *) @@ -245,14 +245,24 @@ type tactic_grammar = { tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } -type all_grammar_command = - | Notation of Notation.level * notation_grammar - | TacticGrammar of KerName.t * tactic_grammar - | MLTacticGrammar of ml_tactic_name * Tacexpr.raw_tactic_expr grammar_prod_item list list +module GrammarCommand = Dyn.Make(struct end) +module GrammarInterp = struct type 'a t = 'a -> int end +module GrammarInterpMap = GrammarCommand.Map(GrammarInterp) + +let grammar_interp = ref GrammarInterpMap.empty + +let (grammar_state : (int * GrammarCommand.t) list ref) = ref [] + +type 'a grammar_command = 'a GrammarCommand.tag + +let create_grammar_command name interp : _ grammar_command = + let obj = GrammarCommand.create name in + let () = grammar_interp := GrammarInterpMap.add obj interp !grammar_interp in + obj (** ML Tactic grammar extensions *) -let add_ml_tactic_entry name prods = +let add_ml_tactic_entry (name, prods) = let entry = Tactic.simple_tactic in let mkact i loc l : raw_tactic_expr = let open Tacexpr in @@ -273,7 +283,7 @@ let head_is_ident tg = match tg.tacgram_prods with (** Tactic grammar extensions *) -let add_tactic_entry kn tg = +let add_tactic_entry (kn, tg) = let entry, pos = get_tactic_entry tg.tacgram_level in let mkact loc l = let filter = function @@ -301,31 +311,34 @@ let add_tactic_entry kn tg = grammar_extend entry None (pos, [(None, None, List.rev [rules])]); 1 -let (grammar_state : (int * all_grammar_command) list ref) = ref [] +let extend_grammar tag g = + let nb = GrammarInterpMap.find tag !grammar_interp g in + grammar_state := (nb, GrammarCommand.Dyn (tag, g)) :: !grammar_state -let extend_grammar gram = - let nb = match gram with - | Notation (_,a) -> extend_constr_notation a - | TacticGrammar (kn, g) -> add_tactic_entry kn g - | MLTacticGrammar (name, pr) -> add_ml_tactic_entry name pr - in - grammar_state := (nb,gram) :: !grammar_state +let extend_dyn_grammar (GrammarCommand.Dyn (tag, g)) = extend_grammar tag g + +let constr_grammar : (Notation.level * notation_grammar) GrammarCommand.tag = + create_grammar_command "Notation" extend_constr_notation -let extend_constr_grammar pr ntn = - extend_grammar (Notation (pr, ntn)) +let tactic_grammar = + create_grammar_command "TacticGrammar" add_tactic_entry -let extend_tactic_grammar kn ntn = - extend_grammar (TacticGrammar (kn, ntn)) +let ml_tactic_grammar = + create_grammar_command "MLTacticGrammar" add_ml_tactic_entry -let extend_ml_tactic_grammar name ntn = - extend_grammar (MLTacticGrammar (name, ntn)) +let extend_constr_grammar pr ntn = extend_grammar constr_grammar (pr, ntn) +let extend_tactic_grammar kn ntn = extend_grammar tactic_grammar (kn, ntn) +let extend_ml_tactic_grammar n ntn = extend_grammar ml_tactic_grammar (n, ntn) let recover_constr_grammar ntn prec = - let filter = function - | _, Notation (prec', ng) when - Notation.level_eq prec prec' && - String.equal ntn ng.notgram_notation -> Some ng - | _ -> None + let filter (_, gram) : notation_grammar option = match gram with + | GrammarCommand.Dyn (tag, obj) -> + match GrammarCommand.eq tag constr_grammar with + | None -> None + | Some Refl -> + let (prec', ng) = obj in + if Notation.level_eq prec prec' && String.equal ntn ng.notgram_notation then Some ng + else None in match List.map_filter filter !grammar_state with | [x] -> x @@ -334,7 +347,7 @@ let recover_constr_grammar ntn prec = (* Summary functions: the state of the lexer is included in that of the parser. Because the grammar affects the set of keywords when adding or removing grammar rules. *) -type frozen_t = (int * all_grammar_command) list * Lexer.frozen_t +type frozen_t = (int * GrammarCommand.t) list * Lexer.frozen_t let freeze _ : frozen_t = (!grammar_state, Lexer.freeze ()) @@ -353,7 +366,7 @@ let unfreeze (grams, lex) = remove_levels n; grammar_state := common; Lexer.unfreeze lex; - List.iter extend_grammar (List.rev_map snd redo) + List.iter extend_dyn_grammar (List.rev_map snd redo) (** No need to provide an init function : the grammar state is statically available, and already empty initially, while diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 23eaa64eec..153f7528ff 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -41,6 +41,20 @@ type tactic_grammar = { tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; } +(** {5 Extending the parser with Summary-synchronized commands} *) + +type 'a grammar_command +(** Type of synchronized parsing extensions. The ['a] type should be + marshallable. *) + +val create_grammar_command : string -> ('a -> int) -> 'a grammar_command +(** Create a new grammar-modifying command with the given name. The function + should modify the parser state and return the number of grammar extensions + performed. *) + +val extend_grammar : 'a grammar_command -> 'a -> unit +(** Extend the grammar of Coq with the given data. *) + (** {5 Adding notations} *) val extend_constr_grammar : Notation.level -> notation_grammar -> unit -- cgit v1.2.3 From b5de86be330f6c878b8f12173d46a4c250fac755 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 18:42:07 +0200 Subject: Moving the code handling tactic notations to Tacentries. --- grammar/argextend.ml4 | 2 +- ltac/extraargs.ml4 | 4 +- ltac/tacentries.ml | 119 ++++++++++++++++++++++++++++++++++++++++++++++++-- ltac/tacentries.mli | 8 ++++ parsing/egramcoq.ml | 110 ---------------------------------------------- parsing/egramcoq.mli | 21 --------- 6 files changed, 127 insertions(+), 137 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index f9f3ee988e..adfbd8cfde 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -140,7 +140,7 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = <:str_item< do { Pptactic.declare_extra_genarg_pprule $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$; - Egramcoq.create_ltac_quotation $se$ + Tacentries.create_ltac_quotation $se$ (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit $wit$) v)) ($lid:s$, None) } >> ] diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 index d33ec91f9d..4d3507cbc4 100644 --- a/ltac/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -25,7 +25,7 @@ open Locus let create_generic_quotation name e wit = let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in - Egramcoq.create_ltac_quotation name inject (e, None) + Tacentries.create_ltac_quotation name inject (e, None) let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string @@ -38,7 +38,7 @@ let () = create_generic_quotation "ipattern" Pcoq.Tactic.simple_intropattern Con let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Constrarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in - Egramcoq.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5) + Tacentries.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5) (* Rewriting orientation *) diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index e247a138dd..99c2213e19 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -127,6 +127,88 @@ let interp_entry_name up_level s sep = in eval (parse_user_entry s sep) +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +let get_tactic_entry n = + if Int.equal n 0 then + Tactic.simple_tactic, None + else if Int.equal n 5 then + Tactic.binder_tactic, None + else if 1<=n && n<5 then + Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) + else + error ("Invalid Tactic Notation level: "^(string_of_int n)^".") + +(**********************************************************************) +(** State of the grammar extensions *) + +type tactic_grammar = { + tacgram_level : int; + tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; +} + +(** ML Tactic grammar extensions *) + +let add_ml_tactic_entry (name, prods) = + let entry = Tactic.simple_tactic in + let mkact i loc l : Tacexpr.raw_tactic_expr = + let open Tacexpr in + let entry = { mltac_name = name; mltac_index = i } in + let map arg = TacGeneric arg in + TacML (loc, entry, List.map map l) + in + let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in + synchronize_level_positions (); + grammar_extend entry None (None, [(None, None, List.rev rules)]); + 1 + +(* Declaration of the tactic grammar rule *) + +let head_is_ident tg = match tg.tacgram_prods with +| GramTerminal _::_ -> true +| _ -> false + +(** Tactic grammar extensions *) + +let add_tactic_entry (kn, tg) = + let open Tacexpr in + let entry, pos = get_tactic_entry tg.tacgram_level in + let mkact loc l = + let filter = function + | GramTerminal _ -> None + | GramNonTerminal (_, t, _) -> Some (Genarg.unquote t) + in + let types = List.map_filter filter tg.tacgram_prods in + let map arg t = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Constrarg.wit_tactic in + if Genarg.argument_type_eq t (Genarg.unquote wit) then + Tacexp (Genarg.out_gen wit arg) + else + TacGeneric arg + in + let l = List.map2 map l types in + (TacAlias (loc,kn,l):raw_tactic_expr) + in + let () = + if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then + error "Notation for simple tactic must start with an identifier." + in + let rules = make_rule mkact tg.tacgram_prods in + synchronize_level_positions (); + grammar_extend entry None (pos, [(None, None, List.rev [rules])]); + 1 + +let tactic_grammar = + create_grammar_command "TacticGrammar" add_tactic_entry + +let ml_tactic_grammar = + create_grammar_command "MLTacticGrammar" add_ml_tactic_entry + +let extend_tactic_grammar kn ntn = extend_grammar tactic_grammar (kn, ntn) +let extend_ml_tactic_grammar n ntn = extend_grammar ml_tactic_grammar (n, ntn) + (**********************************************************************) (* Tactic Notation *) @@ -172,13 +254,13 @@ let cache_tactic_notation (_, tobj) = let key = tobj.tacobj_key in let () = check_key key in Tacenv.register_alias key tobj.tacobj_body; - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram; + extend_tactic_grammar key tobj.tacobj_tacgram; Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp let open_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram + extend_tactic_grammar key tobj.tacobj_tacgram let load_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in @@ -187,7 +269,7 @@ let load_tactic_notation i (_, tobj) = Tacenv.register_alias key tobj.tacobj_body; Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp; if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram + extend_tactic_grammar key tobj.tacobj_tacgram let subst_tactic_notation (subst, tobj) = let (ids, body) = tobj.tacobj_body in @@ -297,6 +379,37 @@ let add_ml_tactic_notation name prods = Lib.add_anonymous_leaf (inMLTacticGrammar obj); extend_atomic_tactic name prods +(**********************************************************************) +(** Ltac quotations *) + +let ltac_quotations = ref String.Set.empty + +let create_ltac_quotation name cast (e, l) = + let open Extend in + let () = + if String.Set.mem name !ltac_quotations then + failwith ("Ltac quotation " ^ name ^ " already registered") + in + let () = ltac_quotations := String.Set.add name !ltac_quotations in + let entry = match l with + | None -> Aentry (name_of_entry e) + | Some l -> Aentryl (name_of_entry e, l) + in +(* let level = Some "1" in *) + let level = None in + let assoc = None in + let rule = + Next (Next (Next (Next (Next (Stop, + Atoken (Lexer.terminal name)), + Atoken (Lexer.terminal ":")), + Atoken (Lexer.terminal "(")), + entry), + Atoken (Lexer.terminal ")")) + in + let action _ v _ _ _ loc = cast (loc, v) in + let gram = (level, assoc, [Rule (rule, action)]) in + Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) + (** Command *) diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli index 3cf0bc5cc9..b60d8f478e 100644 --- a/ltac/tacentries.mli +++ b/ltac/tacentries.mli @@ -19,3 +19,11 @@ val add_ml_tactic_notation : ml_tactic_name -> Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit val register_ltac : bool -> Vernacexpr.tacdef_body list -> unit + +(** {5 Adding tactic quotations} *) + +val create_ltac_quotation : string -> + ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit +(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, + Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and + generates an argument using [f] on the entry parsed by [e]. *) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 5e89567cc4..f0c12ab8ef 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -224,27 +224,6 @@ let extend_constr_notation (_, ng) = let nb' = extend_constr_pat_notation ng in nb + nb' -(**********************************************************************) -(** Grammar declaration for Tactic Notation (Coq level) *) - -let get_tactic_entry n = - if Int.equal n 0 then - Tactic.simple_tactic, None - else if Int.equal n 5 then - Tactic.binder_tactic, None - else if 1<=n && n<5 then - Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) - else - error ("Invalid Tactic Notation level: "^(string_of_int n)^".") - -(**********************************************************************) -(** State of the grammar extensions *) - -type tactic_grammar = { - tacgram_level : int; - tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; -} - module GrammarCommand = Dyn.Make(struct end) module GrammarInterp = struct type 'a t = 'a -> int end module GrammarInterpMap = GrammarCommand.Map(GrammarInterp) @@ -260,57 +239,6 @@ let create_grammar_command name interp : _ grammar_command = let () = grammar_interp := GrammarInterpMap.add obj interp !grammar_interp in obj -(** ML Tactic grammar extensions *) - -let add_ml_tactic_entry (name, prods) = - let entry = Tactic.simple_tactic in - let mkact i loc l : raw_tactic_expr = - let open Tacexpr in - let entry = { mltac_name = name; mltac_index = i } in - let map arg = TacGeneric arg in - TacML (loc, entry, List.map map l) - in - let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in - synchronize_level_positions (); - grammar_extend entry None (None, [(None, None, List.rev rules)]); - 1 - -(* Declaration of the tactic grammar rule *) - -let head_is_ident tg = match tg.tacgram_prods with -| GramTerminal _::_ -> true -| _ -> false - -(** Tactic grammar extensions *) - -let add_tactic_entry (kn, tg) = - let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = - let filter = function - | GramTerminal _ -> None - | GramNonTerminal (_, t, _) -> Some (Genarg.unquote t) - in - let types = List.map_filter filter tg.tacgram_prods in - let map arg t = - (** HACK to handle especially the tactic(...) entry *) - let wit = Genarg.rawwit Constrarg.wit_tactic in - if Genarg.argument_type_eq t (Genarg.unquote wit) then - Tacexp (Genarg.out_gen wit arg) - else - TacGeneric arg - in - let l = List.map2 map l types in - (TacAlias (loc,kn,l):raw_tactic_expr) - in - let () = - if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then - error "Notation for simple tactic must start with an identifier." - in - let rules = make_rule mkact tg.tacgram_prods in - synchronize_level_positions (); - grammar_extend entry None (pos, [(None, None, List.rev [rules])]); - 1 - let extend_grammar tag g = let nb = GrammarInterpMap.find tag !grammar_interp g in grammar_state := (nb, GrammarCommand.Dyn (tag, g)) :: !grammar_state @@ -320,15 +248,7 @@ let extend_dyn_grammar (GrammarCommand.Dyn (tag, g)) = extend_grammar tag g let constr_grammar : (Notation.level * notation_grammar) GrammarCommand.tag = create_grammar_command "Notation" extend_constr_notation -let tactic_grammar = - create_grammar_command "TacticGrammar" add_tactic_entry - -let ml_tactic_grammar = - create_grammar_command "MLTacticGrammar" add_ml_tactic_entry - let extend_constr_grammar pr ntn = extend_grammar constr_grammar (pr, ntn) -let extend_tactic_grammar kn ntn = extend_grammar tactic_grammar (kn, ntn) -let extend_ml_tactic_grammar n ntn = extend_grammar ml_tactic_grammar (n, ntn) let recover_constr_grammar ntn prec = let filter (_, gram) : notation_grammar option = match gram with @@ -386,33 +306,3 @@ let with_grammar_rule_protection f x = let reraise = Errors.push reraise in let () = unfreeze fs in iraise reraise - -(**********************************************************************) -(** Ltac quotations *) - -let ltac_quotations = ref String.Set.empty - -let create_ltac_quotation name cast (e, l) = - let () = - if String.Set.mem name !ltac_quotations then - failwith ("Ltac quotation " ^ name ^ " already registered") - in - let () = ltac_quotations := String.Set.add name !ltac_quotations in - let entry = match l with - | None -> Aentry (name_of_entry e) - | Some l -> Aentryl (name_of_entry e, l) - in -(* let level = Some "1" in *) - let level = None in - let assoc = None in - let rule = - Next (Next (Next (Next (Next (Stop, - Atoken (Lexer.terminal name)), - Atoken (Lexer.terminal ":")), - Atoken (Lexer.terminal "(")), - entry), - Atoken (Lexer.terminal ")")) - in - let action _ v _ _ _ loc = cast (loc, v) in - let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 153f7528ff..6ec1066260 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -36,11 +36,6 @@ type notation_grammar = { notgram_typs : notation_var_internalization_type list; } -type tactic_grammar = { - tacgram_level : int; - tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; -} - (** {5 Extending the parser with Summary-synchronized commands} *) type 'a grammar_command @@ -60,24 +55,8 @@ val extend_grammar : 'a grammar_command -> 'a -> unit val extend_constr_grammar : Notation.level -> notation_grammar -> unit (** Add a term notation rule to the parsing system. *) -val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit -(** Add a tactic notation rule to the parsing system. This produces a TacAlias - tactic with the provided kernel name. *) - -val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> Tacexpr.raw_tactic_expr grammar_prod_item list list -> unit -(** Add a ML tactic notation rule to the parsing system. This produces a - TacML tactic with the provided string as name. *) - val recover_constr_grammar : notation -> Notation.level -> notation_grammar (** For a declared grammar, returns the rule + the ordered entry types of variables in the rule (for use in the interpretation) *) val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b - -(** {5 Adding tactic quotations} *) - -val create_ltac_quotation : string -> - ('grm Loc.located -> Tacexpr.raw_tactic_arg) -> ('grm Gram.entry * int option) -> unit -(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, - Ltac grammar now accepts arguments of the form ["name" ":" "(" ")"], and - generates an argument using [f] on the entry parsed by [e]. *) -- cgit v1.2.3 From bacba3d3ec0dd54d210bdf5045bc7e193c904b3c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 19:37:40 +0200 Subject: Adding a test for bug #1850. --- test-suite/bugs/closed/1850.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/1850.v diff --git a/test-suite/bugs/closed/1850.v b/test-suite/bugs/closed/1850.v new file mode 100644 index 0000000000..26b48093b7 --- /dev/null +++ b/test-suite/bugs/closed/1850.v @@ -0,0 +1,4 @@ +Parameter P : Type -> Type -> Type. +Notation "e |= t --> v" := (P e t v) (at level 100, t at level 54). +Fail Check (nat |= nat --> nat). + -- cgit v1.2.3 From b3315a798edcaea533b592cc442e82260502bd49 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 1 Apr 2016 11:13:07 +0200 Subject: Getting rid of the "_mods" parsing entry. It was only used by setoid_ring for the Add Ring command, and was easily replaced by a dedicated argument. Moreover, it was of no use to tactic notations. --- grammar/q_util.ml4 | 7 +------ grammar/q_util.mli | 1 - intf/extend.mli | 2 -- ltac/tacentries.ml | 6 ------ parsing/pcoq.ml | 7 ------- plugins/setoid_ring/g_newring.ml4 | 18 ++++++++++++++---- 6 files changed, 15 insertions(+), 26 deletions(-) diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 53e1f008d9..c529260e9d 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -22,7 +22,6 @@ type user_symbol = | Ulist0 of user_symbol | Ulist0sep of user_symbol * string | Uopt of user_symbol -| Umodifiers of user_symbol | Uentry of string | Uentryl of string * int @@ -68,7 +67,6 @@ let rec mlexpr_of_prod_entry_key f = function | Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> | Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> | Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> - | Umodifiers s -> <:expr< Extend.Amodifiers $mlexpr_of_prod_entry_key f s$ >> | Uentry e -> <:expr< Extend.Aentry $f e$ >> | Uentryl (e, l) -> (** Keep in sync with Pcoq! *) @@ -77,7 +75,7 @@ let rec mlexpr_of_prod_entry_key f = function else <:expr< Extend.Aentryl (Pcoq.name_of_entry Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> let rec type_of_user_symbol = function -| Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) | Umodifiers s -> +| Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) -> ListArgType (type_of_user_symbol s) | Uopt s -> OptArgType (type_of_user_symbol s) @@ -113,9 +111,6 @@ let rec parse_user_entry s sep = else if l > 4 && coincide s "_opt" (l-4) then let entry = parse_user_entry (String.sub s 0 (l-4)) "" in Uopt entry - else if l > 5 && coincide s "_mods" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-1)) "" in - Umodifiers entry else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in Uentryl ("tactic", n) diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 8c437b42a1..a34fc0bcb7 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -20,7 +20,6 @@ type user_symbol = | Ulist0 of user_symbol | Ulist0sep of user_symbol * string | Uopt of user_symbol -| Umodifiers of user_symbol | Uentry of string | Uentryl of string * int diff --git a/intf/extend.mli b/intf/extend.mli index e1520dec54..10713745e4 100644 --- a/intf/extend.mli +++ b/intf/extend.mli @@ -59,7 +59,6 @@ type user_symbol = | Ulist0 : user_symbol -> user_symbol | Ulist0sep : user_symbol * string -> user_symbol | Uopt : user_symbol -> user_symbol -| Umodifiers : user_symbol -> user_symbol | Uentry : string -> user_symbol | Uentryl : string * int -> user_symbol @@ -83,7 +82,6 @@ type ('self, 'a) symbol = | Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol | Alist0sep : ('self, 'a) symbol * string -> ('self, 'a list) symbol | Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol -| Amodifiers : ('self, 'a) symbol -> ('self, 'a list) symbol | Aself : ('self, 'self) symbol | Anext : ('self, 'self) symbol | Aentry : 'a Entry.t -> ('self, 'a) symbol diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index 99c2213e19..ced4733433 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -79,9 +79,6 @@ let rec parse_user_entry s sep = else if l > 4 && coincide s "_opt" (l-4) then let entry = parse_user_entry (String.sub s 0 (l-4)) "" in Uopt entry - else if l > 5 && coincide s "_mods" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-1)) "" in - Umodifiers entry else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in Uentryl ("tactic", n) @@ -110,9 +107,6 @@ let interp_entry_name up_level s sep = | Uopt e -> let EntryName (t, g) = eval e in EntryName (arg_opt t, Aopt g) - | Umodifiers e -> - let EntryName (t, g) = eval e in - EntryName (arg_list t, Amodifiers g) | Uentry s -> begin try try_get_entry uprim s with Not_found -> diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 75144addb2..802c24eef4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -683,13 +683,6 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Alist0sep (s,sep) -> Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) - | Amodifiers s -> - Gram.srules' - [([], Gram.action (fun _loc -> [])); - ([gram_token_of_string "("; - Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); - gram_token_of_string ")"], - Gram.action (fun _ l _ _loc -> l))] | Aself -> Symbols.sself | Anext -> Symbols.snext | Aentry e -> diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index cd1d704dde..1ebb6e6b77 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -51,9 +51,14 @@ VERNAC ARGUMENT EXTEND ring_mod | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] END +VERNAC ARGUMENT EXTEND ring_mods + | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ] +END + VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF - | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> - [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in + | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> + [ let l = match l with None -> [] | Some l -> l in + let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in add_theory id (ic t) set k cst (pre,post) power sign div] | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ msg_notice (strbrk "The following ring structures have been declared:"); @@ -75,9 +80,14 @@ VERNAC ARGUMENT EXTEND field_mod | [ "completeness" constr(inj) ] -> [ Inject inj ] END +VERNAC ARGUMENT EXTEND field_mods + | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ] +END + VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF -| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> - [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in +| [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> + [ let l = match l with None -> [] | Some l -> l in + let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ msg_notice (strbrk "The following field structures have been declared:"); -- cgit v1.2.3 From 856780b163fdcd5e36a1d4af99034e3af6fde1d7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 2 Apr 2016 21:24:46 +0200 Subject: Fixing the "No applicable tactic" non informative error message regression on apply. --- tactics/tactics.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f23808f6f9..28aed8a10e 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1429,7 +1429,8 @@ let descend_in_conjunctions avoid tac (err, info) c = with Not_found -> let elim = build_case_analysis_scheme env sigma (ind,u) false sort in NotADefinedRecordUseScheme (snd elim) in - Tacticals.New.tclFIRST + Tacticals.New.tclORELSE0 + (Tacticals.New.tclFIRST (List.init n (fun i -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1442,7 +1443,8 @@ let descend_in_conjunctions avoid tac (err, info) c = [Proofview.V82.tactic (refine p); (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] - end)) + end))) + (Proofview.tclZERO ~info err) | None -> Proofview.tclZERO ~info err with RefinerError _|UserError _ -> Proofview.tclZERO ~info err end -- cgit v1.2.3 From 17c2147fe0a73b4e0af6481afd73df5cdcf8aefd Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 4 Apr 2016 15:47:34 +0200 Subject: Fix after merge, the revert of Bind Scope applies to trunk only. --- CHANGES | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/CHANGES b/CHANGES index 161906fd72..3f7cc7c98e 100644 --- a/CHANGES +++ b/CHANGES @@ -24,6 +24,10 @@ Program - The "Shrink Obligations" flag now applies to all obligations, not only those solved by the automatic tactic. +Notations + +- "Bind Scope" can once again bind "Funclass" and "Sortclass". + Changes from V8.5beta3 to V8.5 ============================== @@ -103,9 +107,6 @@ solved by the automatic tactic. - Documented the Hint Cut command that allows control of the proof-search during typeclass resolution (see reference manual). -Notations -- "Bind Scope" can once again bind "Funclass" and "Sortclass". - API - Some functions from pretyping/typing.ml and their derivatives were potential -- cgit v1.2.3 From 59cb5ca9b6c0e29fe65e9ae99dfd6cabafc52be6 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 28 Oct 2015 15:17:30 -0400 Subject: Add compatibility Nonrecursive Elimination Schemes --- theories/Compat/Coq84.v | 3 +++ 1 file changed, 3 insertions(+) diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index 90083b00d9..d695ef1d89 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -15,6 +15,9 @@ Ltac omega := Coq.omega.Omega.omega. (** The number of arguments given in [match] statements has changed from 8.4 to 8.5. *) Global Set Asymmetric Patterns. +(** The automatic elimination schemes for records were dropped by default in 8.5. This restores the default behavior of Coq 8.4. *) +Global Set Nonrecursive Elimination Schemes. + (** See bug 3545 *) Global Set Universal Lemma Under Conjunction. -- cgit v1.2.3 From 4c078b0362542908eb2fe1d63f0d867b339953fd Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 29 Dec 2015 13:21:17 -0500 Subject: Update Coq84.v We no longer need to redefine `refine` (it now shelves by default). Also clean up `constructor` a bit. --- theories/Compat/Coq84.v | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index d695ef1d89..5036b9bc85 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -21,16 +21,11 @@ Global Set Nonrecursive Elimination Schemes. (** See bug 3545 *) Global Set Universal Lemma Under Conjunction. -(** In 8.5, [refine] leaves over dependent subgoals. *) -Tactic Notation "refine" uconstr(term) := refine term; shelve_unifiable. - (** In 8.4, [constructor (tac)] allowed backtracking across the use of [constructor]; it has been subsumed by [constructor; tac]. *) -Ltac constructor_84 := constructor. -Ltac constructor_84_n n := constructor n. Ltac constructor_84_tac tac := once (constructor; tac). -Tactic Notation "constructor" := constructor_84. -Tactic Notation "constructor" int_or_var(n) := constructor_84_n n. +Tactic Notation "constructor" := Coq.Init.Notations.constructor. +Tactic Notation "constructor" int_or_var(n) := Coq.Init.Notations.constructor n. Tactic Notation "constructor" "(" tactic(tac) ")" := constructor_84_tac tac. (** Some tactic notations do not factor well with tactics; we add global parsing entries for some tactics that would otherwise be overwritten by custom variants. See https://coq.inria.fr/bugs/show_bug.cgi?id=4392. *) -- cgit v1.2.3 From a585d46fbacfcc9cddf3da439e5f7001d429ba2a Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 5 Apr 2016 12:56:52 -0400 Subject: Fix bug #4656 I introduced this bug in 4c078b0362542908eb2fe1d63f0d867b339953fd; Coq.Init.Notations.constructor does not take any arguments. --- test-suite/bugs/closed/4656.v | 4 ++++ theories/Compat/Coq84.v | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) create mode 100644 test-suite/bugs/closed/4656.v diff --git a/test-suite/bugs/closed/4656.v b/test-suite/bugs/closed/4656.v new file mode 100644 index 0000000000..c89a86d634 --- /dev/null +++ b/test-suite/bugs/closed/4656.v @@ -0,0 +1,4 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) +Goal True. + constructor 1. +Qed. diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index 5036b9bc85..3266281922 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -22,10 +22,11 @@ Global Set Nonrecursive Elimination Schemes. Global Set Universal Lemma Under Conjunction. (** In 8.4, [constructor (tac)] allowed backtracking across the use of [constructor]; it has been subsumed by [constructor; tac]. *) +Ltac constructor_84_n n := constructor n. Ltac constructor_84_tac tac := once (constructor; tac). Tactic Notation "constructor" := Coq.Init.Notations.constructor. -Tactic Notation "constructor" int_or_var(n) := Coq.Init.Notations.constructor n. +Tactic Notation "constructor" int_or_var(n) := constructor_84_n n. Tactic Notation "constructor" "(" tactic(tac) ")" := constructor_84_tac tac. (** Some tactic notations do not factor well with tactics; we add global parsing entries for some tactics that would otherwise be overwritten by custom variants. See https://coq.inria.fr/bugs/show_bug.cgi?id=4392. *) @@ -43,7 +44,6 @@ Tactic Notation "left" := left. Tactic Notation "eleft" := eleft. Tactic Notation "right" := right. Tactic Notation "eright" := eright. -Tactic Notation "constructor" := constructor. Tactic Notation "econstructor" := econstructor. Tactic Notation "symmetry" := symmetry. Tactic Notation "split" := split. -- cgit v1.2.3 From ab08345ebdb477bf4c83b46e0d8adc29296392f9 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 5 Apr 2016 13:18:00 -0400 Subject: Add -compat 8.4 econstructor tactics, and tests Passing `-compat 8.4` now allows the use of `econstructor (tac)`, as in 8.4. --- test-suite/success/Compat84.v | 19 +++++++++++++++++++ theories/Compat/Coq84.v | 9 ++++++++- 2 files changed, 27 insertions(+), 1 deletion(-) create mode 100644 test-suite/success/Compat84.v diff --git a/test-suite/success/Compat84.v b/test-suite/success/Compat84.v new file mode 100644 index 0000000000..db6348fa17 --- /dev/null +++ b/test-suite/success/Compat84.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) + +Goal True. + solve [ constructor 1 ]. Undo. + solve [ econstructor 1 ]. Undo. + solve [ constructor ]. Undo. + solve [ econstructor ]. Undo. + solve [ constructor (fail) ]. Undo. + solve [ econstructor (fail) ]. Undo. + split. +Qed. + +Goal False \/ True. + solve [ constructor (constructor) ]. Undo. + solve [ econstructor (econstructor) ]. Undo. + solve [ constructor 2; constructor ]. Undo. + solve [ econstructor 2; econstructor ]. Undo. + right; esplit. +Qed. diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index 3266281922..d99d50996a 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -29,6 +29,14 @@ Tactic Notation "constructor" := Coq.Init.Notations.constructor. Tactic Notation "constructor" int_or_var(n) := constructor_84_n n. Tactic Notation "constructor" "(" tactic(tac) ")" := constructor_84_tac tac. +(** In 8.4, [econstructor (tac)] allowed backtracking across the use of [econstructor]; it has been subsumed by [econstructor; tac]. *) +Ltac econstructor_84_n n := econstructor n. +Ltac econstructor_84_tac tac := once (econstructor; tac). + +Tactic Notation "econstructor" := Coq.Init.Notations.econstructor. +Tactic Notation "econstructor" int_or_var(n) := econstructor_84_n n. +Tactic Notation "econstructor" "(" tactic(tac) ")" := econstructor_84_tac tac. + (** Some tactic notations do not factor well with tactics; we add global parsing entries for some tactics that would otherwise be overwritten by custom variants. See https://coq.inria.fr/bugs/show_bug.cgi?id=4392. *) Tactic Notation "reflexivity" := reflexivity. Tactic Notation "assumption" := assumption. @@ -44,7 +52,6 @@ Tactic Notation "left" := left. Tactic Notation "eleft" := eleft. Tactic Notation "right" := right. Tactic Notation "eright" := eright. -Tactic Notation "econstructor" := econstructor. Tactic Notation "symmetry" := symmetry. Tactic Notation "split" := split. Tactic Notation "esplit" := esplit. -- cgit v1.2.3 From f9ef1441083a988a938e163393dfbab04ab9da18 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 7 Apr 2016 13:52:03 +0200 Subject: Use -win32 and -win64 suffixes for installer name on Windows. --- dev/make-installer-win32.sh | 2 +- dev/make-installer-win64.sh | 2 +- dev/nsis/coq.nsi | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dev/make-installer-win32.sh b/dev/make-installer-win32.sh index d405e66cc0..51d428dd1e 100755 --- a/dev/make-installer-win32.sh +++ b/dev/make-installer-win32.sh @@ -16,7 +16,7 @@ if [ ! -e bin/make.exe ]; then fi VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2` cd dev/nsis -"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" coq.nsi +"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" -DARCH="win32" coq.nsi echo Installer: ls -h $PWD/*exe cd ../.. diff --git a/dev/make-installer-win64.sh b/dev/make-installer-win64.sh index 2f765c1a10..438f4ae5b7 100755 --- a/dev/make-installer-win64.sh +++ b/dev/make-installer-win64.sh @@ -22,7 +22,7 @@ if [ ! -e bin/make.exe ]; then fi VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2` cd dev/nsis -"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" coq.nsi +"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" -DARCH="win64" coq.nsi echo Installer: ls -h $PWD/*exe cd ../.. diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index 676490510c..e1052b1e1b 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -13,7 +13,7 @@ SetCompressor lzma !define MY_PRODUCT "Coq" ;Define your own software name here !define COQ_SRC_PATH "..\.." -!define OUTFILE "coq-installer-${VERSION}.exe" +!define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe" !include "MUI2.nsh" !include "FileAssociation.nsh" -- cgit v1.2.3 From 9d50e5426cc816789650b7f541793a9ba773d14c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 7 Apr 2016 14:14:33 +0200 Subject: An example which failed in 8.5 and that d670c6b6 fixes. Thanks to Matthieu for the example. --- test-suite/success/setoid_test.v | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 4c173a3cd5..1f24ef2a6b 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -170,7 +170,12 @@ Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y) Definition t := nat -> bool. Definition h (a b : t) := forall n, a n = b n. -Goal forall a b, h a b -> a 0 = true. + +Instance subrelh : subrelation h (Morphisms.pointwise_relation nat eq). +Proof. intros x y H; assumption. Qed. + +Goal forall a b, h a b -> a 0 = b 0. intros. -rewrite H. (* Fallback on ordinary rewrite without anomaly *) -Abort. +setoid_rewrite H. (* Fallback on ordinary rewrite without anomaly *) +reflexivity. +Qed. -- cgit v1.2.3 From 83608720aac2a0a464649aca8b2a23ce395679ae Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 7 Apr 2016 14:58:27 +0200 Subject: Fixing an incorrect use of prod_appvect on a term which was not a product in setoid_rewrite. Backport of d670c6b6ce from trunk. --- tactics/rewrite.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 803e187ff5..21abafbf18 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1028,7 +1028,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | x -> x in let res = - { rew_car = prod_appvect r.rew_car args; + { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); rew_prf = prf; rew_evars = r.rew_evars } in -- cgit v1.2.3 From 9f0a896536e709880de5ba638069dea680803f62 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 7 Apr 2016 15:50:26 +0200 Subject: Allow to unset the refinement mode of Instance in ML Falling back to the global setting if not given. Useful to make Add Morphism fail correctly when the given proof terms are incomplete. Adapt test-suite file #2848 accordingly. --- tactics/rewrite.ml | 2 +- test-suite/bugs/closed/2848.v | 7 ++++--- toplevel/classes.ml | 4 ++-- toplevel/classes.mli | 1 + 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index 21abafbf18..9d70c177b4 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -1725,7 +1725,7 @@ let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = new_instance (Flags.is_universe_polymorphism ()) binders instance (Some (true, CRecord (Loc.ghost,None,fields))) - ~global ~generalize:false None + ~global ~generalize:false ~refine:false None let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v index de137d39d1..828e3b8c1f 100644 --- a/test-suite/bugs/closed/2848.v +++ b/test-suite/bugs/closed/2848.v @@ -2,8 +2,9 @@ Require Import Setoid. Parameter value' : Type. Parameter equiv' : value' -> value' -> Prop. - +Axiom cheat : forall {A}, A. Add Parametric Relation : _ equiv' - reflexivity proved by (Equivalence.equiv_reflexive _) - transitivity proved by (Equivalence.equiv_transitive _) + reflexivity proved by (Equivalence.equiv_reflexive cheat) + transitivity proved by (Equivalence.equiv_transitive cheat) as apply_equiv'_rel. +Check apply_equiv'_rel : PreOrder equiv'. \ No newline at end of file diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 5f73b70a2e..653b4695ce 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -119,7 +119,7 @@ let declare_instance_constant k pri global imps ?hook id pl poly evm term termty instance_hook k pri global imps ?hook (ConstRef kn); id -let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) props +let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in @@ -290,7 +290,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro if not (Evd.has_undefined evm) && not (Option.is_empty term) then declare_instance_constant k pri global imps ?hook id pl poly evm (Option.get term) termtype - else if Flags.is_program_mode () || !refine_instance || Option.is_empty term then begin + else if Flags.is_program_mode () || refine || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then let hook vis gr _ = diff --git a/toplevel/classes.mli b/toplevel/classes.mli index d600b3104f..f51e70388e 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -41,6 +41,7 @@ val declare_instance_constant : val new_instance : ?abstract:bool -> (** Not abstract by default. *) ?global:bool -> (** Not global by default. *) + ?refine:bool -> (** Allow refinement *) Decl_kinds.polymorphic -> local_binder list -> typeclass_constraint -> -- cgit v1.2.3 From 1f6a31d138bcfcf341f28772de7c5e08906167c5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 8 Apr 2016 00:19:49 +0200 Subject: Fixing printing of Tactic Notations with tactic arguments. --- printing/pptactic.ml | 36 +++++++++++++++++++----------------- test-suite/success/TacticNotation2.v | 12 ++++++++++++ 2 files changed, 31 insertions(+), 17 deletions(-) create mode 100644 test-suite/success/TacticNotation2.v diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 982c18ec61..c175b206db 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -341,11 +341,9 @@ module Make | [], [] -> [] | _ -> failwith "Inconsistent arguments of extended tactic" - type any_arg = AnyArg : 'a Genarg.raw_abstract_argument_type -> any_arg - let filter_arg = function | Egramml.GramTerminal _ -> None - | Egramml.GramNonTerminal (_, t, _) -> Some (AnyArg t) + | Egramml.GramNonTerminal (_, Rawwit t, _) -> Some (ArgumentType t) let pr_tacarg_using_rule pr_gen l = let l = match l with @@ -386,25 +384,25 @@ module Make with Not_found -> KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" - let check_type t arg = match t, arg with - | AnyArg t, TacGeneric arg -> argument_type_eq (unquote t) (genarg_tag arg) - | _ -> false + let check_type t arg = match arg with + | TacGeneric arg -> argument_type_eq t (genarg_tag arg) + | _ -> argument_type_eq t (ArgumentType wit_tactic) - let unwrap_gen f = function TacGeneric x -> f x | _ -> assert false + let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg)) let pr_raw_extend_rec prc prlc prtac prpat = - pr_extend_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) + pr_extend_gen check_type (pr_farg prtac) let pr_glob_extend_rec prc prlc prtac prpat = - pr_extend_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) + pr_extend_gen check_type (pr_farg prtac) let pr_extend_rec prc prlc prtac prpat = - pr_extend_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) + pr_extend_gen check_type (pr_farg prtac) let pr_raw_alias prc prlc prtac prpat = - pr_alias_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) + pr_alias_gen check_type (pr_farg prtac) let pr_glob_alias prc prlc prtac prpat = - pr_alias_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) + pr_alias_gen check_type (pr_farg prtac) let pr_alias prc prlc prtac prpat = - pr_alias_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) + pr_alias_gen check_type (pr_farg prtac) (**********************************************************************) (* The tactic printer *) @@ -1185,7 +1183,7 @@ module Make pr_constant = pr_or_by_notation pr_reference; pr_reference = pr_reference; pr_name = pr_lident; - pr_generic = Genprint.generic_raw_print; + pr_generic = pr_raw_generic_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference; pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; } in @@ -1215,7 +1213,9 @@ module Make pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; - pr_generic = Genprint.generic_glb_print; + pr_generic = pr_glb_generic_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); pr_extend = pr_glob_extend_rec (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); @@ -1256,7 +1256,9 @@ module Make pr_constant = pr_evaluable_reference_env env; pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; - pr_generic = Genprint.generic_top_print; + pr_generic = pr_top_generic_rec + (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) + pr_value pr_constr_pattern; pr_extend = pr_extend_rec (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) pr_value pr_constr_pattern; @@ -1291,7 +1293,7 @@ module Make (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) let check_val_type t arg = - let AnyArg t = t in + let ArgumentType t = t in (* let t = Genarg.val_tag (Obj.magic t) in *) (* let Val.Dyn (t', _) = arg in *) (* match Genarg.Val.eq t t' with *) diff --git a/test-suite/success/TacticNotation2.v b/test-suite/success/TacticNotation2.v new file mode 100644 index 0000000000..cb341b8e10 --- /dev/null +++ b/test-suite/success/TacticNotation2.v @@ -0,0 +1,12 @@ +Tactic Notation "complete" tactic(tac) := tac; fail. + +Ltac f0 := complete (intuition idtac). +(** FIXME: This is badly printed because of bug #3079. + At least we check that it does not fail anomalously. *) +Print Ltac f0. + +Ltac f1 := complete f1. +Print Ltac f1. + +Ltac f2 := complete intuition. +Print Ltac f2. -- cgit v1.2.3 From b5420538da04984ca42eb4284a9be27f3b5ba021 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 8 Apr 2016 00:58:56 +0200 Subject: Fixing printing of toplevel values. This is not perfect yet, in particular the whole precedence system is a real mess, as there is a real need for tidying up the Pptactic implementation. Nonetheless, printing toplevel values is only used for debugging purposes, where an ugly display is better than none at all. --- dev/top_printers.ml | 2 +- lib/genarg.ml | 12 +++++++----- lib/genarg.mli | 3 ++- ltac/tacinterp.ml | 12 ++++++------ printing/pptactic.ml | 24 ++++++++++++++++++++---- printing/pptacticsig.mli | 2 ++ 6 files changed, 38 insertions(+), 17 deletions(-) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 141eab3f3f..29ea08e025 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -468,7 +468,7 @@ let pp_generic_argument arg = let prgenarginfo arg = let Val.Dyn (tag, _) = arg in - let tpe = Val.repr tag in + let tpe = Val.pr tag in (** FIXME *) (* try *) (* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) diff --git a/lib/genarg.ml b/lib/genarg.ml index 5d5b29c99d..ef0de89afb 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -61,11 +61,13 @@ struct end | _ -> None - let rec repr : type a. a tag -> std_ppcmds = function - | Base t -> str (ValT.repr t) - | List t -> repr t ++ spc () ++ str "list" - | Opt t -> repr t ++ spc () ++ str "option" - | Pair (t1, t2) -> str "(" ++ repr t1 ++ str " * " ++ repr t2 ++ str ")" + let repr = ValT.repr + + let rec pr : type a. a tag -> std_ppcmds = function + | Base t -> str (repr t) + | List t -> pr t ++ spc () ++ str "list" + | Opt t -> pr t ++ spc () ++ str "option" + | Pair (t1, t2) -> str "(" ++ pr t1 ++ str " * " ++ pr t2 ++ str ")" end diff --git a/lib/genarg.mli b/lib/genarg.mli index 6cc7893dc4..93665fd45d 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -99,7 +99,8 @@ sig type t = Dyn : 'a tag * 'a -> t val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option - val repr: 'a tag -> Pp.std_ppcmds + val repr : 'a typ -> string + val pr : 'a tag -> Pp.std_ppcmds end (** Dynamic types for toplevel values. While the generic types permit to relate diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 4c74984f83..6f0297268d 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -65,7 +65,7 @@ let val_tag wit = val_tag (topwit wit) let pr_argument_type arg = let Val.Dyn (tag, _) = arg in - Val.repr tag + Val.pr tag let safe_msgnl s = Proofview.NonLogical.catch @@ -83,9 +83,9 @@ let push_appl appl args = match appl with | UnnamedAppl -> UnnamedAppl | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) -let pr_generic arg = (** FIXME *) +let pr_generic arg = let Val.Dyn (tag, _) = arg in - str"<" ++ Val.repr tag ++ str ">" + str"<" ++ Val.pr tag ++ str ":(" ++ Pptactic.pr_value Pptactic.ltop arg ++ str ")>" let pr_appl h vs = Pptactic.pr_ltac_constant h ++ spc () ++ Pp.prlist_with_sep spc pr_generic vs @@ -148,9 +148,9 @@ module Value = struct of_tacvalue closure let cast_error wit v = - let pr_v = mt () in (** FIXME *) + let pr_v = Pptactic.pr_value Pptactic.ltop v in let Val.Dyn (tag, _) = v in - let tag = Val.repr tag in + let tag = Val.pr tag in errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ tag ++ str " while type " ++ Genarg.pr_argument_type (unquote (rawwit wit)) ++ str " was expected.") @@ -198,7 +198,7 @@ module Value = struct end -let print_top_val env v = mt () (** FIXME *) +let print_top_val env v = Pptactic.pr_value Pptactic.ltop v let dloc = Loc.ghost diff --git a/printing/pptactic.ml b/printing/pptactic.ml index c175b206db..355a6a7d64 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -106,7 +106,23 @@ module Make let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) - let pr_value _ _ = str "(* FIXME *)" + let rec pr_value lev (Val.Dyn (tag, x)) : std_ppcmds = match tag with + | Val.List tag -> + pr_sequence (fun x -> pr_value lev (Val.Dyn (tag, x))) x + | Val.Opt tag -> pr_opt (fun x -> pr_value lev (Val.Dyn (tag, x))) x + | Val.Pair (tag1, tag2) -> + str "(" ++ pr_value lev (Val.Dyn (tag1, fst x)) ++ str ", " ++ + pr_value lev (Val.Dyn (tag1, fst x)) ++ str ")" + | Val.Base t -> + let name = Val.repr t in + let default = str "<" ++ str name ++ str ">" in + match ArgT.name name with + | None -> default + | Some (ArgT.Any arg) -> + let wit = ExtraArg arg in + match Val.eq (val_tag (Topwit wit)) (Val.Base t) with + | None -> default + | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x) let pr_with_occurrences pr (occs,c) = match occs with @@ -1245,7 +1261,7 @@ module Make let typed_printers = (strip_prod_binders_constr) in - let prtac n (t:tactic_expr) = + let rec prtac n (t:tactic_expr) = let pr = { pr_tactic = pr_glob_tactic_level env; pr_constr = pr_constr_env env Evd.empty; @@ -1261,10 +1277,10 @@ module Make pr_value pr_constr_pattern; pr_extend = pr_extend_rec (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - pr_value pr_constr_pattern; + prtac pr_constr_pattern; pr_alias = pr_alias (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - pr_value pr_constr_pattern; + prtac pr_constr_pattern; } in make_pr_tac diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index b98b6c67e7..95cf541fd7 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -72,4 +72,6 @@ module type Pp = sig val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('b, 'a) match_rule -> std_ppcmds + val pr_value : tolerability -> Val.t -> std_ppcmds + end -- cgit v1.2.3 From 17c9a9775e99d1551bf6d346d731271e3ae34417 Mon Sep 17 00:00:00 2001 From: Daniel de Rauglaudre Date: Fri, 8 Apr 2016 14:53:32 +0200 Subject: Fixing a source of inefficiency and an artificial dependency in the printer in the congruence tactic. Debugging messages were always built even when not in the verbose mode of congruence. --- plugins/cc/ccalgo.ml | 28 ++++++++++++++-------------- plugins/cc/ccalgo.mli | 2 +- plugins/cc/ccproof.ml | 12 ++++++------ plugins/cc/cctac.ml | 8 ++++---- 4 files changed, 25 insertions(+), 25 deletions(-) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index bc3d9ed560..5d16edfc6a 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -25,7 +25,7 @@ let init_size=5 let cc_verbose=ref false let debug x = - if !cc_verbose then msg_debug x + if !cc_verbose then msg_debug (x ()) let _= let gdopt= @@ -603,7 +603,7 @@ let add_inst state (inst,int_subst) = Control.check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then - debug (str "discarding redundant (dis)equality") + debug (fun () -> str "discarding redundant (dis)equality") else begin Identhash.add state.q_history inst.qe_hyp_id int_subst; @@ -618,7 +618,7 @@ let add_inst state (inst,int_subst) = state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin - debug ( + debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")); @@ -626,7 +626,7 @@ let add_inst state (inst,int_subst) = end else begin - debug ( + debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")); @@ -657,7 +657,7 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (str "Linking " ++ pr_idx_term state.uf i1 ++ + debug (fun () -> str "Linking " ++ pr_idx_term state.uf i1 ++ str " and " ++ pr_idx_term state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in @@ -698,7 +698,7 @@ let union state i1 i2 eq= let merge eq state = (* merge and no-merge *) debug - (str "Merging " ++ pr_idx_term state.uf eq.lhs ++ + (fun () -> str "Merging " ++ pr_idx_term state.uf eq.lhs ++ str " and " ++ pr_idx_term state.uf eq.rhs ++ str "."); let uf=state.uf in let i=find uf eq.lhs @@ -711,7 +711,7 @@ let merge eq state = (* merge and no-merge *) let update t state = (* update 1 and 2 *) debug - (str "Updating term " ++ pr_idx_term state.uf t ++ str "."); + (fun () -> str "Updating term " ++ pr_idx_term state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in let rep = get_representative state.uf i in @@ -773,7 +773,7 @@ let process_constructor_mark t i rep pac state = let process_mark t m state = debug - (str "Processing mark for term " ++ pr_idx_term state.uf t ++ str "."); + (fun () -> str "Processing mark for term " ++ pr_idx_term state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in match m with @@ -794,7 +794,7 @@ let check_disequalities state = else (str "No", check_aux q) in let _ = debug - (str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++ + (fun () -> str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++ pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in ans | [] -> None @@ -979,7 +979,7 @@ let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = - debug (str "Running E-matching algorithm ... "); + debug (fun () -> str "Running E-matching algorithm ... "); try while true do Control.check_for_interrupt (); @@ -990,7 +990,7 @@ let find_instances state = !res let rec execute first_run state = - debug (str "Executing ... "); + debug (fun () -> str "Executing ... "); try while Control.check_for_interrupt (); @@ -1000,7 +1000,7 @@ let rec execute first_run state = None -> if not(Int.Set.is_empty state.pa_classes) then begin - debug (str "First run was incomplete, completing ... "); + debug (fun () -> str "First run was incomplete, completing ... "); complete state; execute false state end @@ -1015,12 +1015,12 @@ let rec execute first_run state = end else begin - debug (str "Out of instances ... "); + debug (fun () -> str "Out of instances ... "); None end else begin - debug (str "Out of depth ... "); + debug (fun () -> str "Out of depth ... "); None end | Some dis -> Some diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index b73c8eef86..c7fa2f56fd 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -120,7 +120,7 @@ val term_equal : term -> term -> bool val constr_of_term : term -> constr -val debug : Pp.std_ppcmds -> unit +val debug : (unit -> Pp.std_ppcmds) -> unit val forest : state -> forest diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index c188bf3bc9..d2bbaf6a7d 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -93,13 +93,13 @@ let pinject p c n a = p_rule=Inject(p,c,n,a)} let rec equal_proof uf i j= - debug (str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + debug (fun () -> str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof uf i li) (psym (path_proof uf j lj)) and edge_proof uf ((i,j),eq)= - debug (str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + debug (fun () -> str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); let pi=equal_proof uf i eq.lhs in let pj=psym (equal_proof uf j eq.rhs) in let pij= @@ -115,7 +115,7 @@ and edge_proof uf ((i,j),eq)= ptrans (ptrans pi pij) pj and constr_proof uf i ipac= - debug (str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20)); + debug (fun () -> str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in let eq_it=equal_proof uf i t in if ipac.args=[] then @@ -128,20 +128,20 @@ and constr_proof uf i ipac= ptrans eq_it (pcongr p (prefl targ)) and path_proof uf i l= - debug (str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++ + debug (fun () -> str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) | x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x) and congr_proof uf i j= - debug (str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + debug (fun () -> str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2) and ind_proof uf i ipac j jpac= - debug (str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); + debug (fun () -> str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); let p=equal_proof uf i j and p1=constr_proof uf i ipac and p2=constr_proof uf j jpac in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 0baa533704..df4a7319ac 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -413,16 +413,16 @@ let build_term_to_complete uf meta pac = let cc_tactic depth additionnal_terms = Proofview.Goal.nf_enter begin fun gl -> Coqlib.check_required_library Coqlib.logic_module_name; - let _ = debug (Pp.str "Reading subgoal ...") in + let _ = debug (fun () -> Pp.str "Reading subgoal ...") in let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in - let _ = debug (Pp.str "Problem built, solving ...") in + let _ = debug (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in - let _ = debug (Pp.str "Computation completed.") in + let _ = debug (fun () -> Pp.str "Computation completed.") in let uf=forest state in match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (Pp.str "Goal solved, generating proof ..."); + debug (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> let p=build_proof uf (`Discr (i,ipac,j,jpac)) in -- cgit v1.2.3 From 84f079fa31723b6a97edc50ca7a81e1eb19e759c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 7 Apr 2016 20:31:42 +0200 Subject: Added compatibility coercions from Specif.v which were present in Coq 8.4. --- theories/Compat/Coq84.v | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index d99d50996a..5c60966f28 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -76,3 +76,11 @@ End Coq. (** Many things now import [PeanoNat] rather than [NPeano], so we require it so that the old absolute names in [NPeano.Nat] are available. *) Require Coq.Numbers.Natural.Peano.NPeano. + +(** The following coercions were declared by default in Specif.v. *) +Coercion sig_of_sig2 : sig2 >-> sig. +Coercion sigT_of_sigT2 : sigT2 >-> sigT. +Coercion sigT_of_sig : sig >-> sigT. +Coercion sig_of_sigT : sigT >-> sig. +Coercion sigT2_of_sig2 : sig2 >-> sigT2. +Coercion sig2_of_sigT2 : sigT2 >-> sig2. -- cgit v1.2.3 From ce71ac17268f11ddd92f4bea85cbdd9c62acbc21 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 11:56:53 +0200 Subject: In pr_clauses, do not print a leading space by default so that it can be used in the generic printer for tactics. Allows e.g. to print "symmetry in H" correctly after its move to TACTIC EXTEND. --- lib/pp.ml | 1 + lib/pp.mli | 3 +++ printing/pptactic.ml | 16 ++++++++-------- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/lib/pp.ml b/lib/pp.ml index 9a833ae225..c7cf9b8d0e 100644 --- a/lib/pp.ml +++ b/lib/pp.ml @@ -518,6 +518,7 @@ let pr_comma () = str "," ++ spc () let pr_semicolon () = str ";" ++ spc () let pr_bar () = str "|" ++ spc () let pr_arg pr x = spc () ++ pr x +let pr_non_empty_arg pr x = let pp = pr x in if ismt pp then mt () else spc () ++ pr x let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x diff --git a/lib/pp.mli b/lib/pp.mli index 015151bc90..2e4d029749 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -199,6 +199,9 @@ val pr_bar : unit -> std_ppcmds val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds (** Adds a space in front of its argument. *) +val pr_non_empty_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds +(** Adds a space in front of its argument if non empty. *) + val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds (** Inner object preceded with a space if [Some], nothing otherwise. *) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 355a6a7d64..7dae97acf2 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -542,7 +542,7 @@ module Make str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" ) occs - let pr_in pp = spc () ++ hov 0 (keyword "in" ++ pp) + let pr_in pp = hov 0 (keyword "in" ++ pp) let pr_simple_hyp_clause pr_id = function | [] -> mt () @@ -829,7 +829,7 @@ module Make (if a then mt() else primitive "simple ") ++ primitive (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - pr_in_hyp_as pr.pr_dconstr pr.pr_name inhyp + pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp ) | TacElim (ev,cb,cbo) -> hov 1 ( @@ -873,7 +873,7 @@ module Make (if b then pr_pose pr.pr_constr pr.pr_lconstr na c else pr_pose_as_style pr.pr_constr na c) ++ pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ - pr_clauses (Some b) pr.pr_name cl) + pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) (* | TacInstantiate (n,c,ConclLocation ()) -> hov 1 (str "instantiate" ++ spc() ++ hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ @@ -918,7 +918,7 @@ module Make | TacReduce (r,h) -> hov 1 ( pr_red_expr r - ++ pr_clauses (Some true) pr.pr_name h + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) | TacChange (op,c,h) -> hov 1 ( @@ -930,7 +930,7 @@ module Make | Some p -> pr.pr_pattern p ++ spc () ++ keyword "with" ++ spc () - ) ++ pr.pr_dconstr c ++ pr_clauses (Some true) pr.pr_name h + ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) (* Equality and inversion *) @@ -943,7 +943,7 @@ module Make pr_orient b ++ pr_multi m ++ pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) l - ++ pr_clauses (Some true) pr.pr_name cl + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl ++ ( match by with | Some by -> pr_by_tactic (pr.pr_tactic ltop) by @@ -962,14 +962,14 @@ module Make pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ pr_with_inversion_names pr.pr_dconstr ids - ++ pr_simple_hyp_clause pr.pr_name cl + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) | TacInversion (InversionUsing (c,cl),hyp) -> hov 1 ( primitive "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ spc () ++ keyword "using" ++ spc () ++ pr.pr_constr c - ++ pr_simple_hyp_clause pr.pr_name cl + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) ) in -- cgit v1.2.3 From b5cc4ac65764b0866bf57caa6f9aa7fa631eabf1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 16:14:29 +0200 Subject: Fixing extra space in printing inductive types with no explicit type given. --- printing/ppvernac.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 55f8f909f0..0b761881dc 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -778,8 +778,8 @@ module Make hov 0 ( str key ++ spc() ++ (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++ - pr_and_type_binders_arg indpar ++ spc() ++ - Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ + pr_and_type_binders_arg indpar ++ + pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++ str" :=") ++ pr_constructor_list k lc ++ prlist (pr_decl_notation pr_constr) ntn in -- cgit v1.2.3 From fa2fa0b2e6ca0fbfb9a9278af211d4ef533b6791 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 16:15:15 +0200 Subject: Simplifying code for printing VERNAC EXTEND. --- printing/ppvernac.ml | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 0b761881dc..9054ba0b67 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -1213,22 +1213,15 @@ module Make with Failure _ -> str "" in try let rl = Egramml.get_extend_vernac_rule s in - let start,rl,cl = - match rl with - | Egramml.GramTerminal s :: rl -> str s, rl, cl - | Egramml.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl - | [] -> anomaly (Pp.str "Empty entry") in - let (pp,_) = - List.fold_left - (fun (strm,args) pi -> - let pp,args = match pi with - | Egramml.GramNonTerminal _ -> (pr_arg (List.hd args), List.tl args) - | Egramml.GramTerminal s -> (str s, args) in - (strm ++ spc() ++ pp), args) - (start,cl) rl in - hov 1 pp + let rec aux rl cl = + match rl, cl with + | Egramml.GramNonTerminal _ :: rl, arg :: cl -> pr_arg arg :: aux rl cl + | Egramml.GramTerminal s :: rl, cl -> str s :: aux rl cl + | [], [] -> [] + | _ -> assert false in + hov 1 (pr_sequence (fun x -> x) (aux rl cl)) with Not_found -> - hov 1 (str "TODO(" ++ str (fst s) ++ prlist_with_sep sep pr_arg cl ++ str ")") + hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")") in pr_vernac -- cgit v1.2.3 From 41af4c3e36af15d9cc235cb5effedeed40478d2e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 16:30:48 +0200 Subject: Re-add printer for tacdef_body so that Ltac definitions are printed by pr_vernac. --- ltac/g_ltac.ml4 | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index b55ac9ad06..c264b19063 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -413,7 +413,26 @@ VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY [ msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] END +let pr_ltac_ref = Libnames.pr_reference + +let pr_tacdef_body tacdef_body = + let id, redef, body = + match tacdef_body with + | TacticDefinition ((_,id), body) -> Nameops.pr_id id, false, body + | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body + in + let idl, body = + match body with + | Tacexpr.TacFun (idl,b) -> idl,b + | _ -> [], body in + id ++ + prlist (function None -> str " _" + | Some id -> spc () ++ Nameops.pr_id id) idl + ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) + ++ Pptactic.pr_raw_tactic body + VERNAC ARGUMENT EXTEND ltac_tacdef_body +PRINTED BY pr_tacdef_body | [ tacdef_body(t) ] -> [ t ] END -- cgit v1.2.3 From a2664de27eabbba7fc357305679112aef99e1f74 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 16:39:55 +0200 Subject: Removing automatic printing of leading space in auto_using and hintbases so that it does not put extra space when auto is defined as a TACTIC EXTEND. --- printing/pptactic.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 7dae97acf2..7d7ebd1416 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -675,15 +675,13 @@ module Make str " ]") let pr_hintbases = function - | None -> spc () ++ keyword "with" ++ str" *" + | None -> keyword "with" ++ str" *" | Some [] -> mt () - | Some l -> - spc () ++ hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l) + | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l) let pr_auto_using prc = function | [] -> mt () - | l -> spc () ++ - hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) + | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) let pr_then () = str ";" -- cgit v1.2.3 From a2d3f5fc3167962f9bf549ba32f0105fff766422 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 17:10:10 +0200 Subject: Removing extra spaces in printing arguments of VERNAC EXTEND. --- ltac/g_ltac.ml4 | 3 ++- printing/pptactic.ml | 21 +++++++++++---------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index c264b19063..56f32196b6 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -354,7 +354,8 @@ VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info | [ "Info" natural(n) ] -> [ n ] END -let pr_ltac_use_default b = if b then str ".." else mt () +let pr_ltac_use_default b = + if b then (* Bug: a space is inserted before "..." *) str ".." else mt () VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default | [ "." ] -> [ false ] diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 7d7ebd1416..4b2dc49a5e 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -109,7 +109,7 @@ module Make let rec pr_value lev (Val.Dyn (tag, x)) : std_ppcmds = match tag with | Val.List tag -> pr_sequence (fun x -> pr_value lev (Val.Dyn (tag, x))) x - | Val.Opt tag -> pr_opt (fun x -> pr_value lev (Val.Dyn (tag, x))) x + | Val.Opt tag -> pr_opt_no_spc (fun x -> pr_value lev (Val.Dyn (tag, x))) x | Val.Pair (tag1, tag2) -> str "(" ++ pr_value lev (Val.Dyn (tag1, fst x)) ++ str ", " ++ pr_value lev (Val.Dyn (tag1, fst x)) ++ str ")" @@ -282,24 +282,25 @@ module Make let with_evars ev s = if ev then "e" ^ s else s + let hov_if_not_empty n p = if Pp.ismt p then p else hov n p let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) = match wit with | ListArg wit -> let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in let ans = pr_sequence map x in - hov 0 ans + hov_if_not_empty 0 ans | OptArg wit -> let ans = match x with | None -> mt () | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in - hov 0 ans + hov_if_not_empty 0 ans | PairArg (wit1, wit2) -> let p, q = x in let p = in_gen (rawwit wit1) p in let q = in_gen (rawwit wit2) q in - hov 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q]) + hov_if_not_empty 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q]) | ExtraArg s -> try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x) with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x) @@ -310,19 +311,19 @@ module Make | ListArg wit -> let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in let ans = pr_sequence map x in - hov 0 ans + hov_if_not_empty 0 ans | OptArg wit -> let ans = match x with | None -> mt () | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in - hov 0 ans + hov_if_not_empty 0 ans | PairArg (wit1, wit2) -> let p, q = x in let p = in_gen (glbwit wit1) p in let q = in_gen (glbwit wit2) q in let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in - hov 0 ans + hov_if_not_empty 0 ans | ExtraArg s -> try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x) with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) x) @@ -332,19 +333,19 @@ module Make | ListArg wit -> let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in let ans = pr_sequence map x in - hov 0 ans + hov_if_not_empty 0 ans | OptArg wit -> let ans = match x with | None -> mt () | Some x -> pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in - hov 0 ans + hov_if_not_empty 0 ans | PairArg (wit1, wit2) -> let p, q = x in let p = in_gen (topwit wit1) p in let q = in_gen (topwit wit2) q in let ans = pr_sequence (pr_top_generic_rec prc prlc prtac prpat) [p; q] in - hov 0 ans + hov_if_not_empty 0 ans | ExtraArg s -> try pi3 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (topwit wit) x) with Not_found -> Genprint.generic_top_print (in_gen (topwit wit) x) -- cgit v1.2.3 From f8f2c684ce97745350f8cbcb654a2ee27fb9d572 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 18:18:46 +0200 Subject: A small test of Print Ltac. --- test-suite/output/ltac.out | 3 +++ test-suite/output/ltac.v | 10 ++++++++++ 2 files changed, 13 insertions(+) diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index d003c70df9..20e274e254 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,2 +1,5 @@ The command has indeed failed with message: Error: Ltac variable y depends on pattern variable name z which is not bound in current context. +Ltac f x y z := + symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize + dependent z diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 7e2610c7d7..373b870b9f 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -15,3 +15,13 @@ lazymatch goal with | H1 : HT |- _ => idtac end. Abort. + +Ltac f x y z := + symmetry in x, y; + auto with z; + auto; + intros; + clearbody x; + generalize dependent z. + +Print Ltac f. -- cgit v1.2.3 From c6a8c4b5fa590f2beecd73817497bd7773a87522 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 10 Apr 2016 01:27:44 +0200 Subject: Expliciting the fact that the atomic tactic type is self-contained. --- intf/tacexpr.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 0aa3b936ca..f821251c27 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -191,7 +191,7 @@ constraint 'a = < (** Possible arguments of a tactic definition *) -and 'a gen_tactic_arg = +type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref -- cgit v1.2.3 From 4ebc7c27f04f2bcc3cf7160ae9ec177d1ca11707 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 10 Apr 2016 02:24:17 +0200 Subject: Extruding the print_atom primitive. --- printing/pptactic.ml | 469 +++++++++++++++++++++++++-------------------------- 1 file changed, 234 insertions(+), 235 deletions(-) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 4b2dc49a5e..1e6c46e759 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -732,247 +732,246 @@ module Make level :'lev > - let make_pr_tac pr strip_prod_binders tag_atom tag = - - (* some shortcuts *) - let _pr_bindings = pr_bindings pr.pr_constr pr.pr_lconstr in - let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in - let pr_with_bindings_arg_full = pr_with_bindings_arg in - let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in - let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in - - let pr_constrarg c = spc () ++ pr.pr_constr c in - let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in - let pr_intarg n = spc () ++ int n in - - (* Some printing combinators *) - let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in + let rec pr_atom pr strip_prod_binders tag_atom = + let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in + let pr_with_bindings_arg_full = pr_with_bindings_arg in + let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in + let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in + + let pr_constrarg c = spc () ++ pr.pr_constr c in + let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in + let pr_intarg n = spc () ++ int n in + + (* Some printing combinators *) + let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in + + let pr_binder_fix (nal,t) = + (* match t with + | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal + | _ ->*) + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + spc() ++ hov 1 (str"(" ++ s ++ str")") in + + let pr_fix_tac (id,n,c) = + let rec set_nth_name avoid n = function + (nal,ty)::bll -> + if n <= List.length nal then + match List.chop (n-1) nal with + _, (_,Name id) :: _ -> id, (nal,ty)::bll + | bef, (loc,Anonymous) :: aft -> + let id = next_ident_away (Id.of_string"y") avoid in + id, ((bef@(loc,Name id)::aft, ty)::bll) + | _ -> assert false + else + let (id,bll') = set_nth_name avoid (n-List.length nal) bll in + (id,(nal,ty)::bll') + | [] -> assert false in + let (bll,ty) = strip_prod_binders n c in + let names = + List.fold_left + (fun ln (nal,_) -> List.fold_left + (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) + ln nal) + [] bll in + let idarg,bll = set_nth_name names n bll in + let annot = match names with + | [_] -> + mt () + | _ -> + spc() ++ str"{" + ++ keyword "struct" ++ spc () + ++ pr_id idarg ++ str"}" + in + hov 1 (str"(" ++ pr_id id ++ + prlist pr_binder_fix bll ++ annot ++ str" :" ++ + pr_lconstrarg ty ++ str")") in + (* spc() ++ + hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg + c) + *) + let pr_cofix_tac (id,c) = + hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in + + (* Printing tactics as arguments *) + let rec pr_atom0 a = tag_atom a (match a with + | TacIntroPattern [] -> primitive "intros" + | TacIntroMove (None,MoveLast) -> primitive "intro" + | t -> str "(" ++ pr_atom1 t ++ str ")" + ) + + (* Main tactic printer *) + and pr_atom1 a = tag_atom a (match a with + (* Basic tactics *) + | TacIntroPattern [] as t -> + pr_atom0 t + | TacIntroPattern (_::_ as p) -> + hov 1 (primitive "intros" ++ spc () ++ + prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) + | TacIntroMove (None,MoveLast) as t -> + pr_atom0 t + | TacIntroMove (Some id,MoveLast) -> + primitive "intro" ++ spc () ++ pr_id id + | TacIntroMove (ido,hto) -> + hov 1 (primitive "intro" ++ pr_opt pr_id ido ++ + Miscprint.pr_move_location pr.pr_name hto) + | TacExact c -> + hov 1 (primitive "exact" ++ pr_constrarg c) + | TacApply (a,ev,cb,inhyp) -> + hov 1 ( + (if a then mt() else primitive "simple ") ++ + primitive (with_evars ev "apply") ++ spc () ++ + prlist_with_sep pr_comma pr_with_bindings_arg cb ++ + pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp + ) + | TacElim (ev,cb,cbo) -> + hov 1 ( + primitive (with_evars ev "elim") + ++ pr_arg pr_with_bindings_arg cb + ++ pr_opt pr_eliminator cbo) + | TacCase (ev,cb) -> + hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb) + | TacMutualFix (id,n,l) -> + hov 1 ( + primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() + ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l) + | TacMutualCofix (id,l) -> + hov 1 ( + primitive "cofix" ++ spc () ++ pr_id id ++ spc() + ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l + ) + | TacAssert (b,Some tac,ipat,c) -> + hov 1 ( + primitive (if b then "assert" else "enough") ++ + pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ + pr_by_tactic (pr.pr_tactic ltop) tac + ) + | TacAssert (_,None,ipat,c) -> + hov 1 ( + primitive "pose proof" + ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c + ) + | TacGeneralize l -> + hov 1 ( + primitive "generalize" ++ spc () + ++ prlist_with_sep pr_comma (fun (cl,na) -> + pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) + l + ) + | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> + hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + | TacLetTac (na,c,cl,b,e) -> + hov 1 ( + (if b then primitive "set" else primitive "remember") ++ + (if b then pr_pose pr.pr_constr pr.pr_lconstr na c + else pr_pose_as_style pr.pr_constr na c) ++ + pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ + pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) + (* | TacInstantiate (n,c,ConclLocation ()) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg c ++ str ")" )) + | TacInstantiate (n,c,HypLocation (id,hloc)) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg c ++ str ")" ) + ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None))) + *) - let extract_binders = function - | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) - | body -> ([],body) in + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + hov 1 ( + primitive (with_evars ev (if isrec then "induction" else "destruct")) + ++ spc () + ++ prlist_with_sep pr_comma (fun ((clear_flag,h),ids,cl) -> + pr_clear_flag clear_flag (pr_induction_arg pr.pr_dconstr pr.pr_dconstr) h ++ + pr_with_induction_names pr.pr_dconstr ids ++ + pr_opt_no_spc (pr_clauses None pr.pr_name) cl) l ++ + pr_opt pr_eliminator el + ) + | TacDoubleInduction (h1,h2) -> + hov 1 ( + primitive "double induction" + ++ pr_arg pr_quantified_hypothesis h1 + ++ pr_arg pr_quantified_hypothesis h2 + ) - let pr_binder_fix (nal,t) = - (* match t with - | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal - | _ ->*) - let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in - spc() ++ hov 1 (str"(" ++ s ++ str")") in - - let pr_fix_tac (id,n,c) = - let rec set_nth_name avoid n = function - (nal,ty)::bll -> - if n <= List.length nal then - match List.chop (n-1) nal with - _, (_,Name id) :: _ -> id, (nal,ty)::bll - | bef, (loc,Anonymous) :: aft -> - let id = next_ident_away (Id.of_string"y") avoid in - id, ((bef@(loc,Name id)::aft, ty)::bll) - | _ -> assert false - else - let (id,bll') = set_nth_name avoid (n-List.length nal) bll in - (id,(nal,ty)::bll') - | [] -> assert false in - let (bll,ty) = strip_prod_binders n c in - let names = - List.fold_left - (fun ln (nal,_) -> List.fold_left - (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) - ln nal) - [] bll in - let idarg,bll = set_nth_name names n bll in - let annot = match names with - | [_] -> - mt () - | _ -> - spc() ++ str"{" - ++ keyword "struct" ++ spc () - ++ pr_id idarg ++ str"}" - in - hov 1 (str"(" ++ pr_id id ++ - prlist pr_binder_fix bll ++ annot ++ str" :" ++ - pr_lconstrarg ty ++ str")") in - (* spc() ++ - hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg - c) - *) - let pr_cofix_tac (id,c) = - hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in - - (* Printing tactics as arguments *) - let rec pr_atom0 a = tag_atom a (match a with - | TacIntroPattern [] -> primitive "intros" - | TacIntroMove (None,MoveLast) -> primitive "intro" - | t -> str "(" ++ pr_atom1 t ++ str ")" - ) - - (* Main tactic printer *) - and pr_atom1 a = tag_atom a (match a with - (* Basic tactics *) - | TacIntroPattern [] as t -> - pr_atom0 t - | TacIntroPattern (_::_ as p) -> - hov 1 (primitive "intros" ++ spc () ++ - prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) - | TacIntroMove (None,MoveLast) as t -> - pr_atom0 t - | TacIntroMove (Some id,MoveLast) -> - primitive "intro" ++ spc () ++ pr_id id - | TacIntroMove (ido,hto) -> - hov 1 (primitive "intro" ++ pr_opt pr_id ido ++ - Miscprint.pr_move_location pr.pr_name hto) - | TacExact c -> - hov 1 (primitive "exact" ++ pr_constrarg c) - | TacApply (a,ev,cb,inhyp) -> - hov 1 ( - (if a then mt() else primitive "simple ") ++ - primitive (with_evars ev "apply") ++ spc () ++ - prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp - ) - | TacElim (ev,cb,cbo) -> - hov 1 ( - primitive (with_evars ev "elim") - ++ pr_arg pr_with_bindings_arg cb - ++ pr_opt pr_eliminator cbo) - | TacCase (ev,cb) -> - hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb) - | TacMutualFix (id,n,l) -> - hov 1 ( - primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() - ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l) - | TacMutualCofix (id,l) -> - hov 1 ( - primitive "cofix" ++ spc () ++ pr_id id ++ spc() - ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l - ) - | TacAssert (b,Some tac,ipat,c) -> - hov 1 ( - primitive (if b then "assert" else "enough") ++ - pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ - pr_by_tactic (pr.pr_tactic ltop) tac - ) - | TacAssert (_,None,ipat,c) -> - hov 1 ( - primitive "pose proof" - ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c - ) - | TacGeneralize l -> - hov 1 ( - primitive "generalize" ++ spc () - ++ prlist_with_sep pr_comma (fun (cl,na) -> - pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) - l - ) - | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> - hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) - | TacLetTac (na,c,cl,b,e) -> - hov 1 ( - (if b then primitive "set" else primitive "remember") ++ - (if b then pr_pose pr.pr_constr pr.pr_lconstr na c - else pr_pose_as_style pr.pr_constr na c) ++ - pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ - pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) - (* | TacInstantiate (n,c,ConclLocation ()) -> - hov 1 (str "instantiate" ++ spc() ++ - hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ - pr_lconstrarg c ++ str ")" )) - | TacInstantiate (n,c,HypLocation (id,hloc)) -> - hov 1 (str "instantiate" ++ spc() ++ - hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ - pr_lconstrarg c ++ str ")" ) - ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None))) - *) - - (* Derived basic tactics *) - | TacInductionDestruct (isrec,ev,(l,el)) -> - hov 1 ( - primitive (with_evars ev (if isrec then "induction" else "destruct")) - ++ spc () - ++ prlist_with_sep pr_comma (fun ((clear_flag,h),ids,cl) -> - pr_clear_flag clear_flag (pr_induction_arg pr.pr_dconstr pr.pr_dconstr) h ++ - pr_with_induction_names pr.pr_dconstr ids ++ - pr_opt_no_spc (pr_clauses None pr.pr_name) cl) l ++ - pr_opt pr_eliminator el - ) - | TacDoubleInduction (h1,h2) -> - hov 1 ( - primitive "double induction" - ++ pr_arg pr_quantified_hypothesis h1 - ++ pr_arg pr_quantified_hypothesis h2 - ) + (* Context management *) + | TacRename l -> + hov 1 ( + primitive "rename" ++ brk (1,1) + ++ prlist_with_sep + (fun () -> str "," ++ brk (1,1)) + (fun (i1,i2) -> + pr.pr_name i1 ++ spc () ++ str "into" ++ spc () ++ pr.pr_name i2) + l + ) - (* Context management *) - | TacRename l -> - hov 1 ( - primitive "rename" ++ brk (1,1) - ++ prlist_with_sep - (fun () -> str "," ++ brk (1,1)) - (fun (i1,i2) -> - pr.pr_name i1 ++ spc () ++ str "into" ++ spc () ++ pr.pr_name i2) - l - ) + (* Conversion *) + | TacReduce (r,h) -> + hov 1 ( + pr_red_expr r + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) + | TacChange (op,c,h) -> + hov 1 ( + primitive "change" ++ brk (1,1) + ++ ( + match op with + None -> + mt () + | Some p -> + pr.pr_pattern p ++ spc () + ++ keyword "with" ++ spc () + ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) - (* Conversion *) - | TacReduce (r,h) -> - hov 1 ( - pr_red_expr r - ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h - ) - | TacChange (op,c,h) -> - hov 1 ( - primitive "change" ++ brk (1,1) - ++ ( - match op with - None -> - mt () - | Some p -> - pr.pr_pattern p ++ spc () - ++ keyword "with" ++ spc () - ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + hov 1 ( + primitive (with_evars ev "rewrite") ++ spc () + ++ prlist_with_sep + (fun () -> str ","++spc()) + (fun (b,m,c) -> + pr_orient b ++ pr_multi m ++ + pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) + l + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl + ++ ( + match by with + | Some by -> pr_by_tactic (pr.pr_tactic ltop) by + | None -> mt() ) + ) + | TacInversion (DepInversion (k,c,ids),hyp) -> + hov 1 ( + primitive "dependent " ++ pr_induction_kind k ++ spc () + ++ pr_quantified_hypothesis hyp + ++ pr_with_inversion_names pr.pr_dconstr ids + ++ pr_with_constr pr.pr_constr c + ) + | TacInversion (NonDepInversion (k,cl,ids),hyp) -> + hov 1 ( + pr_induction_kind k ++ spc () + ++ pr_quantified_hypothesis hyp + ++ pr_with_inversion_names pr.pr_dconstr ids + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl + ) + | TacInversion (InversionUsing (c,cl),hyp) -> + hov 1 ( + primitive "inversion" ++ spc() + ++ pr_quantified_hypothesis hyp ++ spc () + ++ keyword "using" ++ spc () ++ pr.pr_constr c + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl + ) + ) + in + pr_atom1 - (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - hov 1 ( - primitive (with_evars ev "rewrite") ++ spc () - ++ prlist_with_sep - (fun () -> str ","++spc()) - (fun (b,m,c) -> - pr_orient b ++ pr_multi m ++ - pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) - l - ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl - ++ ( - match by with - | Some by -> pr_by_tactic (pr.pr_tactic ltop) by - | None -> mt() - ) - ) - | TacInversion (DepInversion (k,c,ids),hyp) -> - hov 1 ( - primitive "dependent " ++ pr_induction_kind k ++ spc () - ++ pr_quantified_hypothesis hyp - ++ pr_with_inversion_names pr.pr_dconstr ids - ++ pr_with_constr pr.pr_constr c - ) - | TacInversion (NonDepInversion (k,cl,ids),hyp) -> - hov 1 ( - pr_induction_kind k ++ spc () - ++ pr_quantified_hypothesis hyp - ++ pr_with_inversion_names pr.pr_dconstr ids - ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl - ) - | TacInversion (InversionUsing (c,cl),hyp) -> - hov 1 ( - primitive "inversion" ++ spc() - ++ pr_quantified_hypothesis hyp ++ spc () - ++ keyword "using" ++ spc () ++ pr.pr_constr c - ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl - ) - ) - in + let make_pr_tac pr strip_prod_binders tag_atom tag = + let extract_binders = function + | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) + | body -> ([],body) in let rec pr_tac inherited tac = let return (doc, l) = (tag tac doc, l) in let (strm, prec) = return (match tac with @@ -1130,7 +1129,7 @@ module Make | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom | TacAtom (loc,t) -> - pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom + pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom | TacArg(_,Tacexp e) -> pr.pr_tactic (latom,E) e, latom | TacArg(_,ConstrMayEval (ConstrTerm c)) -> -- cgit v1.2.3 From 2da7bf6327e1f35321f121de9560604b758f0472 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 10 Apr 2016 02:37:41 +0200 Subject: Removing the ad-hoc tactic_expr type. This type was actually only used by the debug printer of tactics, and only for atomic tactics. Furthermore, that type was asymmetric, as the underlying tacexpr type was set to be glob_tactic, when the semantics would have required a Val.t type. Furthermore, this type is absent from every contrib I have seen, which hints again in favour of its lack of meaning. --- intf/tacexpr.mli | 8 +------- ltac/tacinterp.ml | 6 +++--- printing/ppannotation.ml | 2 -- printing/ppannotation.mli | 1 - printing/pptactic.ml | 44 ++++++++++++-------------------------------- printing/pptacticsig.mli | 2 +- printing/richprinter.ml | 1 - printing/richprinter.mli | 3 --- 8 files changed, 17 insertions(+), 50 deletions(-) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index f821251c27..875ad3d160 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -377,19 +377,13 @@ type t_dispatch = < constant:t_cst; reference:t_ref; name:t_nam; - tacexpr:glob_tactic_expr; + tacexpr:unit; level:tlevel > -type tactic_expr = - t_dispatch gen_tactic_expr - type atomic_tactic_expr = t_dispatch gen_atomic_tactic_expr -type tactic_arg = - t_dispatch gen_tactic_arg - (** Misc *) type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 6f0297268d..02b03b72c2 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -1650,7 +1650,7 @@ and name_atomic ?env tacexpr tac : unit Proofview.tactic = | Some e -> Proofview.tclUNIT e | None -> Proofview.tclENV end >>= fun env -> - let name () = Pptactic.pr_tactic env (TacAtom (Loc.ghost,tacexpr)) in + let name () = Pptactic.pr_atomic_tactic env tacexpr in Proofview.Trace.name_tactic name tac (* Interprets a primitive tactic *) @@ -1769,7 +1769,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let tac = Option.map (interp_tactic ist) t in Tacticals.New.tclWITHHOLES false (name_atomic ~env - (TacAssert(b,t,ipat,c)) + (TacAssert(b,Option.map ignore t,ipat,c)) (Tactics.forward b tac ipat' c)) sigma end } | TacGeneralize cl -> @@ -1951,7 +1951,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma = project gl in let cl = interp_clause ist env sigma cl in name_atomic ~env - (TacRewrite (ev,l,cl,by)) + (TacRewrite (ev,l,cl,Option.map ignore by)) (Equality.general_multi_rewrite ev l' cl (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), Equality.Naive) diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml index df7f925b73..511f93569c 100644 --- a/printing/ppannotation.ml +++ b/printing/ppannotation.ml @@ -20,7 +20,6 @@ type t = | AGlobAtomicTacticExpr of glob_atomic_tactic_expr | ARawTacticExpr of raw_tactic_expr | ARawAtomicTacticExpr of raw_atomic_tactic_expr - | ATacticExpr of tactic_expr | AAtomicTacticExpr of atomic_tactic_expr let tag_of_annotation = function @@ -32,7 +31,6 @@ let tag_of_annotation = function | AGlobAtomicTacticExpr _ -> "glob_atomic_tactic_expr" | ARawTacticExpr _ -> "raw_tactic_expr" | ARawAtomicTacticExpr _ -> "raw_atomic_tactic_expr" - | ATacticExpr _ -> "tactic_expr" | AAtomicTacticExpr _ -> "atomic_tactic_expr" let attributes_of_annotation a = diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli index 84724053ed..a0fef1a757 100644 --- a/printing/ppannotation.mli +++ b/printing/ppannotation.mli @@ -23,7 +23,6 @@ type t = | AGlobAtomicTacticExpr of glob_atomic_tactic_expr | ARawTacticExpr of raw_tactic_expr | ARawAtomicTacticExpr of raw_atomic_tactic_expr - | ATacticExpr of tactic_expr | AAtomicTacticExpr of atomic_tactic_expr val tag_of_annotation : t -> string diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 1e6c46e759..3cff541b06 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -94,8 +94,6 @@ module Make : raw_tactic_expr -> std_ppcmds -> std_ppcmds val tag_raw_atomic_tactic_expr : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds - val tag_tactic_expr - : tactic_expr -> std_ppcmds -> std_ppcmds val tag_atomic_tactic_expr : atomic_tactic_expr -> std_ppcmds -> std_ppcmds end) @@ -411,15 +409,11 @@ module Make pr_extend_gen check_type (pr_farg prtac) let pr_glob_extend_rec prc prlc prtac prpat = pr_extend_gen check_type (pr_farg prtac) - let pr_extend_rec prc prlc prtac prpat = - pr_extend_gen check_type (pr_farg prtac) let pr_raw_alias prc prlc prtac prpat = pr_alias_gen check_type (pr_farg prtac) let pr_glob_alias prc prlc prtac prpat = pr_alias_gen check_type (pr_farg prtac) - let pr_alias prc prlc prtac prpat = - pr_alias_gen check_type (pr_farg prtac) (**********************************************************************) (* The tactic printer *) @@ -528,9 +522,8 @@ module Make | ipat -> spc() ++ prc c ++ pr_as_ipat prdc ipat - let pr_by_tactic prt = function - | TacId [] -> mt () - | tac -> spc() ++ keyword "by" ++ spc () ++ prt tac + let pr_by_tactic prt tac = + spc() ++ keyword "by" ++ spc () ++ prt tac let pr_hyp_location pr_id = function | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs @@ -732,7 +725,7 @@ module Make level :'lev > - let rec pr_atom pr strip_prod_binders tag_atom = + let pr_atom pr strip_prod_binders tag_atom = let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in let pr_with_bindings_arg_full = pr_with_bindings_arg in let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in @@ -1255,13 +1248,10 @@ module Make | _ -> error "Cannot translate fix tactic: not enough products" in strip_ty [] n ty - let pr_tactic_level env n t = - let typed_printers = - (strip_prod_binders_constr) - in - let rec prtac n (t:tactic_expr) = + let pr_atomic_tactic_level env n t = + let prtac n (t:atomic_tactic_expr) = let pr = { - pr_tactic = pr_glob_tactic_level env; + pr_tactic = (fun _ _ -> str ""); pr_constr = pr_constr_env env Evd.empty; pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); pr_lconstr = pr_lconstr_env env Evd.empty; @@ -1270,21 +1260,13 @@ module Make pr_constant = pr_evaluable_reference_env env; pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; - pr_generic = pr_top_generic_rec - (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - pr_value pr_constr_pattern; - pr_extend = pr_extend_rec - (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - prtac pr_constr_pattern; - pr_alias = pr_alias - (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - prtac pr_constr_pattern; + (** Those are not used by the atomic printer *) + pr_generic = (fun _ -> assert false); + pr_extend = (fun _ _ _ -> assert false); + pr_alias = (fun _ _ _ -> assert false); } in - make_pr_tac - pr typed_printers - tag_atomic_tactic_expr tag_tactic_expr - n t + pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t in prtac n t @@ -1321,7 +1303,7 @@ module Make let pr_extend pr lev ml args = pr_extend_gen check_val_type pr lev ml args - let pr_tactic env = pr_tactic_level env ltop + let pr_atomic_tactic env = pr_atomic_tactic_level env ltop end @@ -1351,7 +1333,6 @@ include Make (Ppconstr) (struct let tag_glob_atomic_tactic_expr = do_not_tag let tag_raw_tactic_expr = do_not_tag let tag_raw_atomic_tactic_expr = do_not_tag - let tag_tactic_expr = do_not_tag let tag_atomic_tactic_expr = do_not_tag end) @@ -1449,7 +1430,6 @@ module Richpp = struct let tag_glob_atomic_tactic_expr a = tag (AGlobAtomicTacticExpr a) let tag_raw_tactic_expr e = tag (ARawTacticExpr e) let tag_raw_atomic_tactic_expr a = tag (ARawAtomicTacticExpr a) - let tag_tactic_expr e = tag (ATacticExpr e) let tag_atomic_tactic_expr a = tag (AAtomicTacticExpr a) end) diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 95cf541fd7..d4858bac4f 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -57,7 +57,7 @@ module type Pp = sig val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds - val pr_tactic : env -> tactic_expr -> std_ppcmds + val pr_atomic_tactic : env -> atomic_tactic_expr -> std_ppcmds val pr_hintbases : string list option -> std_ppcmds diff --git a/printing/richprinter.ml b/printing/richprinter.ml index d95e190749..5f39f36eab 100644 --- a/printing/richprinter.ml +++ b/printing/richprinter.ml @@ -22,4 +22,3 @@ let make_richpp pr ast = let richpp_vernac = make_richpp RichppVernac.pr_vernac let richpp_constr = make_richpp RichppConstr.pr_constr_expr -let richpp_tactic env = make_richpp (RichppTactic.pr_tactic env) diff --git a/printing/richprinter.mli b/printing/richprinter.mli index 261d22c4c3..c9e84e3eb4 100644 --- a/printing/richprinter.mli +++ b/printing/richprinter.mli @@ -34,6 +34,3 @@ val richpp_vernac : Vernacexpr.vernac_expr -> rich_pp (** [richpp_constr constr] produces a rich pretty-printing of [constr]. *) val richpp_constr : Constrexpr.constr_expr -> rich_pp - -(** [richpp_tactic constr] produces a rich pretty-printing of [tactic]. *) -val richpp_tactic : Environ.env -> Tacexpr.tactic_expr -> rich_pp -- cgit v1.2.3 From d78784bd86d3d571bb2891356e9e9718c69976ba Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 10 Apr 2016 14:30:25 +0200 Subject: Fixing printing of "destruct in" after ce71ac17268f. --- printing/pptactic.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 3cff541b06..19536d9f83 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -878,7 +878,7 @@ module Make ++ prlist_with_sep pr_comma (fun ((clear_flag,h),ids,cl) -> pr_clear_flag clear_flag (pr_induction_arg pr.pr_dconstr pr.pr_dconstr) h ++ pr_with_induction_names pr.pr_dconstr ids ++ - pr_opt_no_spc (pr_clauses None pr.pr_name) cl) l ++ + pr_opt (pr_clauses None pr.pr_name) cl) l ++ pr_opt pr_eliminator el ) | TacDoubleInduction (h1,h2) -> -- cgit v1.2.3 From e9aa3e6b70b1bab7138187733f6647b655a81b0b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Apr 2016 13:45:57 +0200 Subject: Allowing the presence of TYPED AS in specialized ARGUMENT EXTEND. This allows to use the ARGUMENT EXTEND macro while sharing the same toplevel dynamic representation as another argument. --- grammar/argextend.ml4 | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index adfbd8cfde..c0be4598e1 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -73,11 +73,11 @@ let make_extend loc s cl wit = match cl with let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in $lid:s$ >> -let declare_tactic_argument loc s (typ, pr, f, g, h) cl = - let rawtyp, rawpr, globtyp, globpr = match typ with - | `Uniform typ -> - typ, pr, typ, pr - | `Specialized (a, b, c, d) -> a, b, c, d +let declare_tactic_argument loc s (typ, f, g, h) cl = + let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with + | `Uniform (typ, pr) -> + typ, pr, typ, pr, Some typ, pr + | `Specialized (a, b, c, d, e, f) -> a, b, c, d, e, f in let glob = match g with | None -> @@ -121,10 +121,10 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = (Genarg.in_gen $make_globwit loc globtyp$ x)) >> | Some f -> <:expr< $lid:f$>> in let dyn = match typ with - | `Uniform typ -> + | None -> <:expr< None >> + | Some typ -> if is_self s typ then <:expr< None >> else <:expr< Some (Genarg.val_tag $make_topwit loc typ$) >> - | `Specialized _ -> <:expr< None >> in let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in @@ -186,8 +186,9 @@ EXTEND f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ] -> - (`Uniform typ, pr, f, g, h) - | "PRINTED"; "BY"; pr = LIDENT; + (`Uniform (typ, pr), f, g, h) + | typ = OPT [ "TYPED"; "AS"; typ = argtype -> typ ]; + "PRINTED"; "BY"; pr = LIDENT; f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; @@ -195,7 +196,7 @@ EXTEND "RAW_PRINTED"; "BY"; rawpr = LIDENT; "GLOB_TYPED"; "AS"; globtyp = argtype; "GLOB_PRINTED"; "BY"; globpr = LIDENT -> - (`Specialized (rawtyp, rawpr, globtyp, globpr), pr, f, g, h) ] ] + (`Specialized (rawtyp, rawpr, globtyp, globpr, typ, pr), f, g, h) ] ] ; argtype: [ "2" -- cgit v1.2.3 From 116f8338b6fd60fdcf0f244772bcd6c82af5e333 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Apr 2016 13:57:32 +0200 Subject: Allowing simple ARGUMENT EXTEND not to mention their self type. The TYPED AS clause was useless when defining a fresh generic argument. Instead of having to write it mandatorily, we simply make it optional. --- grammar/argextend.ml4 | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index c0be4598e1..52119a963a 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -75,8 +75,9 @@ let make_extend loc s cl wit = match cl with let declare_tactic_argument loc s (typ, f, g, h) cl = let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with - | `Uniform (typ, pr) -> - typ, pr, typ, pr, Some typ, pr + | `Uniform (otyp, pr) -> + let typ = match otyp with Some typ -> typ | None -> ExtraArgType s in + typ, pr, typ, pr, otyp, pr | `Specialized (a, b, c, d, e, f) -> a, b, c, d, e, f in let glob = match g with @@ -180,23 +181,25 @@ EXTEND "END" -> declare_vernac_argument loc s pr l ] ] ; + argextend_specialized: + [ [ "RAW_TYPED"; "AS"; rawtyp = argtype; + "RAW_PRINTED"; "BY"; rawpr = LIDENT; + "GLOB_TYPED"; "AS"; globtyp = argtype; + "GLOB_PRINTED"; "BY"; globpr = LIDENT -> + (rawtyp, rawpr, globtyp, globpr) ] ] + ; argextend_header: - [ [ "TYPED"; "AS"; typ = argtype; - "PRINTED"; "BY"; pr = LIDENT; - f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; - g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; - h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ] -> - (`Uniform (typ, pr), f, g, h) - | typ = OPT [ "TYPED"; "AS"; typ = argtype -> typ ]; + [ [ typ = OPT [ "TYPED"; "AS"; typ = argtype -> typ ]; "PRINTED"; "BY"; pr = LIDENT; f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ]; g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ]; h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; - "RAW_TYPED"; "AS"; rawtyp = argtype; - "RAW_PRINTED"; "BY"; rawpr = LIDENT; - "GLOB_TYPED"; "AS"; globtyp = argtype; - "GLOB_PRINTED"; "BY"; globpr = LIDENT -> - (`Specialized (rawtyp, rawpr, globtyp, globpr, typ, pr), f, g, h) ] ] + special = OPT argextend_specialized -> + let repr = match special with + | None -> `Uniform (typ, pr) + | Some (rtyp, rpr, gtyp, gpr) -> `Specialized (rtyp, rpr, gtyp, gpr, typ, pr) + in + (repr, f, g, h) ] ] ; argtype: [ "2" -- cgit v1.2.3 From 5ecdba3505a1dd8e713503657c1a0acbef0796a7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Apr 2016 14:10:07 +0200 Subject: Warning for redundant TYPED AS clauses. --- grammar/argextend.ml4 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 52119a963a..33cd62e3a9 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -76,7 +76,12 @@ let make_extend loc s cl wit = match cl with let declare_tactic_argument loc s (typ, f, g, h) cl = let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with | `Uniform (otyp, pr) -> - let typ = match otyp with Some typ -> typ | None -> ExtraArgType s in + let typ = match otyp with + | None -> ExtraArgType s + | Some typ -> + let () = if is_self s typ then Printf.eprintf "Redundant [TYPED AS %s] clause.\n%!" s in + typ + in typ, pr, typ, pr, otyp, pr | `Specialized (a, b, c, d, e, f) -> a, b, c, d, e, f in -- cgit v1.2.3 From 9719ac37ed51ccadaf81712793057d5c0c3235cf Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Apr 2016 15:45:52 +0200 Subject: Allowing optional RAW_TYPED and GLOB_TYPED clauses in ARGUMENT EXTEND. --- grammar/argextend.ml4 | 53 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 31 insertions(+), 22 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 33cd62e3a9..4fd9cd9da0 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -73,40 +73,48 @@ let make_extend loc s cl wit = match cl with let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in $lid:s$ >> +let warning_redundant prefix s = + Printf.eprintf "Redundant [%sTYPED AS %s] clause.\n%!" prefix s + +let get_type prefix s = function +| None -> None +| Some typ -> + if is_self s typ then + let () = warning_redundant prefix s in None + else Some typ + let declare_tactic_argument loc s (typ, f, g, h) cl = let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with - | `Uniform (otyp, pr) -> - let typ = match otyp with - | None -> ExtraArgType s - | Some typ -> - let () = if is_self s typ then Printf.eprintf "Redundant [TYPED AS %s] clause.\n%!" s in - typ - in - typ, pr, typ, pr, otyp, pr - | `Specialized (a, b, c, d, e, f) -> a, b, c, d, e, f + | `Uniform (typ, pr) -> + let typ = get_type "" s typ in + typ, pr, typ, pr, typ, pr + | `Specialized (a, b, c, d, e, f) -> + get_type "RAW_" s a, b, get_type "GLOB_" s c, d, e, f in let glob = match g with | None -> - if is_self s rawtyp then - <:expr< fun ist v -> (ist, v) >> - else + begin match rawtyp with + | None -> <:expr< fun ist v -> (ist, v) >> + | Some rawtyp -> <:expr< fun ist v -> let ans = out_gen $make_globwit loc rawtyp$ (Tacintern.intern_genarg ist (Genarg.in_gen $make_rawwit loc rawtyp$ v)) in (ist, ans) >> + end | Some f -> <:expr< fun ist v -> (ist, $lid:f$ ist v) >> in let interp = match f with | None -> - if is_self s globtyp then - <:expr< fun ist v -> Ftactic.return v >> - else - <:expr< fun ist x -> + begin match globtyp with + | None -> <:expr< fun ist v -> Ftactic.return v >> + | Some globtyp -> + <:expr< fun ist x -> Ftactic.bind - (Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x)) + (Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x)) (fun v -> Ftactic.return (Tacinterp.Value.cast $make_topwit loc globtyp$ v)) >> + end | Some f -> (** Compatibility layer, TODO: remove me *) <:expr< @@ -118,13 +126,14 @@ let declare_tactic_argument loc s (typ, f, g, h) cl = >> in let subst = match h with | None -> - if is_self s globtyp then - <:expr< fun s v -> v >> - else + begin match globtyp with + | None -> <:expr< fun s v -> v >> + | Some globtyp -> <:expr< fun s x -> out_gen $make_globwit loc globtyp$ (Tacsubst.subst_genarg s (Genarg.in_gen $make_globwit loc globtyp$ x)) >> + end | Some f -> <:expr< $lid:f$>> in let dyn = match typ with | None -> <:expr< None >> @@ -187,9 +196,9 @@ EXTEND declare_vernac_argument loc s pr l ] ] ; argextend_specialized: - [ [ "RAW_TYPED"; "AS"; rawtyp = argtype; + [ [ rawtyp = OPT [ "RAW_TYPED"; "AS"; rawtyp = argtype -> rawtyp ]; "RAW_PRINTED"; "BY"; rawpr = LIDENT; - "GLOB_TYPED"; "AS"; globtyp = argtype; + globtyp = OPT [ "GLOB_TYPED"; "AS"; globtyp = argtype -> globtyp ]; "GLOB_PRINTED"; "BY"; globpr = LIDENT -> (rawtyp, rawpr, globtyp, globpr) ] ] ; -- cgit v1.2.3 From 137888c3aaab15bc26f7b4ffac7e53469fb1bb3e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Apr 2016 16:22:19 +0200 Subject: Adding warnings for inferrable *_TYPED AS clauses. --- grammar/argextend.ml4 | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 4fd9cd9da0..dca3e1656f 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -74,7 +74,7 @@ let make_extend loc s cl wit = match cl with $lid:s$ >> let warning_redundant prefix s = - Printf.eprintf "Redundant [%sTYPED AS %s] clause.\n%!" prefix s + Printf.eprintf "Redundant [%sTYPED AS] clause in [ARGUMENT EXTEND %s].\n%!" prefix s let get_type prefix s = function | None -> None @@ -83,13 +83,23 @@ let get_type prefix s = function let () = warning_redundant prefix s in None else Some typ +let check_type prefix s = function +| None -> () +| Some _ -> warning_redundant prefix s + let declare_tactic_argument loc s (typ, f, g, h) cl = let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with | `Uniform (typ, pr) -> let typ = get_type "" s typ in typ, pr, typ, pr, typ, pr - | `Specialized (a, b, c, d, e, f) -> - get_type "RAW_" s a, b, get_type "GLOB_" s c, d, e, f + | `Specialized (a, rpr, c, gpr, e, tpr) -> + (** Check that we actually need the TYPED AS arguments *) + let rawtyp = get_type "RAW_" s a in + let glbtyp = get_type "GLOB_" s c in + let toptyp = get_type "" s e in + let () = match g with None -> () | Some _ -> check_type "RAW_" s rawtyp in + let () = match f, h with Some _, Some _ -> check_type "GLOB_" s glbtyp | _ -> () in + rawtyp, rpr, glbtyp, gpr, toptyp, tpr in let glob = match g with | None -> -- cgit v1.2.3 From fa9c33e37ca609981aca88d6f92b07882bd2f4f4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Apr 2016 16:05:15 +0200 Subject: Removing redundant *_TYPED AS clauses in EXTEND statements. --- ltac/extraargs.ml4 | 17 ----------------- ltac/extratactics.ml4 | 2 -- ltac/g_auto.ml4 | 2 -- ltac/g_rewrite.ml4 | 6 ------ plugins/extraction/g_extraction.ml4 | 1 - 5 files changed, 28 deletions(-) diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 index 4d3507cbc4..f2dc024c71 100644 --- a/ltac/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -110,10 +110,7 @@ ARGUMENT EXTEND occurrences GLOBALIZED BY glob_occs SUBSTITUTED BY subst_occs - RAW_TYPED AS occurrences_or_var RAW_PRINTED BY pr_occurrences - - GLOB_TYPED AS occurrences_or_var GLOB_PRINTED BY pr_occurrences | [ ne_integer_list(l) ] -> [ ArgArg l ] @@ -141,10 +138,7 @@ ARGUMENT EXTEND glob GLOBALIZED BY glob_glob SUBSTITUTED BY subst_glob - RAW_TYPED AS constr_expr RAW_PRINTED BY pr_gen - - GLOB_TYPED AS glob_constr_and_expr GLOB_PRINTED BY pr_gen [ constr(c) ] -> [ c ] END @@ -164,10 +158,7 @@ ARGUMENT EXTEND lglob GLOBALIZED BY glob_glob SUBSTITUTED BY subst_glob - RAW_TYPED AS constr_expr RAW_PRINTED BY pr_gen - - GLOB_TYPED AS glob_constr_and_expr GLOB_PRINTED BY pr_gen [ lconstr(c) ] -> [ c ] END @@ -207,9 +198,7 @@ ARGUMENT EXTEND hloc INTERPRETED BY interp_place GLOBALIZED BY intern_place SUBSTITUTED BY subst_place - RAW_TYPED AS loc_place RAW_PRINTED BY pr_loc_place - GLOB_TYPED AS loc_place GLOB_PRINTED BY pr_loc_place [ ] -> [ ConclLocation () ] @@ -224,12 +213,6 @@ ARGUMENT EXTEND hloc END - - - - - - (* Julien: Mise en commun des differentes version de replace with in by *) let pr_by_arg_tac _prc _prlc prtac opt_c = diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 index ba9f82fb96..0b475340e2 100644 --- a/ltac/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -980,9 +980,7 @@ let interp_test ist gls = function ARGUMENT EXTEND test PRINTED BY pr_itest' INTERPRETED BY interp_test - RAW_TYPED AS test RAW_PRINTED BY pr_test' - GLOB_TYPED AS test GLOB_PRINTED BY pr_test' | [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] END diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index bc98b7d6d4..d4fd8a1df3 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -174,7 +174,6 @@ END let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom ARGUMENT EXTEND hints_path_atom - TYPED AS hints_path_atom PRINTED BY pr_hints_path_atom | [ global_list(g) ] -> [ Hints.PathHints (List.map Nametab.global g) ] | [ "*" ] -> [ Hints.PathAny ] @@ -183,7 +182,6 @@ END let pr_hints_path prc prx pry c = Hints.pp_hints_path c ARGUMENT EXTEND hints_path - TYPED AS hints_path PRINTED BY pr_hints_path | [ "(" hints_path(p) ")" ] -> [ p ] | [ "!" hints_path(p) ] -> [ Hints.PathStar p ] diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 index c4ef1f297e..395c2cd1b6 100644 --- a/ltac/g_rewrite.ml4 +++ b/ltac/g_rewrite.ml4 @@ -47,10 +47,7 @@ ARGUMENT EXTEND glob_constr_with_bindings GLOBALIZED BY glob_glob_constr_with_bindings SUBSTITUTED BY subst_glob_constr_with_bindings - RAW_TYPED AS constr_expr_with_bindings RAW_PRINTED BY pr_constr_expr_with_bindings - - GLOB_TYPED AS glob_constr_with_bindings GLOB_PRINTED BY pr_glob_constr_with_bindings [ constr_with_bindings(bl) ] -> [ bl ] @@ -76,10 +73,7 @@ ARGUMENT EXTEND rewstrategy GLOBALIZED BY glob_strategy SUBSTITUTED BY subst_strategy - RAW_TYPED AS raw_strategy RAW_PRINTED BY pr_raw_strategy - - GLOB_TYPED AS glob_strategy GLOB_PRINTED BY pr_glob_strategy [ glob(c) ] -> [ StratConstr (c, true) ] diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 7bd07f6255..ca4e13e125 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -35,7 +35,6 @@ let pr_int_or_id _ _ _ = function | ArgId id -> pr_id id ARGUMENT EXTEND int_or_id - TYPED AS int_or_id PRINTED BY pr_int_or_id | [ preident(id) ] -> [ ArgId (Id.of_string id) ] | [ integer(i) ] -> [ ArgInt i ] -- cgit v1.2.3 From d632f64403da813e240973a9caf06c79e262a7ec Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 11 Apr 2016 16:41:49 +0200 Subject: Adding toplevel representation sharing for some generic arguments. --- ltac/extraargs.ml4 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 index f2dc024c71..fbae17bafc 100644 --- a/ltac/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -104,6 +104,7 @@ let glob_occs ist l = l let subst_occs evm l = l ARGUMENT EXTEND occurrences + TYPED AS int list PRINTED BY pr_int_list_full INTERPRETED BY interp_occs @@ -152,6 +153,7 @@ ARGUMENT EXTEND lconstr END ARGUMENT EXTEND lglob + TYPED AS glob PRINTED BY pr_globc INTERPRETED BY interp_glob -- cgit v1.2.3 From 87a81fd7e6ff6b45c76690471eb671ba4b005338 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 14 Apr 2016 18:59:16 +0200 Subject: Moving and enhancing the grammar_tactic_prod_item_expr type. --- intf/vernacexpr.mli | 4 ---- ltac/g_ltac.ml4 | 12 ++++++------ ltac/tacentries.ml | 26 +++++++++++++++++--------- ltac/tacentries.mli | 6 +++++- printing/ppvernac.ml | 6 ------ 5 files changed, 28 insertions(+), 26 deletions(-) diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 14a80379ec..ae9328fcc0 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -200,10 +200,6 @@ type one_inductive_expr = type proof_expr = plident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option) -type grammar_tactic_prod_item_expr = - | TacTerm of string - | TacNonTerm of Loc.t * string * (Names.Id.t * string) - type syntax_modifier = | SetItemLevel of string list * Extend.production_level | SetLevel of int diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index 56f32196b6..fe750f429f 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -385,18 +385,18 @@ VERNAC ARGUMENT EXTEND ltac_production_sep END let pr_ltac_production_item = function -| TacTerm s -> quote (str s) -| TacNonTerm (_, arg, (id, sep)) -> +| Tacentries.TacTerm s -> quote (str s) +| Tacentries.TacNonTerm (_, (arg, sep), id) -> let sep = match sep with - | "" -> mt () - | sep -> str "," ++ spc () ++ quote (str sep) + | None -> mt () + | Some sep -> str "," ++ spc () ++ quote (str sep) in str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item -| [ string(s) ] -> [ TacTerm s ] +| [ string(s) ] -> [ Tacentries.TacTerm s ] | [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ TacNonTerm (loc, Names.Id.to_string nt, (p, Option.default "" sep)) ] + [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ] END VERNAC COMMAND EXTEND VernacTacticNotation diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index ced4733433..46e48c6953 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -19,6 +19,10 @@ open Vernacexpr open Libnames open Nameops +type 'a grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) @@ -60,24 +64,28 @@ let get_tacentry n m = else if check_lvl (n + 1) then EntryName (rawwit Constrarg.wit_tactic, Anext) else EntryName (rawwit Constrarg.wit_tactic, atactic n) +let get_separator = function +| None -> error "Missing separator." +| Some sep -> sep + let rec parse_user_entry s sep = let open Extend in let l = String.length s in if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + let entry = parse_user_entry (String.sub s 3 (l-8)) None in Ulist1 entry else if l > 12 && coincide s "ne_" 0 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 3 (l-12)) "" in - Ulist1sep (entry, sep) + let entry = parse_user_entry (String.sub s 3 (l-12)) None in + Ulist1sep (entry, get_separator sep) else if l > 5 && coincide s "_list" (l-5) then - let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + let entry = parse_user_entry (String.sub s 0 (l-5)) None in Ulist0 entry else if l > 9 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry (String.sub s 0 (l-9)) "" in - Ulist0sep (entry, sep) + let entry = parse_user_entry (String.sub s 0 (l-9)) None in + Ulist0sep (entry, get_separator sep) else if l > 4 && coincide s "_opt" (l-4) then - let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + let entry = parse_user_entry (String.sub s 0 (l-4)) None in Uopt entry else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in @@ -208,7 +216,7 @@ let extend_ml_tactic_grammar n ntn = extend_grammar ml_tactic_grammar (n, ntn) let interp_prod_item lev = function | TacTerm s -> GramTerminal s - | TacNonTerm (loc, nt, (_, sep)) -> + | TacNonTerm (loc, (nt, sep), _) -> let EntryName (etyp, e) = interp_entry_name lev nt sep in GramNonTerminal (loc, etyp, e) @@ -284,7 +292,7 @@ let inTacticGrammar : tactic_grammar_obj -> obj = let cons_production_parameter = function | TacTerm _ -> None -| TacNonTerm (_, _, (id, _)) -> Some id +| TacNonTerm (_, _, id) -> Some id let add_tactic_notation (local,n,prods,e) = let ids = List.map_filter cons_production_parameter prods in diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli index b60d8f478e..0f4bb2530e 100644 --- a/ltac/tacentries.mli +++ b/ltac/tacentries.mli @@ -9,10 +9,14 @@ open Vernacexpr open Tacexpr +type 'a grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + (** Adding a tactic notation in the environment *) val add_tactic_notation : - locality_flag * int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> + locality_flag * int * (string * string option) grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit val add_ml_tactic_notation : ml_tactic_name -> diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 9054ba0b67..f0548238a7 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -104,12 +104,6 @@ module Make if s.[0] == '$' then Id.of_string (String.sub s 1 (String.length s - 1)) else id - let pr_production_item = function - | TacNonTerm (loc, nt, (p, sep)) -> - let pp_sep = if not (String.is_empty sep) then str "," ++ quote (str sep) else mt () in - str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")" - | TacTerm s -> qs s - let pr_comment pr_c = function | CommentConstr c -> pr_c c | CommentString s -> qs s -- cgit v1.2.3 From a88f5f162272ced5fb2b8ea555756b8fc51b939a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 22 Oct 2015 18:22:26 +0200 Subject: This is an attempt to clarify terminology in choosing variable names in file indtypes.ml so that it is easier to follow what the code is doing. This is a purely alpha-renaming commit (if no mistakes). Note: was submitted as pull request #116. --- kernel/indtypes.ml | 200 +++++++++++++++++++++++++++++------------------------ 1 file changed, 109 insertions(+), 91 deletions(-) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 33abfe5b76..edb758f078 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -22,6 +22,16 @@ open Entries open Pp open Context.Rel.Declaration +(* Terminology: +paramdecls (ou paramsctxt?) +args = params + realargs (called vargs when an array, largs when a list) +params = recparams + nonrecparams +nonrecargs = nonrecparams + realargs +env_ar = initial env + declaration of inductive types +env_ar_par = env_ar + declaration of parameters +nmr = ongoing computation of recursive parameters +*) + (* Tell if indices (aka real arguments) contribute to size of inductive type *) (* If yes, this is compatible with the univalent model *) @@ -186,15 +196,16 @@ let is_impredicative env u = polymorphism. The elements x_k is None if the k-th parameter (starting from the most recent and ignoring let-definitions) is not contributing or is Some u_k if its level is u_k and is contributing. *) -let param_ccls params = - let fold acc = function (LocalAssum (_, p)) -> +let param_ccls paramsctxt = + let fold acc = function + | (LocalAssum (_, p)) -> (let c = strip_prod_assum p in match kind_of_term c with | Sort (Type u) -> Univ.Universe.level u | _ -> None) :: acc | LocalDef _ -> acc in - List.fold_left fold [] params + List.fold_left fold [] paramsctxt (* Type-check an inductive definition. Does not check positivity conditions. *) @@ -210,7 +221,7 @@ let typecheck_inductive env mie = mind_check_names mie; (* Params are typed-checked here *) let env' = push_context mie.mind_entry_universes env in - let (env_params, params) = infer_local_decls env' mie.mind_entry_params in + let (env_params,paramsctxt) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows building the environment of arities and to share *) (* the set of constraints *) @@ -249,26 +260,26 @@ let typecheck_inductive env mie = later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) - let full_arity = it_mkProd_or_LetIn arity params in + let full_arity = it_mkProd_or_LetIn arity paramsctxt in let id = ind.mind_entry_typename in let env_ar' = push_rel (LocalAssum (Name id, full_arity)) env_ar in (* (add_constraints cst2 env_ar) in *) - (env_ar', (id,full_arity,sign @ params,expltype,deflev,inflev)::l)) + (env_ar', (id,full_arity,sign @ paramsctxt,expltype,deflev,inflev)::l)) (env',[]) mie.mind_entry_inds in let arity_list = List.rev rev_arity_list in (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) - let env_ar_par = push_rel_context params env_arities in + let env_ar_par = push_rel_context paramsctxt env_arities in (* Now, we type the constructors (without params) *) let inds = List.fold_right2 (fun ind arity_data inds -> let (lc',cstrs_univ) = - infer_constructor_packet env_ar_par params ind.mind_entry_lc in + infer_constructor_packet env_ar_par paramsctxt ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in let ind' = (arity_data,consnames,lc',cstrs_univ) in ind'::inds) @@ -324,7 +335,7 @@ let typecheck_inductive env mie = Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " ++ Universe.pr clev) else - TemplateArity (param_ccls params, infu) + TemplateArity (param_ccls paramsctxt, infu) | _ (* Not an explicit occurrence of Type *) -> full_polymorphic () in @@ -334,7 +345,7 @@ let typecheck_inductive env mie = in (id,cn,lc,(sign,arity))) inds - in (env_arities, env_ar_par, params, inds) + in (env_arities, env_ar_par, paramsctxt, inds) (************************************************************************) (************************************************************************) @@ -354,21 +365,22 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env nbpar c err = - let (lpar,c') = mind_extract_params nbpar c in +let explain_ind_err id ntyp env nparamsctxt c err = + let (lparams,c') = mind_extract_params nparamsctxt c in match err with | LocalNonPos kt -> - raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) + raise (InductiveError (NonPos (env,c',mkRel (kt+nparamsctxt)))) | LocalNotEnoughArgs kt -> raise (InductiveError - (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) + (NotEnoughArgs (env,c',mkRel (kt+nparamsctxt)))) | LocalNotConstructor (paramsctxt,nargs)-> let nparams = Context.Rel.nhyps paramsctxt in raise (InductiveError - (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams,nargs))) + (NotConstructor (env,id,c',mkRel (ntyp+nparamsctxt), + nparams,nargs))) | LocalNonPar (n,i,l) -> raise (InductiveError - (NonPar (env,c',n,mkRel i, mkRel (l+nbpar)))) + (NonPar (env,c',n,mkRel i,mkRel (l+nparamsctxt)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do @@ -384,43 +396,50 @@ let failwith_non_pos_list n ntypes l = anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur") (* Check the inductive type is called with the expected parameters *) -let check_correct_par (env,n,ntypes,_) hyps l largs = - let nparams = Context.Rel.nhyps hyps in - let largs = Array.of_list largs in - if Array.length largs < nparams then - raise (IllFormedInd (LocalNotEnoughArgs l)); - let (lpar,largs') = Array.chop nparams largs in - let nhyps = List.length hyps in - let rec check k index = function +(* [n] is the index of the last inductive type in [env] *) +let check_correct_par (env,n,ntypes,_) paramdecls ind_index args = + let nparams = Context.Rel.nhyps paramdecls in + let args = Array.of_list args in + if Array.length args < nparams then + raise (IllFormedInd (LocalNotEnoughArgs ind_index)); + let (params,realargs) = Array.chop nparams args in + let nparamdecls = List.length paramdecls in + let rec check param_index paramdecl_index = function | [] -> () - | LocalDef _ :: hyps -> check k (index+1) hyps - | _::hyps -> - match kind_of_term (whd_betadeltaiota env lpar.(k)) with - | Rel w when Int.equal w index -> check (k-1) (index+1) hyps - | _ -> raise (IllFormedInd (LocalNonPar (k+1, index-n+nhyps+1, l))) - in check (nparams-1) (n-nhyps) hyps; - if not (Array.for_all (noccur_between n ntypes) largs') then - failwith_non_pos_vect n ntypes largs' - -(* Computes the maximum number of recursive parameters : - the first parameters which are constant in recursive arguments - n is the current depth, nmr is the maximum number of possible - recursive parameters *) - -let compute_rec_par (env,n,_,_) hyps nmr largs = + | LocalDef _ :: paramdecls -> + check param_index (paramdecl_index+1) paramdecls + | _::paramdecls -> + match kind_of_term (whd_betadeltaiota env params.(param_index)) with + | Rel w when Int.equal w paramdecl_index -> + check (param_index-1) (paramdecl_index+1) paramdecls + | _ -> + let paramdecl_index_in_env = paramdecl_index-n+nparamdecls+1 in + let err = + LocalNonPar (param_index+1, paramdecl_index_in_env, ind_index) in + raise (IllFormedInd err) + in check (nparams-1) (n-nparamdecls) paramdecls; + if not (Array.for_all (noccur_between n ntypes) realargs) then + failwith_non_pos_vect n ntypes realargs + +(* Computes the maximum number of recursive parameters: + the first parameters which are constant in recursive arguments + [n] is the current depth, [nmr] is the maximum number of possible + recursive parameters *) + +let compute_rec_par (env,n,_,_) paramsctxt nmr largs = if Int.equal nmr 0 then 0 else -(* start from 0, hyps will be in reverse order *) +(* start from 0, params will be in reverse order *) let (lpar,_) = List.chop nmr largs in let rec find k index = function ([],_) -> nmr - | (_,[]) -> assert false (* |hyps|>=nmr *) - | (lp, LocalDef _ :: hyps) -> find k (index-1) (lp,hyps) - | (p::lp,_::hyps) -> + | (_,[]) -> assert false (* |paramsctxt|>=nmr *) + | (lp, LocalDef _ :: paramsctxt) -> find k (index-1) (lp,paramsctxt) + | (p::lp,_::paramsctxt) -> ( match kind_of_term (whd_betadeltaiota env p) with - | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,hyps) + | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,paramsctxt) | _ -> k) - in find 0 (n-1) (lpar,List.rev hyps) + in find 0 (n-1) (lpar,List.rev paramsctxt) (* [env] is the typing environment [n] is the dB of the last inductive type @@ -431,12 +450,12 @@ if Int.equal nmr 0 then 0 else let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra) -let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = +let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) = let auxntyp = 1 in let specif = (lookup_mind_specif env mi, u) in let ty = type_of_inductive env specif in let env' = - let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lpar) in + let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lrecparams) in push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: @@ -457,7 +476,7 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = let array_min nmr a = if Int.equal nmr 0 then 0 else Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a -(** [check_positivity_one ienv hyps (mind,i) nargs lcnames indlc] +(** [check_positivity_one ienv paramsctxt (mind,i) nnonrecargs lcnames indlc] checks the positivity of the [i]-th member of the mutually inductive definition [mind]. It returns an [Rtree.t] which represents the position of the recursive calls of inductive in [i] @@ -465,9 +484,9 @@ let array_min nmr a = if Int.equal nmr 0 then 0 else considered sub-terms) as well as the number of of non-uniform arguments (used to generate induction schemes, so a priori less relevant to the kernel). *) -let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = - let lparams = Context.Rel.length hyps in - let nmr = Context.Rel.nhyps hyps in +let check_positivity_one recursive (env,_,ntypes,_ as ienv) paramsctxt (_,i as ind) nnonrecargs lcnames indlc = + let nparamsctxt = Context.Rel.length paramsctxt in + let nmr = Context.Rel.nhyps paramsctxt in (** Positivity of one argument [c] of a constructor (i.e. the constructor [cn] has a type of the shape [… -> c … -> P], where, more generally, the arrows may be dependent). *) @@ -490,7 +509,7 @@ let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) na let largs = List.map (whd_betadeltaiota env) largs in let nmr1 = (match ra with - Mrec _ -> compute_rec_par ienv hyps nmr largs + Mrec _ -> compute_rec_par ienv paramsctxt nmr largs | _ -> nmr) in (** The case where one of the inductives of the mutually @@ -525,27 +544,27 @@ let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) na (* accesses to the environment are not factorised, but is it worth? *) and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in - let auxnpar = mib.mind_nparams_rec in - let nonrecpar = mib.mind_nparams - auxnpar in - let (lpar,auxlargs) = - try List.chop auxnpar largs + let auxnrecpar = mib.mind_nparams_rec in + let auxnnonrecpar = mib.mind_nparams - auxnrecpar in + let (auxrecparams,auxnonrecargs) = + try List.chop auxnrecpar largs with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (** Inductives of the inductive block being defined are only allowed to appear nested in the parameters of another inductive type. Not in the proper indices. *) - if not (List.for_all (noccur_between n ntypes) auxlargs) then - failwith_non_pos_list n ntypes auxlargs; + if not (List.for_all (noccur_between n ntypes) auxnonrecargs) then + failwith_non_pos_list n ntypes auxnonrecargs; (* Nested mutual inductive types are not supported *) let auxntyp = mib.mind_ntypes in if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) - let auxlcvect = abstract_mind_lc auxntyp auxnpar mip.mind_nf_lc in + let auxlcvect = abstract_mind_lc auxntyp auxnrecpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) - let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in + let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),auxrecparams) in (* Parameters expressed in env' *) - let lpar' = List.map (lift auxntyp) lpar in + let auxrecparams' = List.map (lift auxntyp) auxrecparams in let irecargs_nmr = (** Checks that the "nesting" inductive type is covariant in the relevant parameters. In other words, that the @@ -554,9 +573,9 @@ let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) na positively in the types of the nested constructors. *) Array.map (function c -> - let c' = hnf_prod_applist env' c lpar' in + let c' = hnf_prod_applist env' c auxrecparams' in (* skip non-recursive parameters *) - let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in + let (ienv',c') = ienv_decompose_prod ienv' auxnnonrecpar c' in check_constructors ienv' false nmr c') auxlcvect in @@ -590,8 +609,8 @@ let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) na if check_head then begin match hd with | Rel j when Int.equal j (n + ntypes - i - 1) -> - check_correct_par ienv hyps (ntypes - i) largs - | _ -> raise (IllFormedInd (LocalNotConstructor(hyps,nargs))) + check_correct_par ienv paramsctxt (ntypes - i) largs + | _ -> raise (IllFormedInd (LocalNotConstructor(paramsctxt,nnonrecargs))) end else if not (List.for_all (noccur_between n ntypes) largs) @@ -603,33 +622,32 @@ let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) na let irecargs_nmr = Array.map2 (fun id c -> - let _,rawc = mind_extract_params lparams c in + let _,rawc = mind_extract_params nparamsctxt c in try check_constructors ienv true nmr rawc with IllFormedInd err -> - explain_ind_err id (ntypes-i) env lparams c err) + explain_ind_err id (ntypes-i) env nparamsctxt c err) (Array.of_list lcnames) indlc in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr', mk_paths (Mrec ind) irecargs) -(** [check_positivity kn env_ar params] checks that the mutually +(** [check_positivity kn env_ar paramsctxt inds] checks that the mutually inductive block [inds] is strictly positive. *) -let check_positivity kn env_ar params finite inds = +let check_positivity kn env_ar_par paramsctxt finite inds = let ntypes = Array.length inds in let recursive = finite != Decl_kinds.BiFinite in - let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) - (Rtree.mk_rec_calls ntypes) in - let lra_ind = Array.rev_to_list rc in - let lparams = Context.Rel.length params in - let nmr = Context.Rel.nhyps params in + let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in + let ra_env_ar = Array.rev_to_list rc in + let nparamsctxt = Context.Rel.length paramsctxt in + let nmr = Context.Rel.nhyps paramsctxt in let check_one i (_,lcnames,lc,(sign,_)) = - let ra_env = - List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in - let ienv = (env_ar, 1+lparams, ntypes, ra_env) in - let nargs = Context.Rel.nhyps sign - nmr in - check_positivity_one recursive ienv params (kn,i) nargs lcnames lc + let ra_env_ar_par = + List.init nparamsctxt (fun _ -> (Norec,mk_norec)) @ ra_env_ar in + let ienv = (env_ar_par, 1+nparamsctxt, ntypes, ra_env_ar_par) in + let nnonrecargs = Context.Rel.nhyps sign - nmr in + check_positivity_one recursive ienv paramsctxt (kn,i) nnonrecargs lcnames lc in let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr @@ -784,14 +802,14 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params Array.of_list (List.rev kns), Array.of_list (List.rev pbs) -let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr recargs = +let build_inductive env p prv ctx env_ar paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in - let nparamargs = Context.Rel.nhyps params in - let nparamdecls = Context.Rel.length params in + let nparamargs = Context.Rel.nhyps paramsctxt in + let nparamsctxt = Context.Rel.length paramsctxt in let subst, ctx = Univ.abstract_universes p ctx in - let params = Vars.subst_univs_level_context subst params in + let paramsctxt = Vars.subst_univs_level_context subst paramsctxt in let env_ar = let ctx = Environ.rel_context env_ar in let ctx' = Vars.subst_univs_level_context subst ctx in @@ -804,10 +822,10 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in let consnrealdecls = - Array.map (fun (d,_) -> Context.Rel.length d - Context.Rel.length params) + Array.map (fun (d,_) -> Context.Rel.length d - nparamsctxt) splayed_lc in let consnrealargs = - Array.map (fun (d,_) -> Context.Rel.nhyps d - Context.Rel.nhyps params) + Array.map (fun (d,_) -> Context.Rel.nhyps d - nparamargs) splayed_lc in (* Elimination sorts *) let arkind,kelim = @@ -841,7 +859,7 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re mind_arity = arkind; mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign; mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs; - mind_nrealdecls = Context.Rel.length ar_sign - nparamdecls; + mind_nrealdecls = Context.Rel.length ar_sign - nparamsctxt; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealdecls; @@ -871,7 +889,7 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re (try let fields, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in let kns, projs = - compute_projections indsp pkt.mind_typename rid nparamargs params + compute_projections indsp pkt.mind_typename rid nparamargs paramsctxt pkt.mind_consnrealdecls pkt.mind_consnrealargs paramslet fields in Some (Some (rid, kns, projs)) with UndefinableExpansion -> Some None) @@ -885,7 +903,7 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re mind_hyps = hyps; mind_nparams = nparamargs; mind_nparams_rec = nmr; - mind_params_ctxt = params; + mind_params_ctxt = paramsctxt; mind_packets = packets; mind_polymorphic = p; mind_universes = ctx; @@ -897,11 +915,11 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, env_ar_par, params, inds) = typecheck_inductive env mie in + let (env_ar, env_ar_par, paramsctxt, inds) = typecheck_inductive env mie in (* Then check positivity conditions *) - let (nmr,recargs) = check_positivity kn env_ar_par params mie.mind_entry_finite inds in + let (nmr,recargs) = check_positivity kn env_ar_par paramsctxt mie.mind_entry_finite inds in (* Build the inductive packets *) build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private mie.mind_entry_universes - env_ar params kn mie.mind_entry_record mie.mind_entry_finite + env_ar paramsctxt kn mie.mind_entry_record mie.mind_entry_finite inds nmr recargs -- cgit v1.2.3 From 3b3d98acd58e91c960a2e11cd47ac19b2b34f86b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 15 Apr 2016 16:28:33 +0200 Subject: Cleaning unpolished commit 0dfd0fb7d7 on basic functions about union type. --- lib/util.ml | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/lib/util.ml b/lib/util.ml index cae996e332..009dfbe1c1 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -147,22 +147,10 @@ struct let fold_left f g a = function | Inl y -> f a y | Inr y -> g a y - | _ -> a end let map_union = Union.map -(** Lifting equality onto union types. *) -let equal_union f g x y = match x, y with - | Inl x, Inl y -> f x y - | Inr x, Inr y -> g x y - | _, _ -> false - -let fold_left_union f g a = function - | Inl y -> f a y - | Inr y -> g a y - | _ -> a - type iexn = Exninfo.iexn let iraise = Exninfo.iraise -- cgit v1.2.3